summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authormillert <millert@openbsd.org>1997-11-30 07:45:47 +0000
committermillert <millert@openbsd.org>1997-11-30 07:45:47 +0000
commitba47ec9da08b5e716a167fd61325b8edfcb66dd6 (patch)
tree91bc543f2ed3206add10a699e40e1120ba95f742
parentverbose eisa/pci (diff)
downloadwireguard-openbsd-ba47ec9da08b5e716a167fd61325b8edfcb66dd6.tar.xz
wireguard-openbsd-ba47ec9da08b5e716a167fd61325b8edfcb66dd6.zip
perl 5.004_04
-rw-r--r--gnu/usr.bin/perl/Artistic2
-rw-r--r--gnu/usr.bin/perl/Changes16598
-rw-r--r--gnu/usr.bin/perl/Changes5.000185
-rw-r--r--gnu/usr.bin/perl/Changes5.0011299
-rw-r--r--gnu/usr.bin/perl/Changes5.002 (renamed from gnu/usr.bin/perl/Changes.Conf)1533
-rw-r--r--gnu/usr.bin/perl/Changes5.003100
-rw-r--r--gnu/usr.bin/perl/Configure4067
-rw-r--r--gnu/usr.bin/perl/EXTERN.h26
-rw-r--r--gnu/usr.bin/perl/INSTALL1223
-rw-r--r--gnu/usr.bin/perl/INTERN.h8
-rw-r--r--gnu/usr.bin/perl/MANIFEST399
-rw-r--r--gnu/usr.bin/perl/Makefile.SH341
-rw-r--r--gnu/usr.bin/perl/Makefile.bsd-wrapper137
-rw-r--r--gnu/usr.bin/perl/Porting/Glossary1420
-rw-r--r--gnu/usr.bin/perl/Porting/makerel100
-rw-r--r--gnu/usr.bin/perl/Porting/patchls431
-rw-r--r--gnu/usr.bin/perl/Porting/pumpkin.pod1180
-rw-r--r--gnu/usr.bin/perl/README13
-rw-r--r--gnu/usr.bin/perl/README.amiga240
-rw-r--r--gnu/usr.bin/perl/README.cygwin3259
-rw-r--r--gnu/usr.bin/perl/README.os21493
-rw-r--r--gnu/usr.bin/perl/README.plan927
-rw-r--r--gnu/usr.bin/perl/README.qnx22
-rw-r--r--gnu/usr.bin/perl/README.vms408
-rw-r--r--gnu/usr.bin/perl/README.win32583
-rw-r--r--gnu/usr.bin/perl/Todo20
-rw-r--r--gnu/usr.bin/perl/XSUB.h27
-rw-r--r--gnu/usr.bin/perl/av.c87
-rw-r--r--gnu/usr.bin/perl/av.h8
-rw-r--r--gnu/usr.bin/perl/cflags.SH5
-rw-r--r--gnu/usr.bin/perl/compat3.sym46
-rw-r--r--gnu/usr.bin/perl/config.sh.OpenBSD92
-rw-r--r--gnu/usr.bin/perl/config_H529
-rw-r--r--gnu/usr.bin/perl/config_h.SH438
-rw-r--r--gnu/usr.bin/perl/configpm119
-rw-r--r--gnu/usr.bin/perl/configure23
-rw-r--r--gnu/usr.bin/perl/configure.gnu124
-rw-r--r--gnu/usr.bin/perl/cop.h79
-rw-r--r--gnu/usr.bin/perl/cv.h15
-rw-r--r--gnu/usr.bin/perl/cygwin32/cw32imp.h356
-rw-r--r--gnu/usr.bin/perl/cygwin32/gcc212
-rw-r--r--gnu/usr.bin/perl/cygwin32/ld29
-rw-r--r--gnu/usr.bin/perl/cygwin32/perlgcc77
-rw-r--r--gnu/usr.bin/perl/cygwin32/perlld192
-rw-r--r--gnu/usr.bin/perl/deb.c40
-rw-r--r--gnu/usr.bin/perl/doio.c355
-rw-r--r--gnu/usr.bin/perl/doop.c293
-rw-r--r--gnu/usr.bin/perl/dosish.h94
-rw-r--r--gnu/usr.bin/perl/dump.c247
-rw-r--r--gnu/usr.bin/perl/eg/ADB2
-rw-r--r--gnu/usr.bin/perl/eg/README2
-rw-r--r--gnu/usr.bin/perl/eg/cgi/RunMeFirst29
-rw-r--r--gnu/usr.bin/perl/eg/cgi/clickable_image.cgi26
-rw-r--r--gnu/usr.bin/perl/eg/cgi/cookie.cgi88
-rw-r--r--gnu/usr.bin/perl/eg/cgi/crash.cgi6
-rw-r--r--gnu/usr.bin/perl/eg/cgi/customize.cgi92
-rw-r--r--gnu/usr.bin/perl/eg/cgi/diff_upload.cgi68
-rw-r--r--gnu/usr.bin/perl/eg/cgi/file_upload.cgi63
-rw-r--r--gnu/usr.bin/perl/eg/cgi/frameset.cgi81
-rw-r--r--gnu/usr.bin/perl/eg/cgi/index.html111
-rw-r--r--gnu/usr.bin/perl/eg/cgi/internal_links.cgi33
-rw-r--r--gnu/usr.bin/perl/eg/cgi/javascript.cgi105
-rw-r--r--gnu/usr.bin/perl/eg/cgi/monty.cgi83
-rw-r--r--gnu/usr.bin/perl/eg/cgi/multiple_forms.cgi54
-rw-r--r--gnu/usr.bin/perl/eg/cgi/nph-clock.cgi18
-rw-r--r--gnu/usr.bin/perl/eg/cgi/popup.cgi32
-rw-r--r--gnu/usr.bin/perl/eg/cgi/save_state.cgi67
-rw-r--r--gnu/usr.bin/perl/eg/cgi/tryit.cgi37
-rw-r--r--gnu/usr.bin/perl/eg/cgi/wilogo.gif.uu14
-rw-r--r--gnu/usr.bin/perl/eg/changes2
-rw-r--r--gnu/usr.bin/perl/eg/dus2
-rw-r--r--gnu/usr.bin/perl/eg/findcp2
-rw-r--r--gnu/usr.bin/perl/eg/findtar2
-rw-r--r--gnu/usr.bin/perl/eg/g/gcp2
-rw-r--r--gnu/usr.bin/perl/eg/g/gcp.man2
-rw-r--r--gnu/usr.bin/perl/eg/g/ged2
-rw-r--r--gnu/usr.bin/perl/eg/g/gsh2
-rw-r--r--gnu/usr.bin/perl/eg/g/gsh.man2
-rw-r--r--gnu/usr.bin/perl/eg/muck.man2
-rw-r--r--gnu/usr.bin/perl/eg/myrup2
-rw-r--r--gnu/usr.bin/perl/eg/nih7
-rw-r--r--gnu/usr.bin/perl/eg/relink7
-rw-r--r--gnu/usr.bin/perl/eg/rename7
-rw-r--r--gnu/usr.bin/perl/eg/rmfrom2
-rw-r--r--gnu/usr.bin/perl/eg/scan/scan_df2
-rw-r--r--gnu/usr.bin/perl/eg/scan/scan_last2
-rw-r--r--gnu/usr.bin/perl/eg/scan/scan_messages2
-rw-r--r--gnu/usr.bin/perl/eg/scan/scan_passwd2
-rw-r--r--gnu/usr.bin/perl/eg/scan/scan_ps2
-rw-r--r--gnu/usr.bin/perl/eg/scan/scan_sudo2
-rw-r--r--gnu/usr.bin/perl/eg/scan/scan_suid2
-rw-r--r--gnu/usr.bin/perl/eg/scan/scanner2
-rw-r--r--gnu/usr.bin/perl/eg/shmkill2
-rw-r--r--gnu/usr.bin/perl/eg/sysvipc/ipcmsg2
-rw-r--r--gnu/usr.bin/perl/eg/sysvipc/ipcsem6
-rw-r--r--gnu/usr.bin/perl/eg/sysvipc/ipcshm2
-rw-r--r--gnu/usr.bin/perl/eg/van/empty2
-rw-r--r--gnu/usr.bin/perl/eg/van/unvanish2
-rw-r--r--gnu/usr.bin/perl/eg/van/vanexp2
-rw-r--r--gnu/usr.bin/perl/eg/van/vanish2
-rw-r--r--gnu/usr.bin/perl/eg/wrapsuid7
-rw-r--r--gnu/usr.bin/perl/emacs/cperl-mode.el3549
-rw-r--r--gnu/usr.bin/perl/embed.h2980
-rw-r--r--gnu/usr.bin/perl/embed.pl129
-rw-r--r--gnu/usr.bin/perl/ext/DB_File/DB_File.pm1613
-rw-r--r--gnu/usr.bin/perl/ext/DB_File/DB_File.xs336
-rw-r--r--gnu/usr.bin/perl/ext/DB_File/Makefile.PL19
-rw-r--r--gnu/usr.bin/perl/ext/DB_File/typemap15
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/DynaLoader.pm180
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL10
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs29
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs153
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs27
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs35
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs58
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs153
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/dl_os2.xs188
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs44
-rw-r--r--gnu/usr.bin/perl/ext/DynaLoader/dlutils.c18
-rw-r--r--gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm44
-rw-r--r--gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs143
-rw-r--r--gnu/usr.bin/perl/ext/FileHandle/FileHandle.pm467
-rw-r--r--gnu/usr.bin/perl/ext/FileHandle/FileHandle.xs177
-rw-r--r--gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm2
-rw-r--r--gnu/usr.bin/perl/ext/GDBM_File/typemap2
-rw-r--r--gnu/usr.bin/perl/ext/IO/IO.pm36
-rw-r--r--gnu/usr.bin/perl/ext/IO/IO.xs288
-rw-r--r--gnu/usr.bin/perl/ext/IO/Makefile.PL (renamed from gnu/usr.bin/perl/ext/FileHandle/Makefile.PL)5
-rw-r--r--gnu/usr.bin/perl/ext/IO/README4
-rw-r--r--gnu/usr.bin/perl/ext/IO/lib/IO/File.pm167
-rw-r--r--gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm544
-rw-r--r--gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm239
-rw-r--r--gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm68
-rw-r--r--gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm371
-rw-r--r--gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm728
-rw-r--r--gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm2
-rw-r--r--gnu/usr.bin/perl/ext/NDBM_File/hints/dec_osf.pl2
-rw-r--r--gnu/usr.bin/perl/ext/NDBM_File/hints/dynixptx.pl3
-rw-r--r--gnu/usr.bin/perl/ext/NDBM_File/typemap2
-rw-r--r--gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm2
-rw-r--r--gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs21
-rw-r--r--gnu/usr.bin/perl/ext/ODBM_File/hints/dec_osf.pl4
-rw-r--r--gnu/usr.bin/perl/ext/ODBM_File/hints/hpux.pl4
-rw-r--r--gnu/usr.bin/perl/ext/ODBM_File/hints/ultrix.pl4
-rw-r--r--gnu/usr.bin/perl/ext/Opcode/Makefile.PL7
-rw-r--r--gnu/usr.bin/perl/ext/Opcode/Opcode.pm569
-rw-r--r--gnu/usr.bin/perl/ext/Opcode/Opcode.xs472
-rw-r--r--gnu/usr.bin/perl/ext/Opcode/Safe.pm555
-rw-r--r--gnu/usr.bin/perl/ext/Opcode/ops.pm45
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/POSIX.pm85
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/POSIX.pod138
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/POSIX.xs618
-rw-r--r--gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl5
-rw-r--r--gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL7
-rw-r--r--gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm2
-rw-r--r--gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL32
-rw-r--r--gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c2
-rw-r--r--gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h10
-rw-r--r--gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ps2225
-rw-r--r--gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3128
-rw-r--r--gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c4
-rw-r--r--gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h94
-rw-r--r--gnu/usr.bin/perl/ext/SDBM_File/typemap2
-rw-r--r--gnu/usr.bin/perl/ext/Safe/Makefile.PL7
-rw-r--r--gnu/usr.bin/perl/ext/Safe/Safe.pm670
-rw-r--r--gnu/usr.bin/perl/ext/Safe/Safe.xs131
-rw-r--r--gnu/usr.bin/perl/ext/Socket/Socket.pm41
-rw-r--r--gnu/usr.bin/perl/ext/Socket/Socket.xs126
-rw-r--r--gnu/usr.bin/perl/ext/util/extliblist155
-rw-r--r--gnu/usr.bin/perl/ext/util/make_ext30
-rw-r--r--gnu/usr.bin/perl/form.h2
-rw-r--r--gnu/usr.bin/perl/global.sym174
-rw-r--r--gnu/usr.bin/perl/gv.c676
-rw-r--r--gnu/usr.bin/perl/gv.h8
-rw-r--r--gnu/usr.bin/perl/handy.h295
-rw-r--r--gnu/usr.bin/perl/hints/3b1.sh4
-rw-r--r--gnu/usr.bin/perl/hints/README.hints90
-rw-r--r--gnu/usr.bin/perl/hints/aix.sh15
-rw-r--r--gnu/usr.bin/perl/hints/amigaos.sh55
-rw-r--r--gnu/usr.bin/perl/hints/apollo.sh2
-rw-r--r--gnu/usr.bin/perl/hints/aux_3.sh (renamed from gnu/usr.bin/perl/hints/aux.sh)8
-rw-r--r--gnu/usr.bin/perl/hints/broken-db.msg14
-rw-r--r--gnu/usr.bin/perl/hints/bsdos.sh104
-rw-r--r--gnu/usr.bin/perl/hints/convexos.sh8
-rw-r--r--gnu/usr.bin/perl/hints/cxux.sh65
-rw-r--r--gnu/usr.bin/perl/hints/cygwin32.sh50
-rw-r--r--gnu/usr.bin/perl/hints/dcosx.sh188
-rw-r--r--gnu/usr.bin/perl/hints/dec_osf.sh287
-rw-r--r--gnu/usr.bin/perl/hints/dgux.sh86
-rw-r--r--gnu/usr.bin/perl/hints/dnix.sh1
-rw-r--r--gnu/usr.bin/perl/hints/dynixptx.sh31
-rw-r--r--gnu/usr.bin/perl/hints/epix.sh2
-rw-r--r--gnu/usr.bin/perl/hints/esix4.sh4
-rw-r--r--gnu/usr.bin/perl/hints/freebsd.sh35
-rw-r--r--gnu/usr.bin/perl/hints/hpux.sh173
-rw-r--r--gnu/usr.bin/perl/hints/irix_4.sh4
-rw-r--r--gnu/usr.bin/perl/hints/irix_5.sh2
-rw-r--r--gnu/usr.bin/perl/hints/irix_6.sh145
-rw-r--r--gnu/usr.bin/perl/hints/irix_6_0.sh43
-rw-r--r--gnu/usr.bin/perl/hints/irix_6_1.sh43
-rw-r--r--gnu/usr.bin/perl/hints/irix_6_2.sh28
-rw-r--r--gnu/usr.bin/perl/hints/isc.sh6
-rw-r--r--gnu/usr.bin/perl/hints/linux.sh67
-rw-r--r--gnu/usr.bin/perl/hints/lynxos.sh11
-rw-r--r--gnu/usr.bin/perl/hints/machten.sh54
-rw-r--r--gnu/usr.bin/perl/hints/machten_2.sh64
-rw-r--r--gnu/usr.bin/perl/hints/mips.sh4
-rw-r--r--gnu/usr.bin/perl/hints/mpeix.sh2
-rw-r--r--gnu/usr.bin/perl/hints/netbsd.sh55
-rw-r--r--gnu/usr.bin/perl/hints/newsos4.sh34
-rw-r--r--gnu/usr.bin/perl/hints/next_3.sh116
-rw-r--r--gnu/usr.bin/perl/hints/next_3_0.sh31
-rw-r--r--gnu/usr.bin/perl/hints/next_4.sh95
-rw-r--r--gnu/usr.bin/perl/hints/os2.sh228
-rw-r--r--gnu/usr.bin/perl/hints/os390.sh33
-rw-r--r--gnu/usr.bin/perl/hints/powerux.sh33
-rw-r--r--gnu/usr.bin/perl/hints/qnx.sh184
-rw-r--r--gnu/usr.bin/perl/hints/sco.sh70
-rw-r--r--gnu/usr.bin/perl/hints/sco_2_3_3.sh4
-rw-r--r--gnu/usr.bin/perl/hints/sco_2_3_4.sh4
-rw-r--r--gnu/usr.bin/perl/hints/solaris_2.sh62
-rw-r--r--gnu/usr.bin/perl/hints/sunos_4_0.sh1
-rw-r--r--gnu/usr.bin/perl/hints/sunos_4_1.sh59
-rw-r--r--gnu/usr.bin/perl/hints/svr4.sh35
-rw-r--r--gnu/usr.bin/perl/hints/titanos.sh11
-rw-r--r--gnu/usr.bin/perl/hints/ultrix_4.sh27
-rw-r--r--gnu/usr.bin/perl/hints/umips.sh39
-rw-r--r--gnu/usr.bin/perl/hints/unicos.sh2
-rw-r--r--gnu/usr.bin/perl/hints/unicosmk.sh3
-rw-r--r--gnu/usr.bin/perl/hints/utekv.sh8
-rw-r--r--gnu/usr.bin/perl/hv.c790
-rw-r--r--gnu/usr.bin/perl/hv.h67
-rw-r--r--gnu/usr.bin/perl/installhtml584
-rw-r--r--gnu/usr.bin/perl/installman52
-rw-r--r--gnu/usr.bin/perl/installperl432
-rw-r--r--gnu/usr.bin/perl/interp.sym14
-rw-r--r--gnu/usr.bin/perl/keywords.h490
-rw-r--r--gnu/usr.bin/perl/keywords.pl5
-rw-r--r--gnu/usr.bin/perl/lib/AnyDBM_File.pm32
-rw-r--r--gnu/usr.bin/perl/lib/AutoLoader.pm260
-rw-r--r--gnu/usr.bin/perl/lib/AutoSplit.pm140
-rw-r--r--gnu/usr.bin/perl/lib/Benchmark.pm274
-rw-r--r--gnu/usr.bin/perl/lib/Bundle/CPAN.pm43
-rw-r--r--gnu/usr.bin/perl/lib/CGI.pm5108
-rw-r--r--gnu/usr.bin/perl/lib/CGI/Apache.pm103
-rw-r--r--gnu/usr.bin/perl/lib/CGI/Carp.pm242
-rw-r--r--gnu/usr.bin/perl/lib/CGI/Fast.pm173
-rw-r--r--gnu/usr.bin/perl/lib/CGI/Push.pm239
-rw-r--r--gnu/usr.bin/perl/lib/CGI/Switch.pm78
-rw-r--r--gnu/usr.bin/perl/lib/CPAN.pm3985
-rw-r--r--gnu/usr.bin/perl/lib/CPAN/FirstTime.pm402
-rw-r--r--gnu/usr.bin/perl/lib/CPAN/Nox.pm33
-rw-r--r--gnu/usr.bin/perl/lib/Carp.pm124
-rw-r--r--gnu/usr.bin/perl/lib/Class/Struct.pm479
-rw-r--r--gnu/usr.bin/perl/lib/Cwd.pm217
-rw-r--r--gnu/usr.bin/perl/lib/Devel/SelfStubber.pm6
-rw-r--r--gnu/usr.bin/perl/lib/English.pm4
-rw-r--r--gnu/usr.bin/perl/lib/Env.pm13
-rw-r--r--gnu/usr.bin/perl/lib/Exporter.pm130
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/Command.pm208
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/Embed.pm486
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/Install.pm112
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm363
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm11
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm556
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm672
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm784
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm197
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm98
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm78
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm68
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/testlib.pm3
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/typemap7
-rw-r--r--gnu/usr.bin/perl/lib/ExtUtils/xsubpp217
-rw-r--r--gnu/usr.bin/perl/lib/File/Basename.pm158
-rw-r--r--gnu/usr.bin/perl/lib/File/Compare.pm143
-rw-r--r--gnu/usr.bin/perl/lib/File/Copy.pm243
-rw-r--r--gnu/usr.bin/perl/lib/File/DosGlob.pm250
-rw-r--r--gnu/usr.bin/perl/lib/File/Find.pm51
-rw-r--r--gnu/usr.bin/perl/lib/File/Path.pm171
-rw-r--r--gnu/usr.bin/perl/lib/File/stat.pm113
-rw-r--r--gnu/usr.bin/perl/lib/FileCache.pm4
-rw-r--r--gnu/usr.bin/perl/lib/FileHandle.pm258
-rw-r--r--gnu/usr.bin/perl/lib/FindBin.pm188
-rw-r--r--gnu/usr.bin/perl/lib/Getopt/Long.pm1021
-rw-r--r--gnu/usr.bin/perl/lib/Getopt/Std.pm54
-rw-r--r--gnu/usr.bin/perl/lib/I18N/Collate.pm80
-rw-r--r--gnu/usr.bin/perl/lib/IPC/Open2.pm72
-rw-r--r--gnu/usr.bin/perl/lib/IPC/Open3.pm253
-rw-r--r--gnu/usr.bin/perl/lib/Math/BigInt.pm30
-rw-r--r--gnu/usr.bin/perl/lib/Math/Complex.pm1659
-rw-r--r--gnu/usr.bin/perl/lib/Math/Trig.pm233
-rw-r--r--gnu/usr.bin/perl/lib/Net/Ping.pm570
-rw-r--r--gnu/usr.bin/perl/lib/Net/hostent.pm149
-rw-r--r--gnu/usr.bin/perl/lib/Net/netent.pm167
-rw-r--r--gnu/usr.bin/perl/lib/Net/protoent.pm94
-rw-r--r--gnu/usr.bin/perl/lib/Net/servent.pm111
-rw-r--r--gnu/usr.bin/perl/lib/Pod/Functions.pm3
-rw-r--r--gnu/usr.bin/perl/lib/Pod/Html.pm1523
-rw-r--r--gnu/usr.bin/perl/lib/Pod/Text.pm120
-rw-r--r--gnu/usr.bin/perl/lib/Search/Dict.pm8
-rw-r--r--gnu/usr.bin/perl/lib/SelectSaver.pm6
-rw-r--r--gnu/usr.bin/perl/lib/SelfLoader.pm156
-rw-r--r--gnu/usr.bin/perl/lib/Shell.pm2
-rw-r--r--gnu/usr.bin/perl/lib/Symbol.pm44
-rw-r--r--gnu/usr.bin/perl/lib/Sys/Hostname.pm26
-rw-r--r--gnu/usr.bin/perl/lib/Sys/Syslog.pm76
-rw-r--r--gnu/usr.bin/perl/lib/Term/Cap.pm15
-rw-r--r--gnu/usr.bin/perl/lib/Term/Complete.pm12
-rw-r--r--gnu/usr.bin/perl/lib/Term/ReadLine.pm172
-rw-r--r--gnu/usr.bin/perl/lib/Test/Harness.pm236
-rw-r--r--gnu/usr.bin/perl/lib/Text/Abbrev.pm52
-rw-r--r--gnu/usr.bin/perl/lib/Text/ParseWords.pm59
-rw-r--r--gnu/usr.bin/perl/lib/Text/Soundex.pm9
-rw-r--r--gnu/usr.bin/perl/lib/Text/Tabs.pm123
-rw-r--r--gnu/usr.bin/perl/lib/Text/Wrap.pm184
-rw-r--r--gnu/usr.bin/perl/lib/Tie/Hash.pm6
-rw-r--r--gnu/usr.bin/perl/lib/Tie/RefHash.pm123
-rw-r--r--gnu/usr.bin/perl/lib/Tie/Scalar.pm4
-rw-r--r--gnu/usr.bin/perl/lib/Tie/SubstrHash.pm10
-rw-r--r--gnu/usr.bin/perl/lib/Time/Local.pm88
-rw-r--r--gnu/usr.bin/perl/lib/Time/gmtime.pm88
-rw-r--r--gnu/usr.bin/perl/lib/Time/localtime.pm84
-rw-r--r--gnu/usr.bin/perl/lib/Time/tm.pm31
-rw-r--r--gnu/usr.bin/perl/lib/UNIVERSAL.pm97
-rw-r--r--gnu/usr.bin/perl/lib/User/grent.pm93
-rw-r--r--gnu/usr.bin/perl/lib/User/pwent.pm103
-rw-r--r--gnu/usr.bin/perl/lib/abbrev.pl2
-rw-r--r--gnu/usr.bin/perl/lib/autouse.pm166
-rw-r--r--gnu/usr.bin/perl/lib/base.pm49
-rw-r--r--gnu/usr.bin/perl/lib/bigfloat.pl6
-rw-r--r--gnu/usr.bin/perl/lib/bigint.pl28
-rw-r--r--gnu/usr.bin/perl/lib/blib.pm71
-rw-r--r--gnu/usr.bin/perl/lib/cacheout.pl2
-rw-r--r--gnu/usr.bin/perl/lib/chat2.inter495
-rw-r--r--gnu/usr.bin/perl/lib/complete.pl5
-rw-r--r--gnu/usr.bin/perl/lib/constant.pm163
-rw-r--r--gnu/usr.bin/perl/lib/diagnostics.pm94
-rw-r--r--gnu/usr.bin/perl/lib/dotsh.pl4
-rw-r--r--gnu/usr.bin/perl/lib/dumpvar.pl21
-rw-r--r--gnu/usr.bin/perl/lib/find.pl85
-rw-r--r--gnu/usr.bin/perl/lib/finddepth.pl83
-rw-r--r--gnu/usr.bin/perl/lib/ftp.pl18
-rw-r--r--gnu/usr.bin/perl/lib/getcwd.pl8
-rw-r--r--gnu/usr.bin/perl/lib/getopt.pl4
-rw-r--r--gnu/usr.bin/perl/lib/getopts.pl9
-rw-r--r--gnu/usr.bin/perl/lib/importenv.pl2
-rw-r--r--gnu/usr.bin/perl/lib/lib.pm19
-rw-r--r--gnu/usr.bin/perl/lib/locale.pm33
-rw-r--r--gnu/usr.bin/perl/lib/look.pl6
-rw-r--r--gnu/usr.bin/perl/lib/newgetopt.pl12
-rw-r--r--gnu/usr.bin/perl/lib/open2.pl60
-rw-r--r--gnu/usr.bin/perl/lib/open3.pl110
-rw-r--r--gnu/usr.bin/perl/lib/overload.pm210
-rw-r--r--gnu/usr.bin/perl/lib/perl5db.pl1104
-rw-r--r--gnu/usr.bin/perl/lib/sigtrap.pm258
-rw-r--r--gnu/usr.bin/perl/lib/splain503
-rw-r--r--gnu/usr.bin/perl/lib/strict.pm9
-rw-r--r--gnu/usr.bin/perl/lib/subs.pm8
-rw-r--r--gnu/usr.bin/perl/lib/syslog.pl6
-rw-r--r--gnu/usr.bin/perl/lib/termcap.pl5
-rw-r--r--gnu/usr.bin/perl/lib/timelocal.pl109
-rw-r--r--gnu/usr.bin/perl/lib/validate.pl4
-rw-r--r--gnu/usr.bin/perl/lib/vars.pm67
-rw-r--r--gnu/usr.bin/perl/makeaperl.SH5
-rw-r--r--gnu/usr.bin/perl/makedepend.SH40
-rw-r--r--gnu/usr.bin/perl/malloc.c530
-rw-r--r--gnu/usr.bin/perl/mg.c862
-rw-r--r--gnu/usr.bin/perl/mg.h11
-rw-r--r--gnu/usr.bin/perl/minimod.pl6
-rw-r--r--gnu/usr.bin/perl/miniperlmain.c14
-rw-r--r--gnu/usr.bin/perl/myconfig6
-rw-r--r--gnu/usr.bin/perl/nostdio.h26
-rw-r--r--gnu/usr.bin/perl/op.c1453
-rw-r--r--gnu/usr.bin/perl/op.h51
-rw-r--r--gnu/usr.bin/perl/opcode.h357
-rw-r--r--gnu/usr.bin/perl/opcode.pl66
-rw-r--r--gnu/usr.bin/perl/os2/Changes165
-rw-r--r--gnu/usr.bin/perl/os2/Makefile.SHs155
-rw-r--r--gnu/usr.bin/perl/os2/OS2/ExtAttr/Changes5
-rw-r--r--gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.pm186
-rw-r--r--gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.xs193
-rw-r--r--gnu/usr.bin/perl/os2/OS2/ExtAttr/MANIFEST8
-rw-r--r--gnu/usr.bin/perl/os2/OS2/ExtAttr/Makefile.PL11
-rw-r--r--gnu/usr.bin/perl/os2/OS2/ExtAttr/myea.h2
-rw-r--r--gnu/usr.bin/perl/os2/OS2/ExtAttr/t/os2_ea.t79
-rw-r--r--gnu/usr.bin/perl/os2/OS2/ExtAttr/typemap2
-rw-r--r--gnu/usr.bin/perl/os2/OS2/PrfDB/Changes5
-rw-r--r--gnu/usr.bin/perl/os2/OS2/PrfDB/MANIFEST7
-rw-r--r--gnu/usr.bin/perl/os2/OS2/PrfDB/Makefile.PL11
-rw-r--r--gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.pm314
-rw-r--r--gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.xs131
-rw-r--r--gnu/usr.bin/perl/os2/OS2/PrfDB/t/os2_prfdb.t190
-rw-r--r--gnu/usr.bin/perl/os2/OS2/PrfDB/typemap14
-rw-r--r--gnu/usr.bin/perl/os2/OS2/Process/MANIFEST4
-rw-r--r--gnu/usr.bin/perl/os2/OS2/Process/Makefile.PL11
-rw-r--r--gnu/usr.bin/perl/os2/OS2/Process/Process.pm112
-rw-r--r--gnu/usr.bin/perl/os2/OS2/Process/Process.xs154
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/Changes4
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/MANIFEST14
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/Makefile.PL8
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/REXX.pm389
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/REXX.xs484
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/t/rx_cmprt.t40
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/t/rx_dllld.t36
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/t/rx_objcall.t33
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/t/rx_sql.test97
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tiesql.test86
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tievar.t88
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tieydb.t31
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/t/rx_varset.t39
-rw-r--r--gnu/usr.bin/perl/os2/OS2/REXX/t/rx_vrexx.t59
-rw-r--r--gnu/usr.bin/perl/os2/README229
-rw-r--r--gnu/usr.bin/perl/os2/README.old529
-rw-r--r--gnu/usr.bin/perl/os2/diff.configure863
-rw-r--r--gnu/usr.bin/perl/os2/diff.db_file15
-rw-r--r--gnu/usr.bin/perl/os2/dl_os2.c71
-rw-r--r--gnu/usr.bin/perl/os2/dlfcn.h3
-rw-r--r--gnu/usr.bin/perl/os2/notes28
-rw-r--r--gnu/usr.bin/perl/os2/os2.c1123
-rw-r--r--gnu/usr.bin/perl/os2/os2ish.h311
-rw-r--r--gnu/usr.bin/perl/os2/perl2cmd.pl5
-rw-r--r--gnu/usr.bin/perl/patchlevel.h12
-rw-r--r--gnu/usr.bin/perl/perl.c1603
-rw-r--r--gnu/usr.bin/perl/perl.h1021
-rw-r--r--gnu/usr.bin/perl/perl_exp.SH97
-rw-r--r--gnu/usr.bin/perl/perlio.c656
-rw-r--r--gnu/usr.bin/perl/perlio.h199
-rw-r--r--gnu/usr.bin/perl/perlio.sym49
-rw-r--r--gnu/usr.bin/perl/perlsdio.h309
-rw-r--r--gnu/usr.bin/perl/perlsfio.h58
-rw-r--r--gnu/usr.bin/perl/perlsh2
-rw-r--r--gnu/usr.bin/perl/perly.c2811
-rw-r--r--gnu/usr.bin/perl/perly.c.diff260
-rw-r--r--gnu/usr.bin/perl/perly.fixer38
-rw-r--r--gnu/usr.bin/perl/perly.h59
-rw-r--r--gnu/usr.bin/perl/perly.y230
-rw-r--r--gnu/usr.bin/perl/plan9/aperl7
-rw-r--r--gnu/usr.bin/perl/plan9/arpa/inet.h7
-rw-r--r--gnu/usr.bin/perl/plan9/buildinfo1
-rw-r--r--gnu/usr.bin/perl/plan9/config.plan91709
-rw-r--r--gnu/usr.bin/perl/plan9/exclude18
-rw-r--r--gnu/usr.bin/perl/plan9/fndvers14
-rw-r--r--gnu/usr.bin/perl/plan9/genconfig.pl275
-rw-r--r--gnu/usr.bin/perl/plan9/mkfile143
-rw-r--r--gnu/usr.bin/perl/plan9/myconfig.plan939
-rw-r--r--gnu/usr.bin/perl/plan9/perlplan9.doc91
-rw-r--r--gnu/usr.bin/perl/plan9/perlplan9.pod87
-rw-r--r--gnu/usr.bin/perl/plan9/plan9.c134
-rw-r--r--gnu/usr.bin/perl/plan9/plan9ish.h126
-rw-r--r--gnu/usr.bin/perl/plan9/setup.rc51
-rw-r--r--gnu/usr.bin/perl/plan9/versnum8
-rw-r--r--gnu/usr.bin/perl/pod/Makefile296
-rw-r--r--gnu/usr.bin/perl/pod/buildtoc171
-rw-r--r--gnu/usr.bin/perl/pod/checkpods.PL75
-rw-r--r--gnu/usr.bin/perl/pod/perl.pod188
-rw-r--r--gnu/usr.bin/perl/pod/perlapio.pod274
-rw-r--r--gnu/usr.bin/perl/pod/perlbook.pod41
-rw-r--r--gnu/usr.bin/perl/pod/perlbot.pod14
-rw-r--r--gnu/usr.bin/perl/pod/perlcall.pod227
-rw-r--r--gnu/usr.bin/perl/pod/perldata.pod215
-rw-r--r--gnu/usr.bin/perl/pod/perldebug.pod1079
-rw-r--r--gnu/usr.bin/perl/pod/perldelta.pod1586
-rw-r--r--gnu/usr.bin/perl/pod/perldiag.pod1108
-rw-r--r--gnu/usr.bin/perl/pod/perldsc.pod307
-rw-r--r--gnu/usr.bin/perl/pod/perlembed.pod1047
-rw-r--r--gnu/usr.bin/perl/pod/perlfaq.pod174
-rw-r--r--gnu/usr.bin/perl/pod/perlfaq1.pod249
-rw-r--r--gnu/usr.bin/perl/pod/perlfaq2.pod443
-rw-r--r--gnu/usr.bin/perl/pod/perlfaq3.pod504
-rw-r--r--gnu/usr.bin/perl/pod/perlfaq4.pod1101
-rw-r--r--gnu/usr.bin/perl/pod/perlfaq5.pod830
-rw-r--r--gnu/usr.bin/perl/pod/perlfaq6.pod605
-rw-r--r--gnu/usr.bin/perl/pod/perlfaq7.pod717
-rw-r--r--gnu/usr.bin/perl/pod/perlfaq8.pod851
-rw-r--r--gnu/usr.bin/perl/pod/perlfaq9.pod331
-rw-r--r--gnu/usr.bin/perl/pod/perlform.pod116
-rw-r--r--gnu/usr.bin/perl/pod/perlfunc.pod1705
-rw-r--r--gnu/usr.bin/perl/pod/perlguts.pod1754
-rw-r--r--gnu/usr.bin/perl/pod/perlipc.pod685
-rw-r--r--gnu/usr.bin/perl/pod/perllocale.pod800
-rw-r--r--gnu/usr.bin/perl/pod/perllol.pod106
-rw-r--r--gnu/usr.bin/perl/pod/perlmod.pod1003
-rw-r--r--gnu/usr.bin/perl/pod/perlmodlib.pod1094
-rw-r--r--gnu/usr.bin/perl/pod/perlobj.pod173
-rw-r--r--gnu/usr.bin/perl/pod/perlop.pod400
-rw-r--r--gnu/usr.bin/perl/pod/perlovl.pod15
-rw-r--r--gnu/usr.bin/perl/pod/perlpod.pod131
-rw-r--r--gnu/usr.bin/perl/pod/perlre.pod212
-rw-r--r--gnu/usr.bin/perl/pod/perlref.pod179
-rw-r--r--gnu/usr.bin/perl/pod/perlrun.pod341
-rw-r--r--gnu/usr.bin/perl/pod/perlsec.pod408
-rw-r--r--gnu/usr.bin/perl/pod/perlstyle.pod56
-rw-r--r--gnu/usr.bin/perl/pod/perlsub.pod398
-rw-r--r--gnu/usr.bin/perl/pod/perlsyn.pod180
-rw-r--r--gnu/usr.bin/perl/pod/perltie.pod327
-rw-r--r--gnu/usr.bin/perl/pod/perltoc.pod3783
-rw-r--r--gnu/usr.bin/perl/pod/perltoot.pod1789
-rw-r--r--gnu/usr.bin/perl/pod/perltrap.pod1229
-rw-r--r--gnu/usr.bin/perl/pod/perlvar.pod363
-rw-r--r--gnu/usr.bin/perl/pod/perlxs.pod104
-rw-r--r--gnu/usr.bin/perl/pod/perlxstut.pod119
-rw-r--r--gnu/usr.bin/perl/pod/pod2html.PL663
-rw-r--r--gnu/usr.bin/perl/pod/pod2latex.PL53
-rw-r--r--gnu/usr.bin/perl/pod/pod2man.PL243
-rw-r--r--gnu/usr.bin/perl/pod/pod2text.PL13
-rw-r--r--gnu/usr.bin/perl/pod/roffitall279
-rw-r--r--gnu/usr.bin/perl/pod/rofftoc66
-rw-r--r--gnu/usr.bin/perl/pod/splitpod18
-rw-r--r--gnu/usr.bin/perl/pp.c1495
-rw-r--r--gnu/usr.bin/perl/pp.h73
-rw-r--r--gnu/usr.bin/perl/pp_ctl.c910
-rw-r--r--gnu/usr.bin/perl/pp_hot.c1058
-rw-r--r--gnu/usr.bin/perl/pp_sys.c1125
-rw-r--r--gnu/usr.bin/perl/proto.h252
-rw-r--r--gnu/usr.bin/perl/qnx/ar33
-rw-r--r--gnu/usr.bin/perl/qnx/cpp24
-rw-r--r--gnu/usr.bin/perl/regcomp.c490
-rw-r--r--gnu/usr.bin/perl/regcomp.h113
-rw-r--r--gnu/usr.bin/perl/regexec.c476
-rw-r--r--gnu/usr.bin/perl/regexp.h10
-rw-r--r--gnu/usr.bin/perl/run.c25
-rw-r--r--gnu/usr.bin/perl/scope.c310
-rw-r--r--gnu/usr.bin/perl/scope.h87
-rw-r--r--gnu/usr.bin/perl/sv.c2392
-rw-r--r--gnu/usr.bin/perl/sv.h92
-rw-r--r--gnu/usr.bin/perl/t/README7
-rw-r--r--gnu/usr.bin/perl/t/TEST80
-rw-r--r--gnu/usr.bin/perl/t/base/lex.t30
-rw-r--r--gnu/usr.bin/perl/t/base/term.t13
-rw-r--r--gnu/usr.bin/perl/t/cmd/mod.t16
-rw-r--r--gnu/usr.bin/perl/t/cmd/while.t1
-rw-r--r--gnu/usr.bin/perl/t/comp/cmdopt.t9
-rw-r--r--gnu/usr.bin/perl/t/comp/colon.t138
-rw-r--r--gnu/usr.bin/perl/t/comp/cpp.aux2
-rw-r--r--gnu/usr.bin/perl/t/comp/cpp.t7
-rw-r--r--gnu/usr.bin/perl/t/comp/multiline.t4
-rw-r--r--gnu/usr.bin/perl/t/comp/package.t6
-rw-r--r--gnu/usr.bin/perl/t/comp/proto.t390
-rw-r--r--gnu/usr.bin/perl/t/comp/redef.t80
-rw-r--r--gnu/usr.bin/perl/t/comp/script.t9
-rw-r--r--gnu/usr.bin/perl/t/comp/term.t37
-rw-r--r--gnu/usr.bin/perl/t/comp/use.t101
-rw-r--r--gnu/usr.bin/perl/t/harness10
-rw-r--r--gnu/usr.bin/perl/t/io/argv.t26
-rw-r--r--gnu/usr.bin/perl/t/io/dup.t13
-rw-r--r--gnu/usr.bin/perl/t/io/fs.t57
-rw-r--r--gnu/usr.bin/perl/t/io/inplace.t15
-rw-r--r--gnu/usr.bin/perl/t/io/pipe.t56
-rw-r--r--gnu/usr.bin/perl/t/io/read.t26
-rw-r--r--gnu/usr.bin/perl/t/io/tell.t2
-rw-r--r--gnu/usr.bin/perl/t/lib/abbrev.t51
-rw-r--r--gnu/usr.bin/perl/t/lib/anydbm.t19
-rw-r--r--gnu/usr.bin/perl/t/lib/autoloader.t100
-rw-r--r--gnu/usr.bin/perl/t/lib/basename.t121
-rw-r--r--gnu/usr.bin/perl/t/lib/bigintpm.t7
-rw-r--r--gnu/usr.bin/perl/t/lib/checktree.t19
-rw-r--r--gnu/usr.bin/perl/t/lib/complex.t818
-rw-r--r--gnu/usr.bin/perl/t/lib/db-btree.t402
-rw-r--r--gnu/usr.bin/perl/t/lib/db-hash.t269
-rw-r--r--gnu/usr.bin/perl/t/lib/db-recno.t343
-rw-r--r--gnu/usr.bin/perl/t/lib/dirhand.t4
-rw-r--r--gnu/usr.bin/perl/t/lib/dosglob.t94
-rw-r--r--gnu/usr.bin/perl/t/lib/env.t18
-rw-r--r--gnu/usr.bin/perl/t/lib/filecache.t25
-rw-r--r--gnu/usr.bin/perl/t/lib/filecopy.t88
-rw-r--r--gnu/usr.bin/perl/t/lib/filefind.t13
-rw-r--r--gnu/usr.bin/perl/t/lib/filehand.t69
-rw-r--r--gnu/usr.bin/perl/t/lib/filepath.t28
-rw-r--r--gnu/usr.bin/perl/t/lib/findbin.t13
-rw-r--r--gnu/usr.bin/perl/t/lib/gdbm.t101
-rw-r--r--gnu/usr.bin/perl/t/lib/getopt.t73
-rw-r--r--gnu/usr.bin/perl/t/lib/hostname.t19
-rw-r--r--gnu/usr.bin/perl/t/lib/io_dup.t61
-rw-r--r--gnu/usr.bin/perl/t/lib/io_pipe.t109
-rw-r--r--gnu/usr.bin/perl/t/lib/io_sel.t116
-rw-r--r--gnu/usr.bin/perl/t/lib/io_sock.t81
-rw-r--r--gnu/usr.bin/perl/t/lib/io_taint.t48
-rw-r--r--gnu/usr.bin/perl/t/lib/io_tell.t64
-rw-r--r--gnu/usr.bin/perl/t/lib/io_udp.t44
-rw-r--r--gnu/usr.bin/perl/t/lib/io_xs.t42
-rw-r--r--gnu/usr.bin/perl/t/lib/ndbm.t97
-rw-r--r--gnu/usr.bin/perl/t/lib/odbm.t97
-rw-r--r--gnu/usr.bin/perl/t/lib/opcode.t115
-rw-r--r--gnu/usr.bin/perl/t/lib/open2.t46
-rw-r--r--gnu/usr.bin/perl/t/lib/open3.t121
-rw-r--r--gnu/usr.bin/perl/t/lib/ops.t29
-rw-r--r--gnu/usr.bin/perl/t/lib/parsewords.t28
-rw-r--r--gnu/usr.bin/perl/t/lib/posix.t23
-rw-r--r--gnu/usr.bin/perl/t/lib/safe.t96
-rw-r--r--gnu/usr.bin/perl/t/lib/safe1.t68
-rw-r--r--gnu/usr.bin/perl/t/lib/safe2.t144
-rw-r--r--gnu/usr.bin/perl/t/lib/sdbm.t100
-rw-r--r--gnu/usr.bin/perl/t/lib/searchdict.t65
-rw-r--r--gnu/usr.bin/perl/t/lib/selectsaver.t28
-rw-r--r--gnu/usr.bin/perl/t/lib/socket.t10
-rw-r--r--gnu/usr.bin/perl/t/lib/soundex.t7
-rw-r--r--gnu/usr.bin/perl/t/lib/symbol.t52
-rw-r--r--gnu/usr.bin/perl/t/lib/texttabs.t28
-rw-r--r--gnu/usr.bin/perl/t/lib/textwrap.t40
-rw-r--r--gnu/usr.bin/perl/t/lib/timelocal.t87
-rw-r--r--gnu/usr.bin/perl/t/lib/trig.t57
-rw-r--r--gnu/usr.bin/perl/t/op/arith.t12
-rw-r--r--gnu/usr.bin/perl/t/op/assignwarn.t61
-rw-r--r--gnu/usr.bin/perl/t/op/bop.t55
-rw-r--r--gnu/usr.bin/perl/t/op/chop.t17
-rw-r--r--gnu/usr.bin/perl/t/op/closure.t454
-rw-r--r--gnu/usr.bin/perl/t/op/cmp.t35
-rw-r--r--gnu/usr.bin/perl/t/op/delete.t22
-rw-r--r--gnu/usr.bin/perl/t/op/each.t62
-rw-r--r--gnu/usr.bin/perl/t/op/exec.t7
-rw-r--r--gnu/usr.bin/perl/t/op/flip.t5
-rw-r--r--gnu/usr.bin/perl/t/op/fork.t10
-rw-r--r--gnu/usr.bin/perl/t/op/glob.t27
-rw-r--r--gnu/usr.bin/perl/t/op/goto.t3
-rw-r--r--gnu/usr.bin/perl/t/op/groups.t7
-rw-r--r--gnu/usr.bin/perl/t/op/gv.t59
-rw-r--r--gnu/usr.bin/perl/t/op/inc.t52
-rw-r--r--gnu/usr.bin/perl/t/op/local.t11
-rw-r--r--gnu/usr.bin/perl/t/op/magic.t170
-rw-r--r--gnu/usr.bin/perl/t/op/method.t122
-rw-r--r--gnu/usr.bin/perl/t/op/misc.t187
-rw-r--r--gnu/usr.bin/perl/t/op/mkdir.t7
-rw-r--r--gnu/usr.bin/perl/t/op/my.t43
-rw-r--r--gnu/usr.bin/perl/t/op/oct.t4
-rw-r--r--gnu/usr.bin/perl/t/op/pack.t63
-rw-r--r--gnu/usr.bin/perl/t/op/pat.t21
-rw-r--r--gnu/usr.bin/perl/t/op/quotemeta.t12
-rw-r--r--gnu/usr.bin/perl/t/op/rand.t366
-rw-r--r--gnu/usr.bin/perl/t/op/re_tests81
-rw-r--r--gnu/usr.bin/perl/t/op/readdir.t2
-rw-r--r--gnu/usr.bin/perl/t/op/recurse.t86
-rw-r--r--gnu/usr.bin/perl/t/op/ref.t52
-rw-r--r--gnu/usr.bin/perl/t/op/regexp.t57
-rw-r--r--gnu/usr.bin/perl/t/op/runlevel.t317
-rw-r--r--gnu/usr.bin/perl/t/op/sleep.t2
-rw-r--r--gnu/usr.bin/perl/t/op/sort.t53
-rw-r--r--gnu/usr.bin/perl/t/op/split.t36
-rw-r--r--gnu/usr.bin/perl/t/op/sprintf.t29
-rw-r--r--gnu/usr.bin/perl/t/op/stat.t114
-rw-r--r--gnu/usr.bin/perl/t/op/subst.t45
-rw-r--r--gnu/usr.bin/perl/t/op/substr.t169
-rw-r--r--gnu/usr.bin/perl/t/op/sysio.t194
-rw-r--r--gnu/usr.bin/perl/t/op/taint.t574
-rw-r--r--gnu/usr.bin/perl/t/op/tie.t155
-rw-r--r--gnu/usr.bin/perl/t/op/universal.t96
-rw-r--r--gnu/usr.bin/perl/t/op/write.t42
-rw-r--r--gnu/usr.bin/perl/t/pragma/constant.t141
-rw-r--r--gnu/usr.bin/perl/t/pragma/locale.t475
-rw-r--r--gnu/usr.bin/perl/t/pragma/overload.t (renamed from gnu/usr.bin/perl/t/op/overload.t)114
-rw-r--r--gnu/usr.bin/perl/t/pragma/strict-refs295
-rw-r--r--gnu/usr.bin/perl/t/pragma/strict-subs279
-rw-r--r--gnu/usr.bin/perl/t/pragma/strict-vars223
-rw-r--r--gnu/usr.bin/perl/t/pragma/strict.t93
-rw-r--r--gnu/usr.bin/perl/t/pragma/subs.t132
-rw-r--r--gnu/usr.bin/perl/t/pragma/warn-1global146
-rw-r--r--gnu/usr.bin/perl/t/pragma/warning.t94
-rw-r--r--gnu/usr.bin/perl/t/re_tests3
-rw-r--r--gnu/usr.bin/perl/taint.c129
-rw-r--r--gnu/usr.bin/perl/toke.c1429
-rw-r--r--gnu/usr.bin/perl/universal.c213
-rw-r--r--gnu/usr.bin/perl/unixish.h67
-rw-r--r--gnu/usr.bin/perl/util.c1752
-rw-r--r--gnu/usr.bin/perl/util.h2
-rw-r--r--gnu/usr.bin/perl/utils/Makefile20
-rw-r--r--gnu/usr.bin/perl/utils/c2ph.PL101
-rw-r--r--gnu/usr.bin/perl/utils/h2ph.PL187
-rw-r--r--gnu/usr.bin/perl/utils/h2xs.PL351
-rw-r--r--gnu/usr.bin/perl/utils/perlbug.PL650
-rw-r--r--gnu/usr.bin/perl/utils/perldoc.PL365
-rw-r--r--gnu/usr.bin/perl/utils/pl2pm.PL15
-rw-r--r--gnu/usr.bin/perl/utils/splain.PL46
-rw-r--r--gnu/usr.bin/perl/vms/Makefile1374
-rw-r--r--gnu/usr.bin/perl/vms/config.vms550
-rw-r--r--gnu/usr.bin/perl/vms/descrip.mms474
-rw-r--r--gnu/usr.bin/perl/vms/ext/DCLsym/0README.txt21
-rw-r--r--gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm270
-rw-r--r--gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.xs151
-rw-r--r--gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL3
-rw-r--r--gnu/usr.bin/perl/vms/ext/DCLsym/test.pl41
-rw-r--r--gnu/usr.bin/perl/vms/ext/Filespec.pm16
-rw-r--r--gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm51
-rw-r--r--gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs20
-rw-r--r--gnu/usr.bin/perl/vms/ext/Stdio/test.pl23
-rw-r--r--gnu/usr.bin/perl/vms/ext/XSSymSet.pm239
-rw-r--r--gnu/usr.bin/perl/vms/ext/filespec.t133
-rw-r--r--gnu/usr.bin/perl/vms/ext/vmsish.pm76
-rw-r--r--gnu/usr.bin/perl/vms/ext/vmsish.t122
-rw-r--r--gnu/usr.bin/perl/vms/fndvers.com5
-rw-r--r--gnu/usr.bin/perl/vms/gen_shrfls.pl99
-rw-r--r--gnu/usr.bin/perl/vms/genconfig.pl254
-rw-r--r--gnu/usr.bin/perl/vms/genopt.com18
-rw-r--r--gnu/usr.bin/perl/vms/myconfig.com2
-rw-r--r--gnu/usr.bin/perl/vms/perlvms.pod158
-rw-r--r--gnu/usr.bin/perl/vms/perly_c.vms2815
-rw-r--r--gnu/usr.bin/perl/vms/perly_h.vms61
-rw-r--r--gnu/usr.bin/perl/vms/sockadapt.c90
-rw-r--r--gnu/usr.bin/perl/vms/sockadapt.h75
-rw-r--r--gnu/usr.bin/perl/vms/test.com47
-rw-r--r--gnu/usr.bin/perl/vms/vms.c1528
-rw-r--r--gnu/usr.bin/perl/vms/vms_yfix.pl10
-rw-r--r--gnu/usr.bin/perl/vms/vmsish.h260
-rw-r--r--gnu/usr.bin/perl/vms/writemain.pl7
-rw-r--r--gnu/usr.bin/perl/win32/Makefile517
-rw-r--r--gnu/usr.bin/perl/win32/TEST149
-rw-r--r--gnu/usr.bin/perl/win32/autosplit.pl3
-rw-r--r--gnu/usr.bin/perl/win32/bin/network.pl211
-rw-r--r--gnu/usr.bin/perl/win32/bin/pl2bat.pl154
-rw-r--r--gnu/usr.bin/perl/win32/bin/runperl.pl67
-rw-r--r--gnu/usr.bin/perl/win32/bin/search.pl1865
-rw-r--r--gnu/usr.bin/perl/win32/bin/webget.pl1091
-rw-r--r--gnu/usr.bin/perl/win32/bin/www.pl901
-rw-r--r--gnu/usr.bin/perl/win32/config.bc498
-rw-r--r--gnu/usr.bin/perl/win32/config.vc498
-rw-r--r--gnu/usr.bin/perl/win32/config_H.bc1802
-rw-r--r--gnu/usr.bin/perl/win32/config_H.vc1802
-rw-r--r--gnu/usr.bin/perl/win32/config_h.PL92
-rw-r--r--gnu/usr.bin/perl/win32/config_sh.PL23
-rw-r--r--gnu/usr.bin/perl/win32/dl_win32.xs112
-rw-r--r--gnu/usr.bin/perl/win32/genxsdef.pl5
-rw-r--r--gnu/usr.bin/perl/win32/include/arpa/inet.h4
-rw-r--r--gnu/usr.bin/perl/win32/include/dirent.h49
-rw-r--r--gnu/usr.bin/perl/win32/include/netdb.h12
-rw-r--r--gnu/usr.bin/perl/win32/include/sys/socket.h149
-rw-r--r--gnu/usr.bin/perl/win32/makedef.pl347
-rw-r--r--gnu/usr.bin/perl/win32/makefile.mk607
-rw-r--r--gnu/usr.bin/perl/win32/makemain.pl45
-rw-r--r--gnu/usr.bin/perl/win32/makeperldef.pl23
-rw-r--r--gnu/usr.bin/perl/win32/perlglob.c42
-rw-r--r--gnu/usr.bin/perl/win32/perllib.c113
-rw-r--r--gnu/usr.bin/perl/win32/pod.mak272
-rw-r--r--gnu/usr.bin/perl/win32/runperl.c18
-rw-r--r--gnu/usr.bin/perl/win32/splittree.pl24
-rw-r--r--gnu/usr.bin/perl/win32/win32.c1639
-rw-r--r--gnu/usr.bin/perl/win32/win32.h154
-rw-r--r--gnu/usr.bin/perl/win32/win32io.c327
-rw-r--r--gnu/usr.bin/perl/win32/win32io.h87
-rw-r--r--gnu/usr.bin/perl/win32/win32iop.h200
-rw-r--r--gnu/usr.bin/perl/win32/win32sck.c726
-rw-r--r--gnu/usr.bin/perl/writemain.SH6
-rw-r--r--gnu/usr.bin/perl/x2p/EXTERN.h2
-rw-r--r--gnu/usr.bin/perl/x2p/INTERN.h2
-rw-r--r--gnu/usr.bin/perl/x2p/Makefile.SH32
-rw-r--r--gnu/usr.bin/perl/x2p/a2p.c2999
-rw-r--r--gnu/usr.bin/perl/x2p/a2p.h43
-rw-r--r--gnu/usr.bin/perl/x2p/a2p.man187
-rw-r--r--gnu/usr.bin/perl/x2p/a2p.pod162
-rw-r--r--gnu/usr.bin/perl/x2p/a2p.y9
-rw-r--r--gnu/usr.bin/perl/x2p/a2py.c16
-rw-r--r--gnu/usr.bin/perl/x2p/cflags.SH12
-rw-r--r--gnu/usr.bin/perl/x2p/find2perl.PL17
-rw-r--r--gnu/usr.bin/perl/x2p/handy.h172
-rw-r--r--gnu/usr.bin/perl/x2p/hash.c2
-rw-r--r--gnu/usr.bin/perl/x2p/hash.h2
-rw-r--r--gnu/usr.bin/perl/x2p/proto.h8
-rw-r--r--gnu/usr.bin/perl/x2p/s2p.PL88
-rw-r--r--gnu/usr.bin/perl/x2p/s2p.man96
-rw-r--r--gnu/usr.bin/perl/x2p/str.c18
-rw-r--r--gnu/usr.bin/perl/x2p/str.h2
-rw-r--r--gnu/usr.bin/perl/x2p/util.c84
-rw-r--r--gnu/usr.bin/perl/x2p/util.h18
-rw-r--r--gnu/usr.bin/perl/x2p/walk.c4
762 files changed, 156061 insertions, 39812 deletions
diff --git a/gnu/usr.bin/perl/Artistic b/gnu/usr.bin/perl/Artistic
index 11f4d82d972..5f221241e80 100644
--- a/gnu/usr.bin/perl/Artistic
+++ b/gnu/usr.bin/perl/Artistic
@@ -97,7 +97,7 @@ 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 whomever generated
+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
diff --git a/gnu/usr.bin/perl/Changes b/gnu/usr.bin/perl/Changes
index 64b93987701..74755010ca3 100644
--- a/gnu/usr.bin/perl/Changes
+++ b/gnu/usr.bin/perl/Changes
@@ -1,2882 +1,13906 @@
+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>
+
+
+----------------
+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.002
+Version 5.004
-------------
-The main enhancement to the Perl core was the addition of prototypes.
-Many of the modules that come with Perl have been extensively upgraded.
+"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
-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).
-Added APPLLIB_EXP for embedded perl library support.
-Files patched: perl.c
+-----------------
+Version 5.003_99a
+-----------------
-Couldn't define autoloaded routine by assignment to typeglob.
-Files patched: pp_hot.c sv.c
+Herein we find the fruits of the gamma.
-NETaa13525: Tiny patch to fix installman -n
-From: Larry Wall
-Files patched: installman
+ CORE LANGUAGE CHANGES
-NETaa13525: de-documented \v
-Files patched: pod/perlop.pod pod/perlre.pod
+ Title: "SECURITY: Forbid glob() when tainting (-T or setuid)"
+ From: Chip Salzenberg
+ Files: pod/perlrun.pod pod/perlsec.pod pp_sys.c
-NETaa13525: doc changes
-Files patched: pod/perlop.pod pod/perltrap.pod
+ 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
-NETaa13525: perlxs update from Dean Roehrich
-Files patched: pod/perlxs.pod
+ CORE PORTABILITY
-NETaa13525: rename powerunix to powerux
-Files patched: MANIFEST hints/powerux.sh
+ 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
-NETaa13540: VMS uses CLK_TCK for HZ
-Files patched: pp_sys.c
+ BUILD PROCESS
-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.
+ Title: "AFS patches"
+ From: Chip Salzenberg, Larry Schwimmer <rosebud@cyclone.Stanford.EDU>
+ Files: Configure installperl
+
+ LIBRARY AND EXTENSIONS
-NETaa13721: warning suppression
-Files patched: toke.c
- (same)
+ 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
-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.
+ (no other changes)
+
+ UTILITIES
-NETaa13724: -MPackage=args patch
-From: Tim Bunce
-Files patched: perl.c pod/perlrun.pod
- Added in the -MPackage=args patch too.
+ 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
-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.
-
+ 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
-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.
-
+----------------
+Version 5.003_99
+----------------
-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.
-
+"Oops." Now this _has_ to be the gamma; we're out of numbers.
-NETaa14312: undef in @EXPORTS core dumps
-Files patched: pod/perldiag.pod sv.c
- (same)
+ CORE LANGUAGE CHANGES
-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.
-
+ (no changes)
-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
+ CORE PORTABILITY
--------------
-Version 5.001
--------------
+ 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
-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.
+ 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
-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.
+ OTHER CORE CHANGES
-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...
-
+ Title: "Fix NUL-termination bug in delimcpy()"
+ From: Chip Salzenberg
+ Files: util.c
-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.
-
+ Title: "Forget prototype of subroutine after C<undef &subr>"
+ From: Chip Salzenberg
+ Files: op.c
-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");
- }
-
+ Title: "Handle tainted values in lists returned from subs, evals"
+ From: Chip Salzenberg
+ Files: pp_ctl.c pp_hot.c t/op/taint.t
-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.
-
+ 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
-NETaa13352: OP_SCOPE allocated as UNOP rather than LISTOP.
-From: Andy Dougherty
-Files patched: op.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
-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.
+ BUILD PROCESS
-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.
-
+ Title: "Add new globals to perl.exp"
+ From: Chip Salzenberg
+ Files: perl_exp.SH
-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';
-
+ LIBRARY AND EXTENSIONS
-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.
-
+ 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
-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.
-
+ TESTS
-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)
+ 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
--------------
-Version 5.000
--------------
+ 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.
-New things
-----------
- The -w switch is much more informative.
+ CORE LANGUAGE CHANGES
- 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.
+ 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
- Objects. See t/op/ref.t for examples.
+ Title: "Allow constant sub to be optimized when called with parens"
+ From: Chip Salzenberg
+ Files: toke.c
- => 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.
+ Title: "Make {,un}pack fail on invalid pack types"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod pp.c
- 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.
+ CORE PORTABILITY
- More embeddible. See main.c and embed_h.sh. Multiple interpreters
- in the same process are supported (though not with interleaved
- execution yet).
+ Title: "Fix bitwise ops and {,un}pack() on Cray CPUs"
+ From: Chip Salzenberg
+ Files: pp.c
- 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.
+ 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
- eval is now treated more like a subroutine call. Among other things,
- this means you can return from it.
+ 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
- Format value lists may be spread over multiple lines by enclosing in
- a do {} block.
+ OTHER CORE CHANGES
- 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.
+ Title: "Fix error messages on method lookup failure"
+ From: Chip Salzenberg
+ Files: pp_hot.c
- Flags on the #! line are interpreted even if the script wasn't
- executed directly. (And even if the script was located by "perl -x"!)
+ 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
- The ?: operator is now legal as an lvalue.
+ BUILD PROCESS
- List context now propagates to the right side of && and ||, as well
- as the 2nd and 3rd arguments to ?:.
+ 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
- The "defined" function can now take a general expression.
+ LIBRARY AND EXTENSIONS
- Lexical scoping available via "my". eval can see the current lexical
- variables.
+ 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
- The preferred package delimiter is now :: rather than '.
+ 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
- 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.
+ Title: "Revise quotewords()"
+ From: Shishir Gundavaram <shishir@ruby.ora.com>
+ Files: lib/Text/ParseWords.pm
- New "and" and "or" operators work just like && and || but with
- a precedence lower than comma, so they work better with list operators.
+ TESTS
- New functions include: abs(), chr(), uc(), ucfirst(), lc(), lcfirst(),
- chomp(), glob()
+ (no other changes)
- require with a number checks to see that the version of Perl that is
- currently running is at least that number.
+ UTILITIES
- Dynamic loading of external modules is now supported.
+ (no changes)
- There is a new quote form qw//, which is equivalent to split(' ', q//).
+ DOCUMENTATION
- 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;
+ Title: "Doc updates: INSTALL-1.13, pumpkin.pod-1.9"
+ From: Andy Dougherty
+ Files: INSTALL Porting/pumpkin.pod
- Filehandle methods are now supported:
- output_autoflush STDOUT 1;
+ Title: "Document size restrictions for packed integers"
+ From: Jarkko Hietaniemi
+ Files: pod/perlfunc.pod
- 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.
+-----------------
+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
- 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.
+ 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
- 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".
+ Title: "Grandfather "$$<digit>" in strings"
+ From: Chip Salzenberg
+ Files: pod/perldiag.pod toke.c
- 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.
+ Title: "Disconnect warn and die hooks _after_ object destruction"
+ From: Chip Salzenberg
+ Files: perl.c
- 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.
+ Title: "Forbid recursive substitutions"
+ From: Chip Salzenberg
+ Files: cop.h pod/perldelta.pod pod/perldiag.pod pp_ctl.c pp_hot.c
- 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.
+ CORE PORTABILITY
- 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.
+ Title: "Use SSize_t for values of PerlIO_{read,write}"
+ From: Chip Salzenberg
+ Files: perlio.c perlio.h perlsdio.h pp_sys.c
- 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".
+ 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
- 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.
+ OTHER CORE CHANGES
-Incompatibilities
+ 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
-----------------
- @ 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.
+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.
- s'$lhs'$rhs' now does no interpolation on either side. It used to
- interplolate $lhs but not $rhs.
+ - Perl subroutines which just return a constant value are now
+ optimized at compile time into inline constants.
- The second and third arguments of splice are now evaluated in scalar
- context (like the book says) rather than list context.
+ - 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.
- Saying "shift @foo + 20" is now a semantic error because of precedence.
+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.
- "open FOO || die" is now incorrect. You need parens around the filehandle.
+ - 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 elements of argument lists for formats are now evaluated in list
- context. This means you can interpolate list values now.
+ - 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.
- You can't do a goto into a block that is optimized away. Darn.
+ - 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.
- 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.
+ - The FindBin library module, which determines the full path
+ to the currently executing program, has been added to the
+ standard distribution.
- Some error messages will be different.
+ - 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 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.
+ - The Carp library module now considers the @ISA chain when
+ determining the caller's package for inclusion in error messages.
- m//g now attaches its state to the searched string rather than the
- regular expression.
+ - The h2xs, perlbug, and xsubpp utilities have been updated.
- "reverse" is no longer allowed as the name of a sort subroutine.
+ - 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.
- taintperl is no longer a separate executable. There is now a -T
- switch to turn on tainting when it isn't turned on automatically.
+ - The pod documentation formatting tools in the standard distribution
+ can now handle characters in the input stream whose high bit is set.
- Symbols starting with _ are no longer forced into package main, except
- for $_ itself (and @_, etc.).
+ - The cperl-mode EMACS editing mode has been updated.
- Double-quoted strings may no longer end with an unescaped $ or @.
+o Changes in Documentation
- Negative array subscripts now count from the end of the array.
+ - Typographic and formatting errors have been corrected in the pod
+ documentation for the core and standard library files
- The comma operator in a scalar context is now guaranteed to give a
- scalar context to its arguments.
+ - Explanations of several core operators have been improved
- The ** operator now binds more tightly than unary minus.
+ - The perldebug, perlembed, perlipc, perlsec, and perltrap documents
+ extensively revised.
- Setting $#array lower now discards array elements so that destructors
- work reasonably.
+o Changes in OS-specific and Build-time Support
- delete is not guaranteed to return the old value for tied arrays,
- since this capability may be onerous for some modules to implement.
+ - 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.
- Attempts to set $1 through $9 now result in a run-time error.
+ - 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/gnu/usr.bin/perl/Changes5.000 b/gnu/usr.bin/perl/Changes5.000
new file mode 100644
index 00000000000..78cab26f14c
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/Changes5.001 b/gnu/usr.bin/perl/Changes5.001
new file mode 100644
index 00000000000..c26134a79aa
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/Changes.Conf b/gnu/usr.bin/perl/Changes5.002
index a956fd77da8..6382d529175 100644
--- a/gnu/usr.bin/perl/Changes.Conf
+++ b/gnu/usr.bin/perl/Changes5.002
@@ -2,7 +2,1405 @@
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
@@ -53,7 +1451,9 @@ 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:
-=item 5.002beta2
+-------------
+Version 5.002beta2
+-------------
This is patch.2b2 to perl5.002beta1.
This takes you from 5.002beta1h to 5.002beta2.
@@ -500,7 +1900,9 @@ Index: writemain.SH
*** perl5.002b1h/writemain.SH Sat Nov 18 15:51:55 1995
--- perl5.002b2/writemain.SH Fri Jan 12 10:53:35 1996
-=item patch.2b1h
+-------------
+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
@@ -1205,7 +2607,9 @@ Index: x2p/s2p.PL
--- perl5.002b1h/x2p/s2p.PL Tue Jan 2 12:11:27 1996
-=item patch.2b1g
+-------------
+Version 5.002b1g
+-------------
This is patch.2b1g to perl5.002beta1.
@@ -1512,7 +2916,9 @@ Index: pod/splitpod
*** /dev/null Wed Jan 3 14:35:56 1996
--- perl5.002b1g/pod/splitpod Thu Dec 21 13:01:16 1995
-=item patch.2b1f
+-------------
+Version 5.002b1f
+-------------
This is patch.2b1f to perl5.002beta1.
@@ -1648,7 +3054,9 @@ Index: toke.c
*** perl5.002b1e/toke.c Wed Nov 15 22:08:23 1995
--- perl5.002b1f/toke.c Wed Dec 6 13:24:19 1995
-=item patch.2b1e
+-------------
+Version 5.002b1e
+-------------
This is patch.2b1e to perl5.002beta1. This is simply
an upgrade from MakeMaker-5.10 to MakeMaker-5.11.
@@ -1667,7 +3075,9 @@ 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
-=item patch.2b1d
+-------------
+Version 5.002b1d
+-------------
This is patch.2b1d to perl5.002beta1.
@@ -1789,7 +3199,9 @@ Index: pod/perlre.pod
*** perl5.002b1c/pod/perlre.pod Wed Nov 15 21:35:31 1995
--- perl5.002b1d/pod/perlre.pod Sun Nov 26 16:57:20 1995
-=item patch.2b1c
+-------------
+Version 5.002b1c
+-------------
This is patch.2b1c to perl5.002beta1. This patch includes
lib/SelfLoader, version 1.06, and
@@ -1812,7 +3224,9 @@ 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
-=item patch.2b1b
+-------------
+Version 5.002b1b
+-------------
This is patch.2b1b to perl5.002beta1. This is simply
MakeMaker-5.10. Nothing else is included.
@@ -1838,7 +3252,9 @@ 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
-=item patch.2b1a
+-------------
+Version 5.002b1a
+-------------
This is patch.2b1a to perl5.002beta1. This is simply
xsubpp-1.944. It includes perl prototype support.
@@ -2585,102 +4001,3 @@ 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
-
--------------
-Version 5.001
--------------
-
-Summary of user-visible Configure and build changes since 5.000:
-
-A large number of 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.
-
-Configure changes:
- New and improved Configure command line options. -O now overrides
- config.sh settings. -D options can now include spaces, if
- protected in quotes (e.g. -Dcc='gcc -posix'). Type Configure -h
- for a full listing of options.
-
- Users can now turn on the defaults for the rest of Configure by
- typing &-d at any Configure prompt. This is useful if you just
- want to change one or two answers.
-
- Support on (non-Sun) SVR4 systems for dynamic loading and shared
- libperl.so
-
- Numerous new or updated hints files: PowerUnix, aix 3.x and 4.x,
- bsd386, convexos, cxux, DEC OSF, Esix, FreeBSD, HP-UX (especially if
- you're using the bundled compiler), irix 4.x, 5.x, and 6.x, Linux,
- MPE/IX, NeXT 3.0 and 3.2, Solaris, SVR4, Ultrix (especially 4.3),
- and Unicos.
-
- Improved generation of a suitable name for architecture-dependent
- library files. NOTE: This may differ from the name you had from
- your 5.000 installation.
-
- Many many portability enhancements and fixes.
-
-Build process:
-
- The process for building extensions has been extensively revised. See
- lib/ExtUtils/MakeMaker.pm for complete documentation. Basically, with
- just a simple Makefile.PL (such as the one generated by h2xs), you can
- now build an extension from anywhere on your system, even if you've
- deleted the perl source.
-
- Improved build/install documentation in README. A little.
-
- Improved dynamic loading on HP-UX. Support dynamic loading on SVR4.
-
- Installperl now gets the version correct :-)
-
- Installperl now saves the perl *.h files and the libperl.a library
- in your architecture-dependent library directory so that you can
- later build extensions without having to re-install the perl
- source.
-
- Include x2p/a2p.c generated by byacc from x2p/a2p.y.
-
- Many many portability fixes.
-
-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.000 sources. In particular,
-your 5.000 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 5.000, and which answer
-to keep can be difficult to sort out. Therefore, you are probably
-better off ignoring your old config.sh.
-
-One big change is that architecture-dependent library files may well
-be stored in a different location in 5.001. This is because the default
-name used in the 5.000 release was not sufficiently specific to
-distinguish incompatible architectures. The relevant variable is $archlib
-in config.sh. Before you run ``make install'' you should rename your old
-$archlib. Thus if your $archlib for version 5.000 was
-/usr/local/lib/perl5/foo, and your new value for 5.001 is
-/usr/local/lib/perl5/foo-bar, then you should
- mv /usr/local/lib/perl5/foo /usr/local/lib/perl5/foo-bar
-before running ``make install''.
-
-Alternatively, you could override Configure's default guess for $archlib
-either by sh Configure -Darchname='foo', or by answering 'foo' when
-prompted by Configure for the architecture name.
-
-The following is the sequence of steps to upgrade to 5.001:
- cd perl5.000
- make realclean
- rm config.sh
- <apply 5.001 patch>
- sh Configure
- make depend
- make
- make test
- <mv old architecture-dependent library to new location, if needed>
- make install
-
diff --git a/gnu/usr.bin/perl/Changes5.003 b/gnu/usr.bin/perl/Changes5.003
new file mode 100644
index 00000000000..daba248a9e5
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/Configure b/gnu/usr.bin/perl/Configure
index 4f17f64aac3..b32c5102afb 100644
--- a/gnu/usr.bin/perl/Configure
+++ b/gnu/usr.bin/perl/Configure
@@ -18,9 +18,9 @@
# archive site. Check with Archie if you don't know where that can be.)
#
-# $Id: Configure,v 1.2 1996/09/06 01:33:53 dm Exp $
+# $Id: Head.U,v 3.0.1.8 1995/07/25 13:40:02 ram Exp $
#
-# Generated on Wed Feb 21 14:26:18 EST 1996 [metaconfig 3.0 PL60]
+# Generated on Sat Feb 1 00:26:40 EST 1997 [metaconfig 3.0 PL60]
cat >/tmp/c1$$ <<EOF
ARGGGHHHH!!!!!
@@ -58,7 +58,7 @@ esac
: Proper PATH separator
p_=:
: On OS/2 this directory should exist if this is not floppy only system :-]
-if test -d c:/.; then
+if test -d c:/. -a -n "$OS2_SHELL"; then
p_=\;
PATH=`cmd /c "echo %PATH%" | tr '\\\\' / `
OS2_SHELL=`cmd /c "echo %OS2_SHELL%" | tr '\\\\' / | tr '[A-Z]' '[a-z]'`
@@ -85,6 +85,12 @@ done
PATH=.$p_$PATH
export PATH
+: This should not matter in scripts, but apparently it does, sometimes
+case "$CDPATH" in
+'') ;;
+*) CDPATH='' ;;
+esac
+
: Sanity checks
# WRONG: This makes it impossible to compile perl non-interactively
#if test ! -t 0; then
@@ -92,24 +98,40 @@ export PATH
# exit 1
#fi
-: On HP-UX, large Configure scripts may exercise a bug in /bin/sh
-if test -f /hp-ux -a -f /bin/ksh; then
- if (PATH=.; alias -x) >/dev/null 2>&1; then
- : already under /bin/ksh
- else
+: Test and see if we are running under ksh, either blatantly or in disguise.
+if (PATH=.; alias -x) >/dev/null 2>&1; then
+ : running under ksh. Is this a good thing?
+ 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
+ : on AIX 4, /bin/sh is really ksh, and it causes us problems.
+ : Avoid it
cat <<'EOM'
-(Feeding myself to ksh to avoid nasty sh bug in "here document" expansion.)
+(Feeding myself to /usr/bin/bsh to avoid AIX 4's /bin/sh.)
EOM
unset ENV
- exec /bin/ksh $0 "$@"
+ exec /usr/bin/bsh $0 "$@"
fi
-else
+ else
+ if test ! -f /hp-ux ; then
: Warn them if they use ksh on other systems
- (PATH=.; alias -x) >/dev/null 2>&1 && \
cat <<EOM
(I see you are using the Korn shell. Some ksh's blow up on $me,
-especially on exotic machines. If yours does, try the Bourne shell instead.)
+especially on older exotic systems. If yours does, try the Bourne
+shell instead.)
EOM
+ unset ENV
+ fi
+ fi
+else
+ : Not running under ksh. Maybe we should be?
+ : On HP-UX, large Configure scripts may exercise a bug in /bin/sh
+ if test -f /hp-ux -a -f /bin/ksh; then
+ cat <<'EOM'
+(Feeding myself to ksh to avoid nasty sh bug in "here document" expansion.)
+EOM
+ unset ENV
+ exec /bin/ksh $0 "$@"
+ fi
fi
: Configure runs within the UU subdirectory
@@ -120,8 +142,8 @@ dynamic_ext=''
extensions=''
known_extensions=''
static_ext=''
+useopcode=''
useposix=''
-usesafe=''
d_bsd=''
d_eunice=''
d_xenix=''
@@ -150,6 +172,7 @@ find=''
flex=''
gcc=''
grep=''
+gzip=''
inews=''
ksh=''
less=''
@@ -161,7 +184,6 @@ lpr=''
ls=''
mail=''
mailx=''
-make=''
mkdir=''
more=''
mv=''
@@ -174,7 +196,6 @@ rm=''
rmail=''
sed=''
sendmail=''
-sh=''
shar=''
sleep=''
smail=''
@@ -192,6 +213,7 @@ uniq=''
uuname=''
vi=''
zcat=''
+zip=''
full_sed=''
libswanted=''
hint=''
@@ -227,6 +249,8 @@ baserev=''
bin=''
binexp=''
installbin=''
+bincompat3=''
+d_bincompat3=''
byteorder=''
cc=''
gccversion=''
@@ -284,19 +308,26 @@ d_flexfnam=''
d_flock=''
d_fork=''
d_fsetpos=''
+d_ftime=''
+d_gettimeod=''
d_Gconvert=''
d_getgrps=''
+d_setgrps=''
d_gethent=''
aphostname=''
d_gethname=''
d_phostname=''
d_uname=''
d_getlogin=''
+d_getpgid=''
d_getpgrp2=''
+d_bsdgetpgrp=''
d_getpgrp=''
d_getppid=''
d_getprior=''
+d_gnulibc=''
d_htonl=''
+d_inetaton=''
d_isascii=''
d_killpg=''
d_link=''
@@ -335,6 +366,7 @@ d_rename=''
d_rmdir=''
d_safebcpy=''
d_safemcpy=''
+d_sanemcmp=''
d_select=''
d_sem=''
d_semctl=''
@@ -347,6 +379,7 @@ d_setlocale=''
d_setpgid=''
d_setpgrp2=''
d_bsdpgrp=''
+d_bsdsetpgrp=''
d_setpgrp=''
d_setprior=''
d_setregid=''
@@ -356,6 +389,8 @@ d_setreuid=''
d_setrgid=''
d_setruid=''
d_setsid=''
+d_sfio=''
+usesfio=''
d_shm=''
d_shmat=''
d_shmatprototype=''
@@ -363,11 +398,8 @@ shmattype=''
d_shmctl=''
d_shmdt=''
d_shmget=''
-d_sigsetjmp=''
d_sigaction=''
-d_sigintrp=''
-d_sigvec=''
-d_sigvectr=''
+d_sigsetjmp=''
d_oldsock=''
d_socket=''
d_sockpair=''
@@ -390,6 +422,9 @@ d_strerrm=''
d_strerror=''
d_sysernlst=''
d_syserrlst=''
+d_strtod=''
+d_strtol=''
+d_strtoul=''
d_strxfrm=''
d_symlink=''
d_syscall=''
@@ -418,11 +453,9 @@ d_wctomb=''
dlext=''
cccdlflags=''
ccdlflags=''
-d_shrplib=''
dlsrc=''
ld=''
lddlflags=''
-shrpdir=''
usedl=''
fpostype=''
gidtype=''
@@ -459,6 +492,7 @@ d_pwcomment=''
d_pwexpire=''
d_pwquota=''
i_pwd=''
+i_sfio=''
i_stddef=''
i_stdlib=''
i_string=''
@@ -472,11 +506,13 @@ 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=''
@@ -486,12 +522,18 @@ 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=''
@@ -500,6 +542,8 @@ xlibpth=''
libs=''
lns=''
lseektype=''
+make=''
+make_set_make=''
d_mymalloc=''
freetype=''
mallocobj=''
@@ -542,6 +586,7 @@ package=''
spackage=''
pager=''
patchlevel=''
+subversion=''
perladmin=''
perlpath=''
prefix=''
@@ -555,6 +600,7 @@ installscript=''
scriptdir=''
scriptdirexp=''
selecttype=''
+sh=''
sig_name=''
sig_num=''
installsitearch=''
@@ -572,13 +618,13 @@ ssizetype=''
startperl=''
startsh=''
stdchar=''
-subversion=''
sysman=''
uidtype=''
nm_opt=''
nm_so_opt=''
runnm=''
usenm=''
+useperlio=''
incpath=''
mips=''
mips_type=''
@@ -672,8 +718,8 @@ i_whoami=''
libswanted=''
: set useposix=false in your hint file to disable the POSIX extension.
useposix=true
-: set usesafe=false in your hint if you want to skip the Safe extension.
-usesafe=true
+: set useopcode=false in your hint file to disable the Opcode extension.
+useopcode=true
: Define several unixisms. These can be used in hint files.
exe_ext=''
: Extra object files, if any, needed on this platform.
@@ -694,9 +740,10 @@ 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="/lib/pa1.1 /usr/shlib /usr/lib/large /lib /usr/lib"
-glibpth="$glibpth $xlibpth /lib/large /usr/lib/small /lib/small"
-glibpth="$glibpth /usr/ccs/lib /usr/ucblib /usr/shlib"
+glibpth="/shlib /usr/shlib /usr/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
@@ -707,7 +754,7 @@ plibpth=''
defvoidused=15
: List of libraries we want.
-libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl'
+libswanted='sfio net 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.
@@ -717,8 +764,117 @@ 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
+'')
+ : SYSTYPE is for some older MIPS systems.
+ : I do not know if it is still needed.
+ 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";
+ echo "Your Bourne shell appears to be in $sh."
+ break
+ elif test -f "$xxx.exe"; then
+ sh="$xxx";
+ echo "Hmm. Your Bourne shell appears to be in $sh."
+ 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 (Chip Salzenberg) at chip@perl.com and
+we'll try to straigten this all out.
+EOM
+ exit 1
+ ;;
+esac
+
+: see if sh knows # comments
+if `$sh -c '#' >/dev/null 2>&1`; then
+ shsharp=true
+ spitshell=cat
+ echo " "
+ 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
+ echo "Okay, let's see if #! works on this system..."
+ echo "It's just a comment."
+ sharpbang=': use '
+ fi
+ fi
+else
+ 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' didn't work."
+ echo "You may have to fix up the shell scripts to make sure sh runs them."
+fi
+rm -f try
+
: script used to extract .SH files with variable substitutions
-cat >extract <<'EOS'
+cat >extract <<EOS
+$startsh
+EOS
+cat >>extract <<'EOS'
CONFIG=true
echo "Doing variable substitutions on .SH files..."
if test -f MANIFEST; then
@@ -826,7 +982,11 @@ silent=''
extractsh=''
override=''
knowitall=''
+
rm -f optdef.sh
+cat >optdef.sh <<EOS
+$startsh
+EOS
: option parsing
while test $# -gt 0; do
@@ -887,7 +1047,7 @@ done
case "$error" in
true)
cat >&2 <<EOM
-Usage: $me [-dehrEKOSV] [-f config.sh] [-D symbol] [-D symbol=value]
+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.
@@ -1014,7 +1174,7 @@ 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@lafcol.lafayette.edu).
+and contact the author (chip@perl.com).
EOM
echo $n "Continue? [n] $c" >&4
@@ -1060,6 +1220,7 @@ esac"
: now set up to do reads with possible shell escape and default assignment
cat <<EOSC >myread
+$startsh
xxxm=\$dflt
$myecho
ans='!'
@@ -1082,7 +1243,7 @@ while expr "X\$ans" : "X!" >/dev/null; do
read answ
set x \$xxxm
shift
- aok=''; eval "ans=\"\$answ\"" && aok=y
+ aok=''; eval ans="\\"\$answ\\"" && aok=y
case "\$answ" in
"\$ans")
case "\$ans" in
@@ -1155,7 +1316,10 @@ EOF
: general instructions
needman=true
firsttime=true
-user=`( (logname) 2>/dev/null || whoami) 2>&1`
+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 " "
@@ -1201,7 +1365,7 @@ 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 remaining of the execution.
+on the non-interactive behavior for the remainder of the execution.
EOH
. ./myread
@@ -1211,7 +1375,7 @@ 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@lafcol.lafayette.edu) know how I blew it.
+have, let me (chip@perl.com) know how I blew it.
This installation script affects things in two ways:
@@ -1232,74 +1396,6 @@ EOH
esac
fi
-: see if sh knows # comments
-echo " "
-echo "Checking your sh to see if it knows about # comments..." >&4
-if `sh -c '#' >/dev/null 2>&1`; then
- echo "Your sh handles # comments correctly."
- shsharp=true
- spitshell=cat
- echo " "
- echo "Okay, let's see if #! works on this system..."
- 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
- echo "It does."
- sharpbang='#!'
- else
- echo "#! $xcat" > try
- $eunicefix try
- chmod +x try
- ./try > today
- if test -s today; then
- echo "It does."
- sharpbang='#! '
- else
- echo "It's just a comment."
- sharpbang=': use '
- fi
- fi
-else
- 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
-echo " "
-echo "Checking out how to guarantee sh startup..." >&4
-case "$SYSTYPE" in
-*bsd*|sys5*) startsh=$sharpbang"/$SYSTYPE/bin/sh";;
-*) startsh=$sharpbang'/bin/sh';;
-esac
-echo "Let's see if '$startsh' works..."
-cat >try <<EOSS
-$startsh
-set abc
-test "$?abc" != 1
-EOSS
-
-chmod +x try
-$eunicefix try
-if ./try; then
- echo "Yup, it does."
-else
-echo "Nope. You may have to fix up the shell scripts to make sure sh runs them."
-fi
-rm -f try
-
: find out where common programs are
echo " "
echo "Locating common programs..." >&4
@@ -1349,7 +1445,6 @@ echo
expr
find
grep
-ln
ls
mkdir
rm
@@ -1366,8 +1461,10 @@ cpp
csh
date
egrep
+gzip
less
line
+ln
more
nroff
perl
@@ -1375,6 +1472,7 @@ pg
sendmail
test
uname
+zip
"
pth=`echo $PATH | sed -e "s/$p_/ /g"`
pth="$pth /lib /usr/lib"
@@ -1422,6 +1520,12 @@ 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."
@@ -1538,10 +1642,16 @@ if test -f config.sh; then
*) 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
@@ -1555,13 +1665,15 @@ EOM
cd 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@lafcol.lafayette.edu
+ : tests or hints, please send them to chip@perl.com
: 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 /unicos && osname=unicos && osvers=`$uname -r`
+ $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
@@ -1593,7 +1705,6 @@ EOM
esac;;
[23]100) osname=mips ;;
next*) osname=next ;;
- news*) osname=news ;;
i386*)
if $test -f /etc/kconfig; then
osname=isc
@@ -1619,6 +1730,9 @@ EOM
*) osvers=$tmp;;
esac
;;
+ *dc.osx) osname=dcosx
+ osvers="$3"
+ ;;
dnix) osname=dnix
osvers="$3"
;;
@@ -1628,6 +1742,9 @@ EOM
dgux) osname=dgux
osvers="$3"
;;
+ dynixptx*) osname=dynixptx
+ osvers="$3"
+ ;;
freebsd) osname=freebsd
osvers="$3" ;;
genix) osname=genix ;;
@@ -1639,7 +1756,7 @@ EOM
*) osvers="$3" ;;
esac
;;
- irix) osname=irix
+ irix*) osname=irix
case "$3" in
4*) osvers=4 ;;
5*) osvers=5 ;;
@@ -1648,16 +1765,25 @@ EOM
;;
linux) osname=linux
case "$3" in
- 1*) osvers=1 ;;
*) osvers="$3" ;;
esac
;;
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
@@ -1684,7 +1810,7 @@ EOM
ultrix) osname=ultrix
osvers="$3"
;;
- osf1) case "$5" in
+ osf1|mls+) case "$5" in
alpha)
osname=dec_osf
osvers=`echo "$3" | sed 's/^[vt]//'`
@@ -1696,10 +1822,13 @@ EOM
uts) osname=uts
osvers="$3"
;;
+ qnx) osname=qnx
+ osvers="$4"
+ ;;
$2) case "$osname" in
*isc*) ;;
*freebsd*) ;;
- svr*)
+ svr*)
: svr4.x or possibly later
case "svr$3" in
${osname}*)
@@ -1752,10 +1881,10 @@ EOM
;;
esac
else
- if test -f /vmunix -a -f news_os.sh; then
+ if test -f /vmunix -a -f newsos4.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
+ osname=newsos4
fi
$rm -f ../UU/kernel.what
elif test -d c:/.; then
@@ -1858,6 +1987,7 @@ cd UU
tmp_c="$c"
cd ..
cp $config_sh config.sh 2>/dev/null
+ chmod +w config.sh
. ./config.sh
cd UU
cp ../config.sh .
@@ -1897,13 +2027,39 @@ 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=`$date 2>&1`
-(logname > .temp) >/dev/null 2>&1
-$test -s .temp || (whoami > .temp) >/dev/null 2>&1
-$test -s .temp || echo unknown > .temp
-cf_by=`$cat .temp`
-$rm -f .temp
+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
: determine the architecture name
echo " "
@@ -1911,7 +2067,8 @@ 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/ /_/g' -e 's/$/'"-$osname/" tmparch`
+ tarch=`$sed -e 's/ *$//' -e 's/ /_/g' \
+ -e 's/$/'"-$osname/" tmparch`
else
tarch="$osname"
fi
@@ -1935,16 +2092,22 @@ rp='What is your architecture name'
archname="$ans"
myarchname="$tarch"
-if [ -z "$afs" ]; then
- : is AFS running?
- echo " "
- if test -d /afs; then
- echo "AFS may be running... I'll be extra cautious then..." >&4
+: is AFS running?
+echo " "
+case "$afs" in
+$define|true) afs=true ;;
+$undef|false) afs=false ;;
+*) if test -d /afs; then
afs=true
else
- echo "AFS does not seem to be running..." >&4
- afs=false
+ afs=false
fi
+ ;;
+esac
+if test $afs = "true"; 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.
@@ -1994,7 +2157,10 @@ chmod +x filexp
$eunicefix filexp
: now set up to get a file name
-cat <<'EOSC' >getfile
+cat <<EOS >getfile
+$startsh
+EOS
+cat <<'EOSC' >>getfile
tilde=''
fullpath=''
already=''
@@ -2309,13 +2475,20 @@ baserev=5.0
echo " "
echo "Getting the current patchlevel..." >&4
if $test -r ../patchlevel.h;then
- patchlevel=`awk '/PATCHLEVEL/ {print $3}' < ../patchlevel.h`
- subversion=`awk '/SUBVERSION/ {print $3}' < ../patchlevel.h`
+ patchlevel=`awk '/PATCHLEVEL/ {print $3}' ../patchlevel.h`
+ subversion=`awk '/SUBVERSION/ {print $3}' ../patchlevel.h`
else
patchlevel=0
subversion=0
fi
-echo "(You have $package $baserev PL$patchlevel sub$subversion.)"
+$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 ".)"
: set the prefixup variable, to restore leading tilda escape
prefixup='case "$prefixexp" in
@@ -2328,19 +2501,27 @@ set archlib archlib
eval $prefixit
case "$archlib" in
'')
- case "$privlib" in
- '')
- dflt=`./loc . "." $prefixexp/lib /usr/local/lib /usr/lib /lib`
- set dflt
- eval $prefixup
- ;;
- *) version=`echo $baserev $patchlevel $subversion | \
- $awk '{print $1 + $2/1000.0 + $3/100000.0}'`
- dflt="$privlib/$archname/$version"
- ;;
- esac
+ case "$privlib" in
+ '') dflt=`./loc . "." $prefixexp/lib /usr/local/lib /usr/lib /lib`
+ set dflt
+ eval $prefixup
;;
-*) dflt="$archlib";;
+ *) 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
+ dflt="$privlib/$archname/$version"
+ ;;
+ esac
+ ;;
+*)
+ dflt="$archlib"
+ ;;
esac
cat <<EOM
@@ -2359,9 +2540,10 @@ archlibexp="$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).
+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
@@ -2382,7 +2564,10 @@ else
fi
: set up the script used to warn in case of inconsistency
-cat <<'EOSC' >whoa
+cat <<EOS >whoa
+$startsh
+EOS
+cat <<'EOSC' >>whoa
dflt=y
echo " "
echo "*** WHOA THERE!!! ***" >&4
@@ -2402,6 +2587,33 @@ $undef$define) . ./whoa; eval "$var=\$tu";;
*) eval "$var=$val";;
esac'
+$cat <<EOM
+
+Perl 5.004 can be compiled for binary compatibility with 5.003.
+If you decide to do so, you will be able to continue using any
+extensions that were compiled for Perl 5.003. However, binary
+compatibility forces Perl to expose some of its internal symbols
+in the same way that 5.003 did. So you may have symbol conflicts
+if you embed a binary-compatible Perl in other programs.
+
+EOM
+case "$d_bincompat3" in
+"$undef") dflt=n ;;
+*) dflt=y ;;
+esac
+rp='Binary compatibility with Perl 5.003?'
+. ./myread
+case "$ans" in
+y*) val="$define" ;;
+*) val="$undef" ;;
+esac
+set d_bincompat3
+eval $setvar
+case "$d_bincompat3" in
+"$define") bincompat3=y ;;
+*) bincompat3=n ;;
+esac
+
: make some quick guesses about what we are up against
echo " "
$echo $n "Hmm... $c"
@@ -2412,6 +2624,7 @@ 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
@@ -2456,6 +2669,17 @@ EOI
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
@@ -2478,8 +2702,8 @@ else
echo "Nor is it Venix..."
fi
fi
-chmod +x bsd usg v7 osf1 eunice xenix venix
-$eunicefix bsd usg v7 osf1 eunice xenix venix
+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
@@ -2551,6 +2775,7 @@ EOM
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
@@ -2617,9 +2842,10 @@ sitelibexp="$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).
+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
@@ -2627,7 +2853,7 @@ EOM
*) dflt="$installsitelib";;
esac
fn=de~
- rp='Where will private files be installed?'
+ rp='Where will site-specific files be installed?'
. ./getfile
installsitelib="$ans"
else
@@ -2660,9 +2886,10 @@ sitearchexp="$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).
+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
@@ -2670,7 +2897,7 @@ EOM
*) dflt="$installsitearch";;
esac
fn=de~
- rp='Where will private files be installed?'
+ rp='Where will site-specific architecture-dependent files be installed?'
. ./getfile
installsitearch="$ans"
else
@@ -2693,12 +2920,13 @@ if $test ! -d "$dflt/auto"; then
fi
cat <<EOM
-In 5.001, Perl stored architecture-dependent library files in a library
+In 5.001, Perl stored architecture-dependent library files in a directory
with a name such as $privlib/$archname,
and this directory contained files from the standard extensions and
files from any additional extensions you might have added. Starting
with version 5.002, all the architecture-dependent standard extensions
-will go into $archlib,
+will go into a version-specific directory such as
+$archlib,
while locally-added extensions will go into
$sitearch.
@@ -2770,264 +2998,6 @@ else
echo "Could not find manual pages in source form." >&4
fi
-: 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"
- : If prefix contains 'perl' then we want to keep the man pages
- : under the prefix directory. Otherwise, look in a variety of
- : other possible places. This is debatable, but probably a
- : good compromise. Well, apparently not.
- : Experience has shown people expect man1dir to be under prefix,
- : so we now always put it there. Users who want other behavior
- : can answer interactively or use a command line option.
- : Does user have System V-style man paths.
- 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.
-You can use the supplied perldoc script instead.
-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.
-You can use the supplied perldoc script instead.
-EOM
- case "$man3dir" in
- '') man3dir="none";;
- esac;;
-esac
-
-echo "If you don't want the manual sources installed, answer 'none'."
-: We dont use /usr/local/man/man3 because some man programs will
-: only show the /usr/local/man/man3 contents, and not the system ones,
-: thus man less will show the perl module less.pm, but not the system
-: less command. We might also conflict with TCL man pages.
-: However, something like /opt/perl/man/man3 is fine.
-case "$man3dir" in
-'') 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
- ;;
-' ') dflt=none;;
-*) dflt="$man3dir" ;;
-esac
-echo " "
-
-fn=dn+~
-rp="Where do the $spackage 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 $spackage 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 what memory models we can support
case "$models" in
'')
@@ -3040,8 +3010,8 @@ main() {
#endif
}
EOP
- cc -o pdp11 pdp11.c >/dev/null 2>&1
- if ./pdp11 2>/dev/null; then
+ (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`
@@ -3296,377 +3266,176 @@ y) fn=d/
;;
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
-
-: 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='';;
+: 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
-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"
+: 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'
-: 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
+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.
-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)"
+EOM
+case "$libpth" in
+'') dflt='none';;
+*)
+ set X $libpth
+ shift
+ dflt=${1+"$@"}
;;
-*) case "$mydomain" in
- '')
- {
- : If we use NIS, try ypmatch.
- : Is there some reason why this was not done before?
- test "X$hostcat" = "Xypcat hosts" &&
- ypmatch "$myhostname" hosts 2>/dev/null |\
- $sed -e 's/[ ]*#.*//; s/$/ /' > hosts && \
- $test -s hosts
- } || {
- : Extract only the relevant hosts, reducing file size,
- : remove comments, insert trailing space for later use.
- $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=.
- ;;
- .) 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)"
- : Why was there an Egrep here, when Sed works?
- dflt=.`$sed -n -e 's/^domain[ ]*\(.*\)/\1/p' $tans \
- | ./tr '[A-Z]' '[a-z]' 2>/dev/null`
- 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?"
+rp="Directories to use for library searches?"
. ./myread
-tans="$ans"
case "$ans" in
-'') ;;
-.*) ;;
-*) tans=".$tans";;
+none) libpth=' ';;
+*) libpth="$ans";;
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]'`
- ;;
+: Define several unixisms. Hints files or command line options
+: can be used to override them.
+case "$ar" in
+'') ar='ar';;
+esac
+case "$lib_ext" in
+'') lib_ext='.a';;
+esac
+case "$obj_ext" in
+'') obj_ext='.o';;
+esac
+case "$path_sep" in
+'') path_sep=':';;
+esac
+: Which makefile gets called first. This is used by make depend.
+case "$firstmakefile" in
+'') firstmakefile='makefile';;
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
+: 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
-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...
+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
-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 ;;
+rp='What is the file extension used for shared libraries?'
+. ./myread
+so="$ans"
+
+: 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
- . ./myread
- case "$ans" in
- y*) cont='' ;;
- *) echo " " ;;
+ 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
- ;;
- esac
+ elif xxx=`./loc lib$thislib$lib_ext X $libpth`; $test -f "$xxx"; then
+ echo "Found -l$thislib."
+ case " $dflt " in
+ *"-l$thislib "*);;
+ *) dflt="$dflt -l$thislib";;
+ esac
+ elif xxx=`./loc $thislib$lib_ext 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$lib_ext 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$lib_ext 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
-
-$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";;
+set X $dflt
+shift
+dflt="$*"
+case "$libs" in
+'') dflt="$dflt";;
+*) dflt="$libs";;
esac
-rp='Perl administrator e-mail address'
-. ./myread
-perladmin="$ans"
-
-: 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"
- ;;
+case "$dflt" in
+' '|'') dflt='none';;
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).
+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
- 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 perl absolute location
-case "$perlpath" in
-'') perlpath=$binexp/perl ;;
-esac
-
-: 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
-($perlpath) on all your platforms. The alternative is to force
-a shell by starting the script with a single ':' character.
-EOH
- dflt=$perlpath
- 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";;
- esac
- ;;
- *) startperl=": # use perl"
- ;;
- esac
- ;;
+echo " "
+rp="Any additional libraries?"
+. ./myread
+case "$ans" in
+none) libs=' ';;
+*) libs="$ans";;
esac
-echo "I'll use $startperl to start perl scripts."
: see how we invoke the C preprocessor
echo " "
@@ -3806,61 +3575,15 @@ case "$cppstdin" in
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
-
: determine optimize, if desired, or use for debug flag also
case "$optimize" in
-' ') dflt='none';;
+' '|$undef) dflt='none';;
'') dflt='-O';;
*) dflt="$optimize";;
esac
$cat <<EOH
-Some C compilers have problems with their optimizers, by default, $package
+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
@@ -3930,8 +3653,6 @@ if ./osf1; then
else
set signal.h LANGUAGE_C; eval $inctest
fi
-set signal.h NO_PROTOTYPE; eval $inctest
-set signal.h _NO_PROTO; eval $inctest
case "$hint" in
none|recommended) dflt="$ccflags $dflt" ;;
@@ -3992,7 +3713,7 @@ EOM
-*) ftry="$flag";;
*) ftry="$previous $flag";;
esac
- if $cppstdin -DLFRULB=bar $ftry $cppminus <cpp.c \
+ if $cppstdin -DLFRULB=bar $cppflags $ftry $cppminus <cpp.c \
>cpp1.out 2>/dev/null && \
$cpprun -DLFRULB=bar $ftry $cpplast <cpp.c \
>cpp2.out 2>/dev/null && \
@@ -4070,8 +3791,8 @@ rmlist="$rmlist pdp11"
: coherency check
echo " "
-echo "Checking your choice of C compiler and flags for coherency..." >&4
-set X $cc $optimize $ccflags $ldflags try.c -o try
+echo "Checking your choice of C compiler, libs, and flags for coherency..." >&4
+set X $cc $optimize $ccflags $ldflags -o try try.c $libs
shift
$cat >try.msg <<EOM
I've tried to compile and run a simple program with:
@@ -4087,22 +3808,22 @@ $cat > try.c <<'EOF'
main() { exit(0); }
EOF
dflt=y
-if sh -c "$cc $optimize $ccflags try.c -o try $ldflags" >>try.msg 2>&1; then
+if sh -c "$cc $optimize $ccflags -o try try.c $ldflags $libs" >>try.msg 2>&1; then
if sh -c './try' >>try.msg 2>&1; then
dflt=n
else
echo "The program compiled OK, but exited with status $?." >>try.msg
- rp="You have a problem. Shall I abort Configure"
+ rp="You have a problem. Shall I abort Configure (and explain the problem)"
dflt=y
fi
else
echo "I can't compile the test program." >>try.msg
- rp="You have a BIG problem. Shall I abort Configure"
+ rp="You have a BIG problem. Shall I abort Configure (and explain the problem)"
dflt=y
fi
case "$dflt" in
y)
- $cat try.msg
+ $cat try.msg >&4
case "$knowitall" in
'')
echo "(The supplied flags might be incorrect with this C compiler.)"
@@ -4122,121 +3843,43 @@ n) echo "OK, that should do.";;
esac
$rm -f try try.* core
-: 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"
-
-: 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 newer Unix System V'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.
+echo "Checking for GNU C Library..." >&4
+cat >gnulibc.c <<EOM
+int
+main()
+{
+ return __libc_main();
+}
EOM
-
-echo " "
-rp="Any additional libraries?"
-. ./myread
-case "$ans" in
-none) libs=' ';;
-*) libs="$ans";;
-esac
+if $cc $ccflags $ldflags -o gnulibc gnulibc.c $libs >/dev/null 2>&1 && \
+ ./gnulibc | $contains '^GNU C Library' >/dev/null 2>&1; 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=`egrep 'inlibc|csym' ../Configure | wc -l 2>/dev/null`
- if $test $dflt -gt 20; then
- dflt=y
- else
+ case "$d_gnulibc" in
+ $define)
dflt=n
- fi
+ ;;
+ *)
+ dflt=`egrep 'inlibc|csym' ../Configure | wc -l 2>/dev/null`
+ if $test $dflt -gt 20; then
+ dflt=y
+ else
+ dflt=n
+ fi
+ ;;
+ esac
;;
*)
case "$usenm" in
@@ -4253,6 +3896,7 @@ 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 shouldn't let me use 'nm' if you have the GNU C Library.
EOM
rp='Shall I use nm to extract C symbols from the libraries?'
@@ -4270,11 +3914,13 @@ esac
: nm options which may be necessary
case "$nm_opt" in
'') if $test -f /mach_boot; then
- nm_opt=''
+ nm_opt='' # Mach
elif $test -d /usr/ccs/lib; then
- nm_opt='-p'
+ nm_opt='-p' # Solaris (and SunOS?)
elif $test -f /dgux; then
- nm_opt='-p'
+ nm_opt='-p' # DG-UX
+ elif $test -f /lib64/rld; then
+ nm_opt='-p' # 64-bit Irix
else
nm_opt=''
fi;;
@@ -4300,7 +3946,7 @@ echo " "
case "$libc" in
'') libc=unknown
case "$libs" in
- *-lc_s*) libc=`./loc libc_s.a $libc $libpth`
+ *-lc_s*) libc=`./loc libc_s$lib_ext $libc $libpth`
esac
;;
esac
@@ -4318,13 +3964,15 @@ case "$libs" in
:
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 lib$thislib$lib_ext X $libpth`; $test -f "$try"; then
+ :
+ elif try=`./loc $thislib$lib_ext 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
+ elif try=`./loc Slib$thislib$lib_ext X $xlibpth`; $test -f "$try"; then
:
else
try=''
@@ -4355,7 +4003,7 @@ unknown)
eval set \$$#
done
$test -r $1 || set /usr/ccs/lib/libc.$so
- $test -r $1 || set /lib/libsys_s.a
+ $test -r $1 || set /lib/libsys_s$lib_ext
;;
*)
set blurfl
@@ -4374,25 +4022,25 @@ elif $test -r /lib/libc && $test -r /lib/clib; then
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;
+elif $test -r $incpath/usr/lib/libc$lib_ext; then
+ libc=$incpath/usr/lib/libc$lib_ext;
echo "Your C library seems to be in $libc. That's fine."
-elif $test -r /lib/libc.a; then
- libc=/lib/libc.a;
+elif $test -r /lib/libc$lib_ext; then
+ libc=/lib/libc$lib_ext;
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
+ if tans=`./loc libc$lib_ext 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 Slibc$lib_ext blurfl/dyick $xlibpth`; $test -r "$tans"; then
:
- elif tans=`./loc Mlibc.a blurfl/dyick $xlibpth`; $test -r "$tans"; then
+ elif tans=`./loc Mlibc$lib_ext blurfl/dyick $xlibpth`; $test -r "$tans"; then
:
else
- tans=`./loc Llibc.a blurfl/dyick $xlibpth`
+ tans=`./loc Llibc$lib_ext blurfl/dyick $xlibpth`
fi
if $test -r "$tans"; then
echo "Your C library seems to be in $tans, of all places."
@@ -4455,7 +4103,7 @@ $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'";\
+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
@@ -4492,6 +4140,10 @@ 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
@@ -4500,6 +4152,10 @@ 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
@@ -4546,6 +4202,100 @@ fi
esac
$rm -f libnames libpath
+: 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 dld is available
+set dld.h i_dld
+eval $inhdr
+
: is a C symbol defined?
csym='tlook=$1;
case "$3" in
@@ -4609,30 +4359,1194 @@ yes)
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 ../$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 ../$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.
+ cd ..; ls -C $dldir/dl*.xs; cd UU
+ rp="Source file to use for dynamic loading"
+ fn="fne"
+ . ./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' ;;
+ svr4*|esix*) dflt='-Kpic' ;;
+ irix*) dflt='-KPIC' ;;
+ solaris) case "$ccflags" in
+ *-DDEBUGGING*) dflt='-KPIC' ;;
+ *) dflt='-Kpic' ;;
+ esac ;;
+ sunos) dflt='-pic' ;;
+ *) dflt='none' ;;
+ esac ;;
+ *) case "$osname/$ccflags" in
+ solaris/*-DDEBUGGING*) dflt='-fPIC' ;;
+ *) dflt='-fpic' ;;
+ esac ;;
+ esac ;;
+ *) 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="$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
+ ;;
+ sunos)
+ dflt=n
+ also='Building a shared libperl will definitely not work on SunOS 4.'
+ ;;
+ *) 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${lib_ext}, 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' ;;
+ *) xxx='LD_LIBRARY_PATH' ;;
+ esac
+ $cat <<EOM >&4
+
+To build perl, you must add the current working directory to your
+$xxx environtment 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
+ ;;
+ *) 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${lib_ext}"
+ ;;
+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 (chip@perl.com) 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"
+ : If prefix contains 'perl' then we want to keep the man pages
+ : under the prefix directory. Otherwise, look in a variety of
+ : other possible places. This is debatable, but probably a
+ : good compromise. Well, apparently not.
+ : Experience has shown people expect man1dir to be under prefix,
+ : so we now always put it there. Users who want other behavior
+ : can answer interactively or use a command line option.
+ : Does user have System V-style man paths.
+ 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.
+You can use the supplied perldoc script instead.
+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.
+You can use the supplied perldoc script instead.
+EOM
+ case "$man3dir" in
+ '') man3dir="none";;
+ esac;;
+esac
+
+echo "If you don't want the manual sources installed, answer 'none'."
+: We dont use /usr/local/man/man3 because some man programs will
+: only show the /usr/local/man/man3 contents, and not the system ones,
+: thus man less will show the perl module less.pm, but not the system
+: less command. We might also conflict with TCL man pages.
+: However, something like /opt/perl/man/man3 is fine.
+case "$man3dir" in
+'') 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
+ ;;
+' ') dflt=none;;
+*) dflt="$man3dir" ;;
+esac
+echo " "
+
+fn=dn+~
+rp="Where do the $spackage 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 $spackage 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
+
+: 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
+ '')
+ {
+ : If we use NIS, try ypmatch.
+ : Is there some reason why this was not done before?
+ test "X$hostcat" = "Xypcat hosts" &&
+ ypmatch "$myhostname" hosts 2>/dev/null |\
+ $sed -e 's/[ ]*#.*//; s/$/ /' > hosts && \
+ $test -s hosts
+ } || {
+ : Extract only the relevant hosts, reducing file size,
+ : remove comments, insert trailing space for later use.
+ $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)"
+ : Why was there an Egrep here, when Sed works?
+ : Look for either a search or a domain directive.
+ 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
+
+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 and is the only supported mechanism. This abstraction
+layer can use AT&T's sfio (if you already have sfio installed) or
+fall back on standard IO. This PerlIO abstraction layer is
+experimental and may cause problems with some extension modules.
+
+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.
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
-main() {
+
+#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);
- if (buf[0] != '1' || buf[1] != '\0')
- exit(1);
+ checkit("1", buf);
+
Gconvert(0.0, 8, 0, buf);
- if (buf[0] != '0' || buf[1] != '\0')
- exit(1);
+ checkit("0", buf);
+
Gconvert(-1.0, 8, 0, buf);
- if (buf[0] != '-' || buf[1] != '1' || buf[2] != '\0')
- exit(1);
+ 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
@@ -4650,11 +5564,10 @@ for xxx_convert in $xxx_list; do
try.c $libs > /dev/null 2>&1 ; then
echo "$xxx_convert" found. >&4
if ./try; then
- echo "Good, $xxx_convert drops a trailing decimal point."
echo "I'll use $xxx_convert to convert floats into a string." >&4
break;
else
- echo "But $xxx_convert keeps a trailing decimal point".
+ echo "...But $xxx_convert didn't work as I expected."
fi
else
echo "$xxx_convert NOT found." >&4
@@ -4673,66 +5586,6 @@ h_fcntl=false
: Initialize h_sysfile
h_sysfile=false
-: 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
-
: access call always available on UNIX
set access d_access
eval $inlibc
@@ -4810,81 +5663,189 @@ eval $inlibc
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
+
+echo "Checking to see which flavor of getpgrp is in use . . . "
+case "$d_getpgrp" in
+"$define")
+ echo " "
+ $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
-: see which flavor of setpgrp is in use
+echo "Checking to see which flavor of setpgrp is in use . . . "
case "$d_setpgrp" in
"$define")
echo " "
$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(1);
- exit(0);
+ exit(0);
+#else
+ if (setpgrp() != -1)
+ exit(0);
+#endif
+ exit(1);
}
EOP
- if $cc $ccflags $ldflags -o set set.c $libs >/dev/null 2>&1; then
- ./set 2>/dev/null
- case $? in
- 0) echo "You have to use setpgrp() instead of setpgrp(pid, pgrp)." >&4
- val="$undef";;
- *) echo "You have to use setpgrp(pid, pgrp) instead of setpgrp()." >&4
- val="$define";;
- esac
+ 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="USG one, i.e. you use setpgrp()."
- val="$undef"
+ xxx="a USG one, i.e. you use setpgrp()."
else
- xxx="BSD one, i.e. you use setpgrp(pid, pgrp)."
- val="$define"
+ # 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 a $xxx" >&4
+ echo "Assuming your setpgrp is $xxx" >&4
fi
;;
*) val="$undef";;
esac
-set d_bsdpgrp
+set d_bsdsetpgrp
eval $setvar
+d_bsdpgrp=$d_bsdsetpgrp
$rm -f set set.c
-
: see if bzero exists
set bzero d_bzero
eval $inlibc
-: check for length of integer
+: check for lengths of integral types
echo " "
case "$intsize" in
'')
echo "Checking to see how big your integers are..." >&4
- $cat >try.c <<'EOCP'
+ $cat >intsize.c <<'EOCP'
#include <stdio.h>
main()
{
- printf("%d\n", sizeof(int));
+ printf("intsize=%d;\n", sizeof(int));
+ printf("longsize=%d;\n", sizeof(long));
+ printf("shortsize=%d;\n", sizeof(short));
+ fflush(stdout);
exit(0);
}
EOCP
- if $cc $ccflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then
- intsize=`./try`
+# If $libs contains -lsfio, and sfio is mis-configured, then it
+# sometimes (apparently) runs and exits with a 0 status, but with no
+# output!. Thus we check with test -s whether we actually got any
+# output. I think it has to do with sfio's use of _exit vs. exit,
+# but I don't know for sure. --Andy Dougherty 1/27/97.
+ if $cc $optimize $ccflags $ldflags -o intsize intsize.c $libs >/dev/null 2>&1 &&
+ ./intsize > intsize.out 2>/dev/null && test -s intsize.out ; then
+ eval `$cat intsize.out`
echo "Your integers are $intsize bytes long."
+ echo "Your long integers are $longsize bytes long."
+ echo "Your short integers are $shortsize bytes long."
else
- dflt='4'
- echo "(I can't seem to compile the test program. Guessing...)"
+ $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 try.c try
+$rm -f intsize intsize.[co] intsize.out
: see if signal is declared as pointer to function returning int or void
echo " "
@@ -5130,19 +6091,19 @@ if set crypt val -f d_crypt; eval $csym; $val; then
val="$define"
cryptlib=''
else
- cryptlib=`./loc Slibcrypt.a "" $xlibpth`
+ cryptlib=`./loc Slibcrypt$lib_ext "" $xlibpth`
if $test -z "$cryptlib"; then
- cryptlib=`./loc Mlibcrypt.a "" $xlibpth`
+ cryptlib=`./loc Mlibcrypt$lib_ext "" $xlibpth`
else
cryptlib=-lcrypt
fi
if $test -z "$cryptlib"; then
- cryptlib=`./loc Llibcrypt.a "" $xlibpth`
+ cryptlib=`./loc Llibcrypt$lib_ext "" $xlibpth`
else
cryptlib=-lcrypt
fi
if $test -z "$cryptlib"; then
- cryptlib=`./loc libcrypt.a "" $libpth`
+ cryptlib=`./loc libcrypt$lib_ext "" $libpth`
else
cryptlib=-lcrypt
fi
@@ -5158,47 +6119,20 @@ eval $setvar
: get csh whereabouts
case "$csh" in
-'csh') val="$undef" ;;
-*) val="$define" ;;
+'csh') val="$undef" ;;
+*) val="$define" ;;
esac
set d_csh
eval $setvar
-full_csh=$csh
+: Respect a hint or command line value for full_csh.
+case "$full_csh" in
+'') full_csh=$csh ;;
+esac
: see if cuserid exists
set cuserid d_cuserid
eval $inlibc
-: 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 limits.h system
set limits.h i_limits
eval $inhdr
@@ -5313,261 +6247,6 @@ set dlerror d_dlerror
eval $inlibc
runnm="$xxx_runnm"
-: see if dld is available
-set dld.h i_dld
-eval $inhdr
-
-: 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 ../$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 ../$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.
- cd ..; ls -C $dldir/dl*.xs; cd UU
- rp="Source file to use for dynamic loading"
- fn="fne"
- . ./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' ;;
- solaris|svr4*|esix*) dflt='-Kpic' ;;
- sunos) dflt='-pic' ;;
- *) dflt='none' ;;
- esac ;;
- *) dflt='-fpic' ;;
- esac ;;
- *) 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) 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="$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
-
-val="$undef"
-case "$osname" in
-esix*|svr4*)
- case "$usedl" in
- $define)
- $cat <<EOM
-
-System V Release 4 systems can support dynamic loading
-only if libperl is created as a shared library.
-
-EOM
- val="$define"
- ;;
- esac ;;
-esac
-set d_shrplib; eval $setvar
-case "$d_shrplib" in
-$define)
- cat <<EOM >&4
-
-Be sure to add the perl source directory to the LD_LIBRARY_PATH
-environment variable before running make:
- LD_LIBRARY_PATH=`cd ..;pwd`; export LD_LIBRARY_PATH
-or
- setenv LD_LIBRARY_PATH `cd ..;pwd`
-
-EOM
-;;
-esac
-case "$d_shrplib" in
-$define)
- case "$shrpdir" in
- "") dflt="$archlib/CORE";;
- *) dflt="$shrpdir";;
- esac
- rp="What directory should we install the shared libperl into?"
- fn="d~"
- . ./getfile
- shrpdir="$ans"
- ;;
-*) shrpdir='none'
- ;;
-esac
-
: see if dlfcn is available
set dlfcn.h i_dlfcn
eval $inhdr
@@ -5630,26 +6309,31 @@ main()
#endif
handle = dlopen("./dyna.$dlext", mode) ;
if (handle == NULL) {
- printf ("1\n") ;
- exit(0);
+ 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") ;
- exit(0);
- }
- printf ("3\n") ;
+ /* 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") ;
- exit(0);
+ 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 &&
- $ld $lddlflags -o dyna.$dlext dyna.o > /dev/null 2>&1 &&
+ mv dyna${obj_ext} tmp-dyna${obj_ext} > /dev/null 2>&1 &&
+ $ld $lddlflags -o dyna.$dlext tmp-dyna${obj_ext} > /dev/null 2>&1 &&
$cc $ccflags $ldflags $cccdlflags $ccdlflags fred.c -o fred $libs > /dev/null 2>&1; then
xxx=`./fred`
case $xxx in
@@ -5667,7 +6351,7 @@ EOM
;;
esac
-$rm -f fred fred.? dyna.$dlext dyna.?
+$rm -f fred fred.? dyna.$dlext dyna.? tmp-dyna.?
set d_dlsymun
eval $setvar
@@ -5697,7 +6381,7 @@ main() {
EOCP
: check sys/file.h first to get FREAD on Sun
if $test `./findhdr sys/file.h` && \
- $cc $cppflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then
+ $cc $ccflags "-DI_SYS_FILE" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then
h_sysfile=true;
echo "<sys/file.h> defines the O_* constants..." >&4
if ./open3; then
@@ -5708,7 +6392,7 @@ if $test `./findhdr sys/file.h` && \
val="$undef"
fi
elif $test `./findhdr fcntl.h` && \
- $cc "-DI_FCNTL" open3.c -o open3 >/dev/null 2>&1 ; then
+ $cc $ccflags "-DI_FCNTL" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then
h_fcntl=true;
echo "<fcntl.h> defines the O_* constants..." >&4
if ./open3; then
@@ -5873,7 +6557,7 @@ EOCP
*) echo "However, your read() returns '$status' on EOF??";;
esac
val="$define"
- if test "$status" -eq "$rd_nodata"; then
+ if test "$status" = "$rd_nodata"; then
echo "WARNING: you can't distinguish between EOF and no data!"
val="$undef"
fi
@@ -5943,8 +6627,8 @@ eval $inlibc
set getlogin d_getlogin
eval $inlibc
-: see if getpgrp exists
-set getpgrp d_getpgrp
+: see if getpgid exists
+set getpgid d_getpgid
eval $inlibc
: see if getpgrp2 exists
@@ -5959,6 +6643,25 @@ eval $inlibc
set getpriority d_getprior
eval $inlibc
+: 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
@@ -6052,6 +6755,10 @@ 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'
@@ -6362,13 +7069,59 @@ eval $inlibc
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 >foo.c <<'EOCP'
+ $cat >foo.c <<EOCP
+#$i_memory I_MEMORY
+#$i_stdlib I_STDLIB
+#$i_string I_STRING
+#$i_unistd I_UNISTD
+EOCP
+ $cat >>foo.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];
@@ -6377,6 +7130,8 @@ 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. */
bcopy("abcdefghijklmnopqrstuvwxyz0123456789", abc, 36);
for (align = 7; align >= 0; align--) {
@@ -6394,15 +7149,22 @@ for (align = 7; align >= 0; align--) {
exit(0);
}
EOCP
- if $cc $ccflags $ldflags foo.c -o safebcpy $libs >/dev/null 2>&1; then
+ if $cc $optimize $ccflags $ldflags foo.c \
+ -o safebcpy $libs >/dev/null 2>&1; then
if ./safebcpy 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
@@ -6416,7 +7178,29 @@ case "$d_memcpy" in
"$define")
echo " "
echo "Checking to see if your memcpy() can do overlapping copies..." >&4
- $cat >foo.c <<'EOCP'
+ $cat >foo.c <<EOCP
+#$i_memory I_MEMORY
+#$i_stdlib I_STDLIB
+#$i_string I_STRING
+#$i_unistd I_UNISTD
+EOCP
+ $cat >>foo.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];
@@ -6425,6 +7209,8 @@ 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--) {
@@ -6442,15 +7228,22 @@ for (align = 7; align >= 0; align--) {
exit(0);
}
EOCP
- if $cc $ccflags $ldflags foo.c -o safemcpy $libs >/dev/null 2>&1; then
+ if $cc $optimize $ccflags $ldflags foo.c \
+ -o safemcpy $libs >/dev/null 2>&1; then
if ./safemcpy 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
@@ -6458,6 +7251,61 @@ $rm -f foo.* safemcpy core
set d_safemcpy
eval $setvar
+: can memcmp be trusted to compare relative magnitude?
+val="$undef"
+case "$d_memcmp" in
+"$define")
+ echo " "
+ echo "Checking to see if your memcmp() can compare relative magnitude..." >&4
+ $cat >foo.c <<EOCP
+#$i_memory I_MEMORY
+#$i_stdlib I_STDLIB
+#$i_string I_STRING
+#$i_unistd I_UNISTD
+EOCP
+ $cat >>foo.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
+ if $cc $optimize $ccflags $ldflags foo.c \
+ -o sanemcmp $libs >/dev/null 2>&1; then
+ if ./sanemcmp 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 foo.* sanemcmp core
+set d_sanemcmp
+eval $setvar
+
: see if select exists
set select d_select
eval $inlibc
@@ -6543,6 +7391,59 @@ eval $inlibc
set setsid d_setsid
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
@@ -6605,34 +7506,44 @@ fi
set d_shm
eval $setvar
-: see if sigvector exists -- since sigvec will match the substring
echo " "
-if set sigvector val -f d_sigvectr; eval $csym; $val; then
- echo 'sigvector() found--you must be running HP-UX.' >&4
- val="$define"; set d_sigvectr; eval $setvar
- val="$define"; set d_sigvec; eval $setvar
+: see if we have sigaction
+if set sigaction val -f d_sigaction; eval $csym; $val; then
+ echo 'sigaction() found.' >&4
+ val="$define"
else
-: try the original name
- d_sigvectr="$undef"
- if set sigvec val -f d_sigvec; eval $csym; $val; then
- echo 'sigvec() found.' >&4
- val="$define"; set d_sigvec; eval $setvar
- else
- echo 'sigvec() not found--race conditions with signals may occur.' >&4
- val="$undef"; set d_sigvec; eval $setvar
- fi
+ echo 'sigaction NOT found.' >&4
+ val="$undef"
fi
-: see if we have sigaction
-set sigaction d_sigaction
-eval $inlibc
+$cat > set.c <<'EOP'
+/* Solaris 2.5_x86 with SunWorks Pro C 3.0.1 doesn't have a complete
+ sigaction structure if compiled with cc -Xc. This compile test
+ will fail then. <doughera@lafcol.lafayette.edu>
+*/
+#include <stdio.h>
+#include <sys/types.h>
+#include <signal.h>
+main()
+{
+ struct sigaction act, oact;
+}
+EOP
+if $cc $ccflags $ldflags -o set set.c $libs >/dev/null 2>&1; then
+ :
+else
+ echo "But you don't seem to have a useable struct sigaction." >&4
+ val="$undef"
+fi
+set d_sigaction; eval $setvar
+$rm -f set set.o set.c
: see if sigsetjmp exists
echo " "
case "$d_sigsetjmp" in
'')
- $cat >set.c <<EOP
+ $cat >set.c <<'EOP'
#include <setjmp.h>
sigjmp_buf env;
int set = 1;
@@ -6645,25 +7556,26 @@ main()
exit(1);
}
EOP
- if $cc $ccflags $ldflags set.c -o set $libs >/dev/null 2>&1; then
+ if $cc $ccflags $ldflags -o set set.c $libs > /dev/null 2>&1 ; then
if ./set >/dev/null 2>&1; then
echo "POSIX sigsetjmp found." >&4
val="$define"
else
- $cat <<EOM
+ $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
+ 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;;
+ $undef) echo "sigsetjmp not found." >&4;;
esac
;;
esac
@@ -6692,10 +7604,10 @@ else
: 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
+ echo "You don't have Berkeley networking in libc$lib_ext..." >&4
+ if test -f /usr/lib/libnet$lib_ext; then
+ ( (nm $nm_opt /usr/lib/libnet$lib_ext | eval $nm_extract) || \
+ ar t /usr/lib/libnet$lib_ext) 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"
@@ -6708,7 +7620,7 @@ else
d_oldsock="$define"
fi
else
- echo "or even in libnet.a, which is peculiar." >&4
+ echo "or even in libnet$lib_ext, which is peculiar." >&4
d_socket="$undef"
d_oldsock="$undef"
fi
@@ -6790,7 +7702,7 @@ $cat >try.c <<EOP
#include <stdio.h>
#define FILE_ptr(fp) $stdio_ptr
#define FILE_cnt(fp) $stdio_cnt
-main() {
+main() {
FILE *fp = fopen("try.c", "r");
char c = getc(fp);
if (
@@ -6832,6 +7744,7 @@ esac
set d_stdio_cnt_lval
eval $setvar
+
: see if _base is also standard
val="$undef"
case "$d_stdstdio" in
@@ -6840,7 +7753,7 @@ $define)
#include <stdio.h>
#define FILE_base(fp) $stdio_base
#define FILE_bufsiz(fp) $stdio_bufsiz
-main() {
+main() {
FILE *fp = fopen("try.c", "r");
char c = getc(fp);
if (
@@ -6853,7 +7766,7 @@ main() {
EOP
if $cc $ccflags $ldflags -o try try.c $libs > /dev/null 2>&1; then
if ./try; then
- echo "Even its _base field acts std."
+ echo "And its _base field acts std."
val="$define"
else
echo "But its _base field isn't std."
@@ -6932,6 +7845,18 @@ else
d_strerrm='"unknown"'
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
@@ -7235,7 +8160,7 @@ EOCP
dflt=`./try`
else
dflt='8'
- echo"(I can't seem to compile the test program...)"
+ echo "(I can't seem to compile the test program...)"
fi
;;
*) dflt="$alignbytes"
@@ -7246,25 +8171,6 @@ rp="Doubles must be aligned on a how-many-byte boundary?"
alignbytes="$ans"
$rm -f try.c try
-: Define several unixisms. Hints files or command line options
-: can be used to override them.
-case "$ar" in
-'') ar='ar';;
-esac
-case "$lib_ext" in
-'') lib_ext='.a';;
-esac
-case "$obj_ext" in
-'') obj_ext='.o';;
-esac
-case "$path_sep" in
-'') path_sep=':';;
-esac
-: Which makefile gets called first. This is used by make depend.
-case "$firstmakefile" in
-'') firstmakefile='makefile';;
-esac
-
: check for ordering of bytes in a long
case "$byteorder" in
'')
@@ -7361,6 +8267,55 @@ set db.h i_db
eval $inhdr
case "$i_db" in
+$define)
+ : Check db version. We can not use version 2.
+ 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: not yet. */
+ printf("You have Berkeley DB Version %d.%d\n",
+ DB_VERSION_MAJOR, DB_VERSION_MINOR);
+ printf("Perl currently only supports up to version 1.86.\n");
+ exit(2);
+#else
+#if defined(_DB_H_) && defined(BTREEMAGIC) && defined(HASHMAGIC)
+ exit(0); /* DB version < 2: the coast is clear. */
+#else
+ exit(1); /* <db.h> not Berkeley DB? */
+#endif
+#endif
+}
+EOCP
+ if $cc $optimize $ccflags $ldflags -o try try.c $libs && ./try; then
+ echo 'Looks OK. (Perl supports up to version 1.86).' >&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 " "
@@ -7390,13 +8345,15 @@ EOCP
db_hashtype='u_int32_t'
fi
else
- echo "I can't seem to compile the test program." >&4
- db_hashtype=int
+ : XXX Maybe we should just give up here.
+ db_hashtype=u_int32_t
+ 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=int
+*) db_hashtype=u_int32_t
;;
esac
@@ -7430,13 +8387,15 @@ EOCP
db_prefixtype='size_t'
fi
else
- echo "I can't seem to compile the test program." >&4
- db_prefixtype='int'
+ db_prefixtype='size_t'
+ : XXX Maybe we should just give up here.
+ 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='int'
+*) db_prefixtype='size_t'
;;
esac
@@ -7456,9 +8415,9 @@ case "$voidflags" in
'')
$cat >try.c <<'EOCP'
#if TRY & 1
-void main() {
+void sub() {
#else
-main() {
+sub() {
#endif
extern void moo(); /* function returning void */
void (*goo)(); /* ptr to func returning void */
@@ -7476,8 +8435,9 @@ main() {
#endif
exit(0);
}
+main() { sub(); }
EOCP
- if $cc -c -DTRY=$defvoidused try.c >.out 2>&1 ; then
+ if $cc $ccflags -c -DTRY=$defvoidused try.c >.out 2>&1 ; then
voidflags=$defvoidused
echo "It appears to support void to the level $package wants ($defvoidused)."
if $contains warning .out >/dev/null 2>&1; then
@@ -7486,16 +8446,16 @@ EOCP
fi
else
echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4
- if $cc -c -DTRY=1 try.c >/dev/null 2>&1 ; then
+ if $cc $ccflags -c -DTRY=1 try.c >/dev/null 2>&1; then
echo "It supports 1..."
- if $cc -c -DTRY=3 try.c >/dev/null 2>&1 ; then
+ if $cc $ccflags -c -DTRY=3 try.c >/dev/null 2>&1; then
echo "It also supports 2..."
- if $cc -c -DTRY=7 try.c >/dev/null 2>&1 ; then
+ 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 -c -DTRY=11 try.c >/dev/null 2>&1 ; then
+ if $cc $ccflags -c -DTRY=11 try.c >/dev/null 2>&1; then
voidflags=11
echo "But it supports 8."
else
@@ -7505,11 +8465,11 @@ echo "Hmm, your compiler has some difficulty with void. Checking further..." >&4
fi
else
echo "It does not support 2..."
- if $cc -c -DTRY=13 try.c >/dev/null 2>&1 ; then
+ 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 -c -DTRY=5 try.c >/dev/null 2>&1 ; then
+ 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
@@ -7570,20 +8530,24 @@ gidtype="$ans"
set getgroups d_getgrps
eval $inlibc
-: Find type of 2nd arg to getgroups
+: see if setgroups exists
+set setgroups d_setgrps
+eval $inlibc
+
+: Find type of 2nd arg to 'getgroups()' and 'setgroups()'
echo " "
-case "$d_getgrps" in
-'define')
+case "$d_getgrps$d_setgrps" in
+*define*)
case "$groupstype" in
'') dflt="$gidtype" ;;
*) dflt="$groupstype" ;;
esac
$cat <<EOM
-What is the type of the second argument to getgroups()? Usually this
-is the same as group ids, $gidtype, but not always.
+What is the type of the second argument to getgroups() and setgroups()?
+Usually this is the same as group ids, $gidtype, but not always.
EOM
- rp='What type is the second argument to getgroups()?'
+ rp='What type is the second argument to getgroups() and setgroups()?'
. ./myread
groupstype="$ans"
;;
@@ -7599,6 +8563,42 @@ rp="What type is lseek's offset on this system declared as?"
. ./myread
lseektype="$ans"
+echo " "
+case "$make" in
+'')
+ make=`./loc make make $pth`
+ case "$make" in
+ /*) echo make is in $make. ;;
+ ?:[\\/]*) echo make is in $make. ;;
+ *) echo "I don't know where 'make' is, and my life depends on it." >&4
+ echo "Go find a make program or fix your PATH setting!" >&4
+ exit 1
+ ;;
+ esac
+ ;;
+*) echo make is in $make. ;;
+esac
+
+$echo $n "Checking if your $make program sets \$(MAKE)... $c" >&4
+case "$make_set_make" in
+'')
+ $sed 's/^X //' > testmake.mak << 'EOF'
+Xall:
+X @echo 'ac_maketemp="$(MAKE)"'
+EOF
+ : GNU make sometimes prints "make[1]: Entering...", which would confuse us.
+ case "`$make -f testmake.mak 2>/dev/null`" in
+ *ac_maketemp=*) make_set_make='#' ;;
+ *) make_set_make="MAKE=$make" ;;
+ esac
+ $rm -f testmake.mak
+ ;;
+esac
+case "$make_set_make" in
+'#') echo "Yup, it does." >&4 ;;
+*) echo "Nope, it doesn't." >&4 ;;
+esac
+
: see what type is used for mode_t
set mode_t modetype int stdio.h sys/types.h
eval $typedef
@@ -7656,8 +8656,18 @@ echo " "
case "$randbits" in
'')
echo "Checking to see how many bits your rand function produces..." >&4
- $cat >try.c <<'EOCP'
+ $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;
@@ -7671,9 +8681,10 @@ main()
for (i = 0; max; i++)
max /= 2;
printf("%d\n",i);
+ fflush(stdout);
}
EOCP
- if $cc try.c -o try >/dev/null 2>&1 ; then
+ if $cc $ccflags $ldflags -o try try.c $libs >/dev/null 2>&1 ; then
dflt=`try`
else
dflt='?'
@@ -7687,7 +8698,7 @@ esac
rp='How many bits does your rand() function produce?'
. ./myread
randbits="$ans"
-$rm -f try.c try
+$rm -f try.c try.o try
: see if ar generates random libraries by itself
echo " "
@@ -7700,14 +8711,14 @@ 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 &&
+ar rc bar$lib_ext bar2.o bar1.o >/dev/null 2>&1
+if $cc $ccflags $ldflags -o foobar foo.o bar$lib_ext $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 &&
+elif ar ts bar$lib_ext >/dev/null 2>&1 &&
+ $cc $ccflags $ldflags -o foobar foo.o bar$lib_ext $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
@@ -7834,11 +8845,10 @@ $cat >fd_set.c <<EOCP
#endif
#ifdef I_SYS_TIME
#include <sys/time.h>
-#else
+#endif
#ifdef I_SYS_SELECT
#include <sys/select.h>
#endif
-#endif
main() {
fd_set fds;
@@ -7929,11 +8939,10 @@ EOM
#endif
#ifdef I_SYS_TIME
#include <sys/time.h>
-#else
+#endif
#ifdef I_SYS_SELECT
#include <sys/select.h>
#endif
-#endif
main()
{
int width;
@@ -7998,13 +9007,59 @@ $cat > signal.c <<'EOP'
#include <sys/types.h>
#include <signal.h>
int main() {
-#ifdef NSIG
-printf("NSIG %d\n", NSIG);
-#else
-#ifdef _NSIG
-printf("NSIG %d\n", _NSIG);
+
+/* 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);
+
EOP
echo $xxx | $tr ' ' '\012' | $sort | $uniq | $awk '
{
@@ -8051,7 +9106,7 @@ EOP
$cat >signal_cmd <<EOS
$startsh
$test -s signal.lst && exit 0
-if $cc $ccflags signal.c -o signal $ldflags >/dev/null 2>&1; then
+if $cc $ccflags $ldflags signal.c -o signal >/dev/null 2>&1; then
./signal | $sort -n +1 | $uniq | $awk -f signal.awk >signal.lst
else
echo "(I can't seem be able to compile the test program -- Guessing)"
@@ -8063,7 +9118,7 @@ else
0) set HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM;;
esac
echo \$@ | $tr ' ' '\012' | \
- $awk '{ printf $1; printf " %d\n", ++s; }' >signal.lst
+ $awk '{ printf \$1; printf " %d\n", ++s; }' >signal.lst
fi
$rm -f signal.c signal signal.o
EOS
@@ -8132,25 +9187,36 @@ main()
printf("int\n");
else
printf("long\n");
+ fflush(stdout);
+ exit(0);
}
EOM
echo " "
-if $cc $ccflags $ldflags -o ssize ssize.c $libs > /dev/null 2>&1 ; then
- ssizetype=`./ssize`
+# If $libs contains -lsfio, and sfio is mis-configured, then it
+# sometimes (apparently) runs and exits with a 0 status, but with no
+# output!. Thus we check with test -s whether we actually got any
+# output. I think it has to do with sfio's use of _exit vs. exit,
+# but I don't know for sure. --Andy Dougherty 1/27/97.
+if $cc $optimize $ccflags $ldflags -o ssize ssize.c $libs > /dev/null 2>&1 &&
+ ./ssize > ssize.out 2>/dev/null && test -s ssize.out ; then
+ ssizetype=`$cat ssize.out`
echo "I'll be using $ssizetype for functions returning a byte count." >&4
else
- echo "(I can't compile the test program--please enlighten me!)"
- $cat <<EOM
+ $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 int and long.
+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.[co]
+$rm -f ssize ssize.[co] ssize.out
: see what type of char stdio uses.
echo " "
@@ -8296,30 +9362,6 @@ eval $inhdr
set math.h i_math
eval $inhdr
-: 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
-
: see if ndbm.h is available
set ndbm.h t_ndbm
eval $inhdr
@@ -8658,6 +9700,10 @@ eval $setvar
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
@@ -8670,14 +9716,18 @@ eval $inhdr
set sys/un.h i_sysun
eval $inhdr
-: see if this is a unistd.h system
-set unistd.h i_unistd
+: 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")
@@ -8720,19 +9770,22 @@ known_extensions=''
: some additional extensions into the source tree and expect them
: to be built.
for xxx in * ; do
- if $test -f $xxx/$xxx.xs; then
- known_extensions="$known_extensions $xxx"
+ case "$xxx" in
+ DynaLoader) ;;
+ *) if $test -f $xxx/$xxx.xs; then
+ known_extensions="$known_extensions $xxx"
else
- if $test -d $xxx; then
- cd $xxx
- for yyy in * ; do
- if $test -f $yyy/$yyy.xs; then
- known_extensions="$known_extensions $xxx/$yyy"
- fi
- done
- cd ..
- fi
- fi
+ if $test -d $xxx; then
+ cd $xxx
+ for yyy in * ; do
+ if $test -f $yyy/$yyy.xs; then
+ known_extensions="$known_extensions $xxx/$yyy"
+ fi
+ done
+ cd ..
+ fi
+ fi ;;
+ esac
done
set X $known_extensions
shift
@@ -8763,7 +9816,7 @@ for xxx in $known_extensions ; do
true|define|y) avail_ext="$avail_ext $xxx" ;;
esac
;;
- SAFE) case "$usesafe" in
+ Opcode) case "$useopcode" in
true|define|y) avail_ext="$avail_ext $xxx" ;;
esac
;;
@@ -8912,10 +9965,10 @@ 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".
+# This file was produced by running the Configure script. It holds all
+# the definitions figured out by Configure. Should you modify any of
+# these values, do not forget to propagate your changes by running
+# "Configure -S"; or, equivalently, you may run each .SH file yourself.
#
# Configuration time: $cf_time
@@ -8945,6 +9998,7 @@ awk='$awk'
baserev='$baserev'
bash='$bash'
bin='$bin'
+bincompat3='$bincompat3'
binexp='$binexp'
bison='$bison'
byacc='$byacc'
@@ -8984,8 +10038,11 @@ d_archlib='$d_archlib'
d_attribut='$d_attribut'
d_bcmp='$d_bcmp'
d_bcopy='$d_bcopy'
+d_bincompat3='$d_bincompat3'
d_bsd='$d_bsd'
+d_bsdgetpgrp='$d_bsdgetpgrp'
d_bsdpgrp='$d_bsdpgrp'
+d_bsdsetpgrp='$d_bsdsetpgrp'
d_bzero='$d_bzero'
d_casti32='$d_casti32'
d_castneg='$d_castneg'
@@ -9020,16 +10077,22 @@ d_flock='$d_flock'
d_fork='$d_fork'
d_fpathconf='$d_fpathconf'
d_fsetpos='$d_fsetpos'
+d_ftime='$d_ftime'
d_getgrps='$d_getgrps'
+d_setgrps='$d_setgrps'
d_gethent='$d_gethent'
d_gethname='$d_gethname'
d_getlogin='$d_getlogin'
+d_getpgid='$d_getpgid'
d_getpgrp2='$d_getpgrp2'
d_getpgrp='$d_getpgrp'
d_getppid='$d_getppid'
d_getprior='$d_getprior'
+d_gettimeod='$d_gettimeod'
+d_gnulibc='$d_gnulibc'
d_htonl='$d_htonl'
d_index='$d_index'
+d_inetaton='$d_inetaton'
d_isascii='$d_isascii'
d_killpg='$d_killpg'
d_link='$d_link'
@@ -9075,6 +10138,7 @@ d_rewinddir='$d_rewinddir'
d_rmdir='$d_rmdir'
d_safebcpy='$d_safebcpy'
d_safemcpy='$d_safemcpy'
+d_sanemcmp='$d_sanemcmp'
d_seekdir='$d_seekdir'
d_select='$d_select'
d_sem='$d_sem'
@@ -9096,18 +10160,15 @@ d_setreuid='$d_setreuid'
d_setrgid='$d_setrgid'
d_setruid='$d_setruid'
d_setsid='$d_setsid'
+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_shrplib='$d_shrplib'
d_sigaction='$d_sigaction'
-d_sigintrp='$d_sigintrp'
d_sigsetjmp='$d_sigsetjmp'
-d_sigvec='$d_sigvec'
-d_sigvectr='$d_sigvectr'
d_socket='$d_socket'
d_sockpair='$d_sockpair'
d_statblks='$d_statblks'
@@ -9120,6 +10181,9 @@ 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'
@@ -9178,6 +10242,7 @@ glibpth='$glibpth'
grep='$grep'
groupcat='$groupcat'
groupstype='$groupstype'
+gzip='$gzip'
h_fcntl='$h_fcntl'
h_sysfile='$h_sysfile'
hint='$hint'
@@ -9203,6 +10268,7 @@ 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'
@@ -9215,6 +10281,7 @@ 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'
@@ -9223,11 +10290,13 @@ 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'
@@ -9251,6 +10320,7 @@ ldflags='$ldflags'
less='$less'
lib_ext='$lib_ext'
libc='$libc'
+libperl='$libperl'
libpth='$libpth'
libs='$libs'
libswanted='$libswanted'
@@ -9261,6 +10331,7 @@ ln='$ln'
lns='$lns'
locincpth='$locincpth'
loclibpth='$loclibpth'
+longsize='$longsize'
lp='$lp'
lpr='$lpr'
ls='$ls'
@@ -9268,6 +10339,7 @@ lseektype='$lseektype'
mail='$mail'
mailx='$mailx'
make='$make'
+make_set_make='$make_set_make'
mallocobj='$mallocobj'
mallocsrc='$mallocsrc'
malloctype='$malloctype'
@@ -9334,7 +10406,8 @@ sh='$sh'
shar='$shar'
sharpbang='$sharpbang'
shmattype='$shmattype'
-shrpdir='$shrpdir'
+shortsize='$shortsize'
+shrpenv='$shrpenv'
shsharp='$shsharp'
sig_name='$sig_name'
sig_num='$sig_num'
@@ -9382,8 +10455,11 @@ uniq='$uniq'
usedl='$usedl'
usemymalloc='$usemymalloc'
usenm='$usenm'
+useopcode='$useopcode'
+useperlio='$useperlio'
useposix='$useposix'
-usesafe='$usesafe'
+usesfio='$usesfio'
+useshrplib='$useshrplib'
usevfork='$usevfork'
usrinc='$usrinc'
uuname='$uuname'
@@ -9391,6 +10467,7 @@ vi='$vi'
voidflags='$voidflags'
xlibpth='$xlibpth'
zcat='$zcat'
+zip='$zip'
EOT
: add special variables
diff --git a/gnu/usr.bin/perl/EXTERN.h b/gnu/usr.bin/perl/EXTERN.h
index dedd37958c1..228ed524065 100644
--- a/gnu/usr.bin/perl/EXTERN.h
+++ b/gnu/usr.bin/perl/EXTERN.h
@@ -1,6 +1,6 @@
/* EXTERN.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -15,12 +15,32 @@
*/
#undef EXT
#undef dEXT
+#undef EXTCONST
+#undef dEXTCONST
#if defined(VMS) && !defined(__GNUC__)
# define EXT globalref
# define dEXT globaldef {"$GLOBAL_RW_VARS"} noshare
+# define EXTCONST globalref
+# define dEXTCONST globaldef {"$GLOBAL_RO_VARS"} readonly
#else
-# define EXT extern
-# define dEXT
+# if (defined(_MSC_VER) && defined(_WIN32)) || (defined(__BORLANDC__) && defined(__WIN32__))
+# 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
diff --git a/gnu/usr.bin/perl/INSTALL b/gnu/usr.bin/perl/INSTALL
index 3274ddbb7e7..488a1ce870a 100644
--- a/gnu/usr.bin/perl/INSTALL
+++ b/gnu/usr.bin/perl/INSTALL
@@ -4,7 +4,7 @@ Install - Build and Installation guide for perl5.
=head1 SYNOPSIS
-The basic steps to build and install perl5 are:
+The basic steps to build and install perl5 on a Unix system are:
rm -f config.sh
sh Configure
@@ -12,43 +12,98 @@ The basic steps to build and install perl5 are:
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. Special notes specific to this release are identified
-by B<NOTE>.
+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 Space Requirements
-=head1 BUILDING PERL5
+The complete perl5 source tree takes up about 7 MB of disk space. The
+complete tree after completing make takes roughly 15 MB, though the
+actual total is likely to be quite system-dependent. The installation
+directories need something on the order of 7 MB, though again that
+value is system-dependent.
-=head1 Start with a Fresh Distribution.
+=head1 Start with a Fresh Distribution
If you have built perl before, you should clean out the build directory
with the command
make realclean
-
+
The results of a Configure run are stored in the config.sh file. 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 I<not>
+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
-Then run Configure.
+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 or i586. 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.
-=head1 Run Configure.
+=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 C<RETURN>. The default
-is almost always ok.
+you about. To accept the default, just press RETURN. The default
+is almost always ok. 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
-F<*.SH> files and offer to run B<make depend>.
+*.SH files and offer to run make depend.
-Configure supports a number of useful options. Run B<Configure -h>
-to get a listing. To compile with gcc, for example, you can run
+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
@@ -58,11 +113,6 @@ 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>.
-If you are willing to accept all the defaults, and you want terse
-output, you can run
-
- sh Configure -des
-
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
@@ -74,39 +124,80 @@ e.g.
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
-/usr/local/lib/perl5/.
+/opt/perl/lib/perl5/.
-By default, Configure will compile perl to use dynamic loading, if
+NOTE: You must not specify an installation directory that is below
+your perl source directory. If you do, installperl will attempt
+infinite recursion.
+
+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 by
-using the Configure command line option -Uusedl.
+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 command, e.g.
+
+ CC=gcc ./configure
+
+The configure script emulates a few of the more common configure
+options. Try
+
+ ./configure --help
+
+for a listing.
+
+Cross compiling is not supported.
+
+For systems that do not distinguish the files "Configure" and
+"configure", Perl includes a copy of configure named
+configure.gnu.
=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.)
-DynaLoader, Fcntl and FileHandle 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 Safe extension is always
-built by default, but you can skip it by setting the Configure variable
-usesafe=false either in a hint file for from the command line.
+DynaLoader, Fcntl, and IO 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:
DB_File i_db
- DynaLoader (Must always be included)
+ DynaLoader (Must always be included as a static extension)
Fcntl (Always included by default)
- FileHandle (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)
- Safe usesafe
+ Opcode useopcode
Socket d_socket
Thus to skip the NDBM_File extension, you can use
@@ -117,67 +208,56 @@ 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.
+the extensions you want.
+
+Note: The DB_File module will only work with version 1.x of
+Berkeley DB. Once Berkeley DB version 2 is released, DB_File will be
+upgraded to work with it. Configure will automatically detect this
+for you and refuse to try to build DB_File with version 2.
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 GNU-style configure
-
-If you prefer the GNU-style B<configure> command line interface, you can
-use the supplied B<configure> command, e.g.
-
- CC=gcc ./configure
-
-The B<configure> script emulates several of the more common configure
-options. Try
-
- ./configure --help
-
-for a listing.
-
-Cross compiling is currently not supported.
-
=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 B<not> included with perl. See the library documentation for
+are not included with perl. See the library documentation for
how to obtain the libraries.
-I<Note:> If your database header (.h) files are not in a
+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 B<-I/your/directory> option when prompted by
+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 B<-L/your/directory> option when prompted by
+include the appropriate -L/your/directory option when prompted by
Configure. See the examples below.
=head2 Examples
=over 4
-=item gdbm in /usr/local.
+=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 F<gdbm.h>
-installed in F</usr/local/include/gdbm.h> and F<libgdbm.a> installed in
-F</usr/local/lib/libgdbm.a>. Configure should figure all 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 C<-I/usr/local/include>.
+your C compiler, you should include -I/usr/local/include.
When Configure prompts you for linker flags, you should include
-C<-L/usr/local/lib>.
+-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
-C<-L/usr/local/lib>.
+-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
@@ -194,11 +274,11 @@ This should actually work if you have gdbm installed in any of
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 F</usr/you/include/gdbm.h> and F</usr/you/lib/libgdbm.a>. You
-still have to add B<-I/usr/you/include> to cc flags, but you have to take
-an extra step to help Configure find F<libgdbm.a>. Specifically, when
+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
-F</usr/you/lib> to the list.
+/usr/you/lib to the list.
It is possible to specify this from the command line too (all on one
line):
@@ -207,13 +287,13 @@ line):
-Dlocincpth="/usr/you/include" \
-Dloclibpth="/usr/you/lib"
-C<locincpth> is a space-separated list of include directories to search.
-Configure will automatically add the appropriate B<-I> directives.
+locincpth is a space-separated list of include directories to search.
+Configure will automatically add the appropriate -I directives.
-C<loclibpth> is a space-separated list of library directories to search.
-Configure will automatically add the appropriate B<-L> directives. If
-you have some libraries under F</usr/local/> and others under
-F</usr/you>, then you have to include both, namely
+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" \
@@ -221,17 +301,22 @@ F</usr/you>, then you have to include both, namely
=back
-=head2 Installation Directories.
+=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 uses the following directories for
library files (archname is a string like sun4-sunos, determined
by Configure)
- /usr/local/lib/perl5/archname/5.002
+ /usr/local/lib/perl5/archname/5.004
/usr/local/lib/perl5/
/usr/local/lib/perl5/site_perl/archname
/usr/local/lib/perl5/site_perl
@@ -243,17 +328,29 @@ and the following directories for manual pages:
(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
+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 B<less> program.
+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 are
+directory structure is simplified. For example, if you Configure with
+-Dprefix=/opt/perl, then the defaults are
- /opt/perl/lib/archname/5.002
+ /opt/perl/lib/archname/5.004
/opt/perl/lib
/opt/perl/lib/site_perl/archname
/opt/perl/lib/site_perl
@@ -269,14 +366,14 @@ intended to be used for installing local or site-wide extensions. Perl
will automatically look in these directories. Previously, most sites
just put their local extensions in with the standard distribution.
-In order to support using things like #!/usr/local/bin/perl5.002 after
+In order to support using things like #!/usr/local/bin/perl5.004 after
a later version is released, architecture-dependent libraries are
stored in a version-specific directory, such as
-/usr/local/lib/perl5/archname/5.002/. In 5.000 and 5.001, these files
-were just stored in /usr/local/lib/perl5/archname/. If you will not be
-using 5.001 binaries, you can delete the standard extensions from the
-/usr/local/lib/perl5/archname/ directory. Locally-added extensions can
-be moved to the site_perl and site_perl/archname directories.
+/usr/local/lib/perl5/archname/5.004/. In Perl 5.000 and 5.001, these
+files were just stored in /usr/local/lib/perl5/archname/. If you will
+not be using 5.001 binaries, you can delete the standard extensions from
+the /usr/local/lib/perl5/archname/ directory. Locally-added extensions
+can be moved to the site_perl and site_perl/archname directories.
Again, these are just the defaults, and can be changed as you run
Configure.
@@ -287,19 +384,17 @@ 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 B<depot> to manage software
+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 C<-Dinstallprefix=/foo> to simplify this.
+an option -Dinstallprefix=/foo to simplify this.
-Suppose you want to install perl under the F</tmp/perl5> directory.
-You can edit F<config.sh> and change all the install* variables to
-point to F</tmp/perl5> instead of F</usr/local/wherever>. You could
-also set them all from the Configure command line. Or, you can
-automate this process by placing the following lines in a file
-F<config.over> B<before> you run Configure (replace /tmp/perl5 by a
-directory of your choice):
+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
@@ -312,7 +407,6 @@ directory of your choice):
installscript=`echo $installscript | sed "s!$prefix!$installprefix!"`
installsitelib=`echo $installsitelib | sed "s!$prefix!$installprefix!"`
installsitearch=`echo $installsitearch | sed "s!$prefix!$installprefix!"`
- shrpdir=`echo $shrpdir | sed "s!$prefix!$installprefix!"`
Then, you can Configure and install in the usual way:
@@ -334,11 +428,334 @@ installed on multiple systems. Here's one way to do that:
make test
make install
cd /tmp/perl5
+ # Edit lib/<archname>/<version>/Config.pm to change all the
+ # install* variables back to reflect where everything will
+ # really be installed.
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 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 Binary Compatibility With Earlier Versions of Perl 5
+
+If you have dynamically loaded extensions that you built under
+perl 5.003 and that you wish to continue to use with perl 5.004, then you
+need to ensure that 5.004 remains binary compatible with 5.003.
+
+Starting with Perl 5.003, all functions in the Perl C source code have
+been protected by default by the prefix Perl_ (or perl_) so that you
+may link with third-party libraries without fear of namespace
+collisions. This change broke compatibility with version 5.002, so
+installing 5.003 or 5.004 over 5.002 or earlier will force you to
+re-build and install all of your dynamically loadable extensions.
+(The standard extensions supplied with Perl are handled
+automatically). You can turn off this namespace protection by adding
+-DNO_EMBED to your ccflags variable in config.sh.
+
+Perl 5.003's namespace protection was incomplete, but this has
+been fixed in 5.004. However, some sites may need to maintain
+complete binary compatibility with Perl 5.003. If you are building
+Perl for such a site, then when Configure asks if you want binary
+compatibility, answer "y".
+
+On the other hand, if you are embedding perl into another application
+and want the maximum namespace protection, then you probably ought to
+answer "n" when Configure asks if you want binary compatibility, or
+disable it from the Configure command line with
+
+ sh Configure -Ud_bincompat3
+
+The default answer of "y" to maintain binary compatibility is probably
+appropriate for almost everyone.
+
+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.
+
+=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, and work is in progress to make
+it more easily buildable by adding Configure support.
+
+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 (or whatever is appropriate for
+your platform.)
+
+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 is probably a bit slower but also a bit more frugal.
+
+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 experimental
+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 cflags config.sh variable
+to change its behavior in potentially useful ways. You can find out
+more about these flags by reading the malloc.c source.
+In a future version of perl, these might be enabled by default.
+
+=over 4
+
+=item -DPERL_EMERGENCY_SBRK
+
+If PERL_EMERGENCY_SBRK is defined, running out of memory need not be a
+fatal error: a memory pool can allocated by assigning to the special
+variable $^M. See perlvar(1) for more details.
+
+=item -DPACK_MALLOC
+
+If PACK_MALLOC is defined, malloc.c uses a slightly different
+algorithm for small allocations (up to 64 bytes long). Such small
+allocations are quite common in typical Perl scripts.
+
+The expected memory savings (with 8-byte alignment in $alignbytes) is
+about 20% for typical Perl usage. The expected slowdown due to the
+additional malloc overhead is in fractions of a percent. (It is hard
+to measure because of the effect of the saved memory on speed).
+
+=item -DTWO_POT_OPTIMIZE
+
+If TWO_POT_OPTIMIZE is defined, malloc.c uses a slightly different
+algorithm for large allocations that are close to a power of two
+(starting with 16K). Such allocations are typical for big hashes and
+special-purpose scripts, especially image processing. If you will be
+manipulating very large blocks with sizes close to powers of two, it
+might be wise to define this macro.
+
+The expected saving of memory is 0-100% (100% in applications which
+require most memory in such 2**n chunks). The expected slowdown is
+negligible.
+
+=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 you 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:
+
+ sh Configure -Dccflags='-Drand=random -Dsrand=srandom'
+
+or by adding -Drand=random and -Dsrand=srandom to your ccflags
+at the appropriate Configure prompt. (Note: Although this worked for
+me, it might not work for you if your system's header files give
+different prototypes for rand() and random() or srand() and srandom().)
+
+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
@@ -350,15 +767,15 @@ 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 &
-flags) you can type '&-d' at the next Configure prompt and Configure
+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.
+=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
@@ -366,7 +783,7 @@ 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 F<hints/solaris_2.sh> for an
+file for further information. See hints/solaris_2.sh for an
extensive example.
=item *** WHOA THERE!!! ***
@@ -398,24 +815,31 @@ Now, Configure will find your gdbm library and will issue a message:
The previous value for $i_gdbm on this machine was "undef"!
Keep the previous value? [y]
-In this case, you do I<not> want to keep the previous value, so you
-should answer 'n'. (You'll also have to manuually add GDBM_File to
+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 I<not> re-use your old config.sh. Simply remove it or
+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 B<cc> to
-B<gcc>, you should almost always remove your old config.sh.
+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
-=item Propagating your changes
+ sh Configure -S
-If you later make any changes to F<config.sh>, you should propagate
-them to all the .SH files by running B<sh Configure -S>.
+You will then have to rebuild by running
+
+ make depend
+ make
=item config.over
@@ -423,48 +847,64 @@ 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
-changing the installation directory for an example.
+L<"Changing the installation directory"> for an example.
=item config.h
-Many of the system dependencies are contained in F<config.h>.
-F<Configure> builds F<config.h> by running the F<config_h.SH> script.
-The values for the variables are taken from F<config.sh>.
+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 F<config.h> directly. Beware,
-though, that the next time you run B<Configure>, your changes will be
+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 F<cflags.SH>. For instance, to turn off the
-optimizer on F<toke.c>, find the line in the switch structure for
-F<toke.c> and put the command C<optimize='-g'> before the C<;;>. You
-can also edit F<cflags> directly, but beware that your changes will be
-lost the next time you run B<Configure>.
+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 change the C flags for all the files, edit F<config.sh>
-and change either C<$ccflags> or C<$optimize>,
-and then re-run B<sh Configure -S ; make depend>.
+To change the C flags for all the files, edit config.sh
+and change either $ccflags or $optimize,
+and then re-run
-=item No sh.
+ sh Configure -S
+ make depend
+
+=item No sh
If you don't have sh, you'll have to copy the sample file 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 F<makefile>. The only difference between
-F<Makefile> and F<makefile> is the dependencies at the bottom of
-F<makefile>. If you have to make any changes, you should edit
-F<makefile>, not F<Makefile> since the Unix B<make> command reads
-F<makefile> first.
+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.
@@ -474,138 +914,322 @@ explicitly above.
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 *
+=item hints
If you used a hint file, try reading the comments in the hint file
for further tips and information.
-=item *
+=item extensions
-If you can't compile successfully, try adding a C<-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. If that has no effect, try turning off
-optimization. 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.
-
-=item *
-
-Some compilers will not compile or optimize the larger files without
-some extra switches to use larger jump offsets or allocate larger
-internal tables. You can customize the switches for each file in
-F<cflags>. It's okay to insert rules for specific files into
-F<makefile> since a default rule only takes effect in the absence of a
-specific rule.
-
-=item *
-
-If you can successfully build F<miniperl>, but the process crashes
+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 *
+=item locale
-Some additional things that have been reported for either perl4 or perl5:
+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.
-Genix may need to use libc rather than libc_s, or #undef VARARGS.
+=item malloc duplicates
-NCR Tower 32 (OS 2.01.01) may need -W2,-Sl,2000 and #undef MKDIR.
+If you get duplicates upon linking for malloc et al, add -DHIDEMYMALLOC
+or -DEMBEDMYMALLOC to your ccflags variable in config.sh.
-UTS may need one or more of B<-DCRIPPLED_CC>, B<-K> or B<-g>, and undef LSTAT.
+=item varargs
-If you get syntax errors on '(', try -DCRIPPLED_CC.
+If you get varargs problems with gcc, be sure that gcc is installed
+correctly. 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.
-Machines with half-implemented dbm routines will need to #undef I_ODBM
+=item croak
-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.
+If you get error messages such as the following (the exact line
+numbers will vary in different versions of perl):
-If you get duplicates upon linking for malloc et al, say -DHIDEMYMALLOC.
+ util.c: In function `Perl_croak':
+ util.c:962: number of arguments doesn't match prototype
+ proto.h:45: prototype declaration
-If you get duplicate function definitions (a perl function has the
-same name as another function on your system) try -DEMBED.
+it might well be a symptom of the gcc "varargs problem". See the
+previous L<"varargs"> item.
-If you get varags problems with gcc, be sure that gcc is installed
-correctly. When using gcc, you should probably have i_stdarg='define'
-and i_varags='undef' in config.sh. The problem is usually solved
-by running fixincludes correctly.
+=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<-B/bin/> (for SunOS) or B<-B/usr/ccs/bin> (for Solaris) to your
+-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.
+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. Perl should build
+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 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. You are probably better off
+re-running Configure without using nm extraction (see previous item).
+
+=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 items
+on L<"vsprintf"> and 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 something like
+
+ 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.
+
+=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 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.
+
+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. If it
-doesn't say "All tests successful" then something went wrong. See the
-file F<t/README> in the F<t> subdirectory. Note that you can't run it
-in background if this disables opening of /dev/tty. If B<make test>
-bombs out, just B<cd> to the F<t> directory and run B<TEST> by hand
-to see if it makes any difference.
-If individual tests bomb, you can run them by hand, e.g.,
+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.
+
+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
-B<Note>: one possible reason for errors is that some external programs
+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.
+
+Note: One possible reason for errors is that some external programs
may be broken due to the combination of your environment and the way
-C<make test> exercises them. This may happen for example if you have
-one or more of these environment variables set:
-C<LC_ALL LC_CTYPE LANG>. In certain UNIXes especially the non-English
-locales are known to cause programs to exhibit mysterious errors.
+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
-C<setenv LC_ALL C> or <LC_ALL=C;export LC_ALL>, for C<csh>-style and
-C<Bourne>-style shells, respectively, from the command line and then
-retry C<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:
-C<exec, `backquoted command`, system, open("|...")> or C<open("...|")>.
-All these mean that Perl is trying to run some external program.
-=head1 INSTALLING PERL5
+
+ 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.
=head1 make install
This will put perl into the public directory you specified to
-B<Configure>; by default this is F</usr/local/bin>. It will also try
+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
-page, however. You may need to be root to run B<make install>. If you
+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.
-B<NOTE:> In the 5.002 release, you will see some harmless error
-messages and warnings from pod2man. You may safely ignore them. (Yes,
-they should be fixed, but they didn't seem important enough to warrant
-holding up the entire 5.002 release.)
-
If you want to see exactly what will happen without installing
anything, you can run
./perl installperl -n
./perl installman -n
-B<make install> will install the following:
+make install will install the following:
perl,
perl5.nnn where nnn is the current release number. This
@@ -618,12 +1242,16 @@ B<make install> will install the following:
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, and to other useful formats.
- pod2man
+ 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/.
@@ -640,104 +1268,177 @@ $sitearch listed in config.sh. Usually, these are something like
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 even if the Perl source is no longer available.
-
-The libperl.a library is only needed for building new
-extensions and linking them statically into a new perl executable.
-If you will not be doing that, then you may safely delete
-$archlib/libperl.a after perl is installed.
-
-make install may also offer to install perl in a "standard" location.
-
-Most of the documentation in the pod/ directory is also available
-in HTML and LaTeX format. Type
-
- cd pod; make html; cd ..
-
-to generate the html versions, and
-
- cd pod; make tex; cd ..
-
-to generate the LaTeX versions.
-
-=head1 Coexistence with earlier versions of perl5.
-
-You can safely install the current version of perl5 and still run
-scripts under the old binaries. Instead of starting your script with
-#!/usr/local/bin/perl, just start it with #!/usr/local/bin/perl5.001
-(or whatever version you want to run.)
-
-The architecture-dependent files are stored in a version-specific
-directory (such as F</usr/local/lib/perl5/sun4-sunos/5.002>) so that
-they are still accessible. I<Note:> perl5.000 and perl5.001 did not
-put their architecture-dependent libraries in a version-specific
-directory. They are simply in F</usr/local/lib/perl5/$archname>. If
-you will not be using 5.000 or 5.001, you may safely remove those
-files.
-
-The standard library files in F</usr/local/lib/perl5>
-should be useable by all versions of perl5.
+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
+
+You can safely install the current version of perl5 and still run scripts
+under the old binaries for versions 5.003 and later ONLY. Instead of
+starting your script with #!/usr/local/bin/perl, just start it with
+#!/usr/local/bin/perl5.003 (or whatever version you want to run.)
+If you want to retain a version of Perl 5 prior to 5.003, you'll
+need to install the current version in a separate directory tree,
+since some of the architecture-independent library files have changed
+in incompatible ways.
+
+The old architecture-dependent files are stored in a version-specific
+directory (such as /usr/local/lib/perl5/sun4-sunos/5.003) so that they
+will still be accessible even after a later version is installed.
+(Note: Perl 5.000 and 5.001 did not put their architecture-dependent
+libraries in a version-specific directory. They are simply in
+/usr/local/lib/perl5/$archname. If you will not be using 5.000 or
+5.001, you may safely remove those files.)
+
+In general, the standard library files in /usr/local/lib/perl5 should
+be usable by all versions of perl5. However, the diagnostics.pm module
+uses the /usr/local/lib/perl5/pod/perldiag.pod documentation file, so
+the C<use diagnostics;> pragma and the splain script will only identify
+and explain any warnings or errors that the most recently-installed
+version of perl can generate.
Most extensions will probably not need to be recompiled to use with a newer
version of perl. If you do run into problems, and you want to continue
to use the old version of perl along with your extension, simply move
those extension files to the appropriate version directory, such as
-F</usr/local/lib/perl/archname/5.002>. Then perl5.002 will find your
-files in the 5.002 directory, and newer versions of perl will find your
+/usr/local/lib/perl/archname/5.003. Then Perl 5.003 will find your
+files in the 5.003 directory, and newer versions of perl will find your
newer extension in the site_perl directory.
-Some users may prefer to keep all versions of perl in completely
+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.002
+ sh Configure -Dprefix=/opt/perl5.004
-and adding /opt/perl5.002/bin to the shell PATH variable. Such users
+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.
-B<NOTE>: Starting with 5.002_01, all functions in the perl C source
-code are protected by default by the prefix Perl_ (or perl_) so that
-you may link with third-party libraries without fear of namespace
-collisons. This breaks compatability with the initially released
-version of 5.002, so once you install 5.002_01 (or higher) you will
-need to re-build and install all of your dynamically loadable
-extensions. (The standard extensions supplied with Perl are handled
-automatically). You can turn off this namespace protection by adding
--DNO_EMBED to your ccflags variable in config.sh. This is a one-time
-change. In the future, we certainly hope that most extensions won't
-need to be recompiled for use with a newer version of perl.
+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.
=head1 Coexistence with perl4
You can safely install perl5 even if you want to keep perl4 around.
-By default, the perl5 libraries go into F</usr/local/lib/perl5/>, so
-they don't override the perl4 libraries in F</usr/local/lib/perl/>.
+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
-F<perl4.036>. That will not be touched by the perl5 installation
+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 C<#!> line at the top of them by C<#!/usr/local/bin/perl4.036>
+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 architectural library directory
+you specified to Configure; by default this is
+/usr/local/lib/perl5/ARCH/VERSION, where ARCH is your architecture
+(such as sun4-solaris) and VERSION is the version of perl you are
+building (for example, 5.004).
+
+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 and installed before you can use it.
+
+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 B<perldoc> script. This
+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
-Andy Dougherty <doughera@lafcol.lafayette.edu>, borrowing I<very> heavily
-from the original README by Larry Wall.
+Original author: Andy Dougherty doughera@lafcol.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 or questions, please see L<"Reporting Problems">
+above.
=head1 LAST MODIFIED
-19 March 1996
+$Id: INSTALL,v 1.28 1997/10/10 16:50:59 doughera Released $
diff --git a/gnu/usr.bin/perl/INTERN.h b/gnu/usr.bin/perl/INTERN.h
index d89d2e68a44..ba71c2f7adf 100644
--- a/gnu/usr.bin/perl/INTERN.h
+++ b/gnu/usr.bin/perl/INTERN.h
@@ -1,6 +1,6 @@
/* INTERN.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -15,12 +15,18 @@
*/
#undef EXT
#undef dEXT
+#undef EXTCONST
+#undef dEXTCONST
#if defined(VMS) && !defined(__GNUC__)
# 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
# define EXT
# define dEXT
+# define EXTCONST const
+# define dEXTCONST const
#endif
#undef INIT
diff --git a/gnu/usr.bin/perl/MANIFEST b/gnu/usr.bin/perl/MANIFEST
index e493f4e7c76..26a54094aff 100644
--- a/gnu/usr.bin/perl/MANIFEST
+++ b/gnu/usr.bin/perl/MANIFEST
@@ -1,26 +1,46 @@
Artistic The "Artistic License"
-Changes Differences from previous versions.
-Changes.Conf Recent changes in the Configure & build process
+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
configure Crude emulation of GNU configure
+configure.gnu Copy of configure (for case-insensitive systems)
Configure Portability tool
Copying The GNU General Public License
EXTERN.h Included before foreign .h files
-INSTALL Detailed installation instructions.
+INSTALL Detailed installation instructions
INTERN.h Included before domestic .h files
MANIFEST This list of files
Makefile.SH A script that generates Makefile
+Porting/Glossary Glossary of config.sh variables
+Porting/makerel Release making utility
+Porting/patchls Flexible patch file listing utility
+Porting/pumpkin.pod Guidelines and hints for Perl maintainers
README The Instructions
-README.vms Notes about VMS
+README.amiga Notes about AmigaOS port
+README.cygwin32 Notes about Cygwin32 port
+README.os2 Notes about OS/2 port
+README.plan9 Notes about Plan9 port
+README.qnx Notes about QNX port
+README.vms Notes about VMS port
+README.win32 Notes about Win32 port
Todo The Wishlist
XSUB.h Include file for extension subroutines
av.c Array value code
av.h Array value header
cflags.SH A script that emits C compilation flags per file
+compat3.sym List of symbols for binary-compatibility with 5.003
config_H Sample config.h
config_h.SH Produces config.h
configpm Produces lib/Config.pm
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
doio.c I/O operations
doop.c Support code for various operations
@@ -28,6 +48,24 @@ dosish.h Some defines for MS/DOSish machines
dump.c Debugging output
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/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/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/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
@@ -82,27 +120,36 @@ ext/DynaLoader/DynaLoader.pm 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_next.xs Next implementation
ext/DynaLoader/dl_none.xs Stub implementation
-ext/DynaLoader/dl_os2.xs OS/2 implementation
ext/DynaLoader/dl_vms.xs VMS implementation
ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files
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/FileHandle/FileHandle.pm FileHandle extension Perl module
-ext/FileHandle/FileHandle.xs FileHandle extension external subroutines
-ext/FileHandle/Makefile.PL FileHandle 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/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
@@ -110,14 +157,22 @@ 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/next_3.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
@@ -142,20 +197,15 @@ 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/readme.ps 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/Safe/Makefile.PL Safe extension makefile writer
-ext/Safe/Safe.pm Safe extension Perl module
-ext/Safe/Safe.xs Safe extension external subroutines
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/util/extliblist Used by extension Makefile.PL to make lib lists
ext/util/make_ext Used by Makefile to execute extension Makefiles
ext/util/mkbootstrap Turns ext/*/*_BS into bootstrap info
form.h Public declarations for the above
@@ -178,17 +228,20 @@ 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/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.sh Hints for named architecture
+hints/aux_3.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/dnix.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
@@ -202,10 +255,12 @@ 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_2.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
@@ -213,11 +268,15 @@ 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/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
@@ -232,61 +291,89 @@ 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
-installman Perl script to install man pages for pods.
+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
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 A module to split up autoload functions
-lib/Benchmark.pm A module to time pieces of code and such
+lib/AutoSplit.pm Split up autoload functions
+lib/Benchmark.pm Measure execution time
+lib/Bundle/CPAN.pm The CPAN bundle
+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/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/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_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/testlib.pm Fixes up @INC to use just-built extension
+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/File/Basename.pm A module to emulate the basename program
+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 A module to do things like `mkdir -p' and `rm -r'
+lib/File/Path.pm Do things like `mkdir -p' and `rm -r'
+lib/File/stat.pm By-name interface to Perl's builtin stat
lib/FileCache.pm Keep more files open than the system permits
-lib/Getopt/Long.pm A module to fetch command options (GetOptions)
-lib/Getopt/Std.pm A module to fetch command options (getopt, getopts)
+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/Net/Ping.pm Ping methods
+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 A module to do binary search on dictionaries
-lib/SelectSaver.pm A module to enforce proper select scoping
-lib/SelfLoader.pm A module to load functions only on demand.
-lib/Shell.pm A module to make AUTOLOADed system() calls
+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
@@ -300,18 +387,28 @@ 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/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.inter A chat2 with interaction
-lib/chat2.pl Randal's famous expect-ish routines
+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
@@ -321,7 +418,7 @@ lib/fastcwd.pl a faster but more dangerous getcwd
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
+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
@@ -330,16 +427,16 @@ 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
-lib/open3.pl Open a three-ended pipe
-lib/overload.pm Module for overloading perl operators.
+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/splain Standalone program to print verbose diagnostics.
lib/stat.pl Perl library supporting stat function
lib/strict.pm For "use strict"
lib/subs.pm Declare overriding subs
@@ -359,50 +456,117 @@ minimod.pl Writes lib/ExtUtils/Miniperl.pm
miniperlmain.c Basic perl w/o dynamic loading or extensions
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
op.c Opcode syntax tree code
op.h Opcode syntax tree header
opcode.h Automatically generated opcode header
opcode.pl Opcode header generatore
-os2/diff.configure Patches to Configure
-os2/diff.db_file patch to DB_File
+os2/Changes Changelog for OS/2 port
os2/Makefile.SHs Shared library generation for OS/2
-os2/POSIX.mkfifo POSIX.xs patch.
-os2/README OS/2 port info.
-os2/README.old previous OS/2 port info, partially relevant.
-os2/notes Notes for perl maintainer
+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/os2ish.h Header for OS/2
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.
+perl_exp.SH Creates list of exported symbols for AIX
+perlio.c C code for PerlIO abstraction
+perlio.h Interface to PerlIO abstraction
+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
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/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/perlipc.pod IPC info
-pod/perllol.pod How to use lists of lists.
-pod/perlmod.pod Module info
+pod/perllocale.pod Locale support info
+pod/perllol.pod How to use lists of lists
+pod/perlmod.pod Module mechanism info
+pod/perlmodlib.pod Module policy info
pod/perlobj.pod Object info
pod/perlop.pod Operator info
-pod/perlovl.pod Overloading info
pod/perlpod.pod Pod info
pod/perlre.pod Regular expression info
pod/perlref.pod References info
@@ -413,6 +577,7 @@ 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
@@ -420,8 +585,9 @@ 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/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
@@ -430,6 +596,8 @@ pp_ctl.c Push/Pop code for control flow
pp_hot.c Push/Pop code for heavily used opcodes
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
regexec.c Regular expression evaluator
@@ -453,13 +621,17 @@ 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/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
@@ -467,32 +639,73 @@ t/io/fs.t See if directory manipulations work
t/io/inplace.t See if inplace editing works
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/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/english.t See if English works
+t/lib/env.t See if Env 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/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/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/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/posix.t See if POSIX works
-t/lib/safe.t See if Safe 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/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/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/delete.t See if delete works
t/op/do.t See if subroutines work
-t/op/each.t See if associative iterators 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
@@ -501,30 +714,34 @@ 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/groups.t See if $( works
+t/op/gv.t See if typeglobs 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/oct.t See if oct and hex work
t/op/ord.t See if ord works
-t/op/overload.t See if operator overload works
t/op/pack.t See if pack and unpack work
t/op/pat.t See if esoteric patterns work
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 Input file for op.regexp
+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/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/split.t See if split works
@@ -533,34 +750,57 @@ 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/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/write.t See if write works
-t/re_tests Regular expressions for regexp.t
+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
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 Public declarations for the above
-utils/Makefile Extract the utility scripts.
+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/perldoc.PL A simple tool to find & display perl's documentation
utils/pl2pm.PL A pl to pm translator
-vms/Makefile VMS port
+utils/splain.PL Stand-alone version of diagnostics.pm
vms/config.vms default config.h for VMS
vms/descrip.mms 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/fndvers.com parse Perl version from patchlevel.h
+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/fndvers.com parse Perl version from patchlevel.h
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
@@ -577,22 +817,57 @@ 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/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/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.vc Win32 base line config.sh (Visual C++ build)
+win32/config_H.bc Win32 config header (Borland C++ 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/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/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/win32io.c Win32 port
+win32/win32io.h Win32 port
+win32/win32iop.h Win32 port
+win32/win32sck.c Win32 port
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.man Manual page for awk to perl translator
+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/handy.h Handy definitions
-x2p/hash.c Associative arrays again
+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/s2p.man Manual page for sed to perl translator
x2p/str.c String handling package
x2p/str.h Public declarations for the above
x2p/util.c Utility routines
diff --git a/gnu/usr.bin/perl/Makefile.SH b/gnu/usr.bin/perl/Makefile.SH
index 7eaa4e46dd5..f2a4a9fbc70 100644
--- a/gnu/usr.bin/perl/Makefile.SH
+++ b/gnu/usr.bin/perl/Makefile.SH
@@ -1,3 +1,4 @@
+#! /bin/sh
case $CONFIG in
'')
if test -f config.sh; then TOP=.;
@@ -22,24 +23,42 @@ case "$d_dosuid" in
*) suidperl='';;
esac
-shrpenv=""
-case "$d_shrplib" in
-*define*)
- patchlevel=`egrep '^#define[ ]+PATCHLEVEL' patchlevel.h \
- | awk '{print $3}'`
- case "$patchlevel" in
- *[0-9]) plibsuf=.$so.$patchlevel;;
- *) plibsuf=.$so;;
- esac
- if test "x$plibext" != "x" ; then plibsuf=$plibext d_shrplib=custom ; fi
- case "$shrpdir" in
- /usr/lib) ;;
- "") ;;
- *) shrpenv="env LD_RUN_PATH=$shrpdir";;
- esac
- pldlflags="$cccdlflags";;
-*) plibsuf=$lib_ext
- pldlflags="";;
+linklibperl='$(LIBPERL)'
+shrpldflags='$(LDDLFLAGS)'
+case "$useshrplib" in
+true)
+ 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)/\$@"
+ ;;
+ 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.
@@ -51,30 +70,20 @@ for f in $dynamic_ext; do
done
static_list=' '
-static_ai_list=' '
for f in $static_ext; do
base=`echo "$f" | sed 's/.*\///'`
static_list="$static_list lib/auto/$f/$base\$(LIB_EXT)"
- if test -f ext/$f/AutoInit.c; then
- static_ai_list="$static_ai_list ext/$f/AutoInit.c"
- fi
- if test -f ext/$f/AutoInit.pl; then
- static_ai_list="$static_ai_list ext/$f/AutoInit.pl"
- fi
done
echo "Extracting Makefile (with variable substitutions)"
-$spitshell >Makefile <<'!NO!SUBS!'
+$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 makefile. The only difference
-# is that makefile has the dependencies filled in at the end.
+# Makefile is used to generate $firstmakefile. The only difference
+# is that $firstmakefile has the dependencies filled in at the end.
#
#
-!NO!SUBS!
-
-$spitshell >>Makefile <<!GROK!THIS!
# I now supply perly.c with the kits, so don't remake perly.c without byacc
BYACC = $byacc
CC = $cc
@@ -97,6 +106,7 @@ ranlib = $ranlib
# installman commandline.
bin = $installbin
scriptdir = $scriptdir
+shrpdir = $archlibexp/CORE
privlib = $installprivlib
man1dir = $man1dir
man1ext = $man1ext
@@ -106,16 +116,17 @@ 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
-PLIBSUF = $plibsuf
+LIBPERL = $libperl
+LLIBPERL= $linklibperl
SHRPENV = $shrpenv
dynamic_ext = $dynamic_list
static_ext = $static_list
ext = \$(dynamic_ext) \$(static_ext)
-static_ext_autoinit = $static_ai_list
DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
libs = $libs $cryptlib
@@ -124,8 +135,9 @@ public = perl $suidperl utilities translators
shellflags = $shellflags
-## To use an alternate make, set \$altmake in config.sh.
-MAKE = ${altmake-make}
+# This is set to MAKE=$make if your $make command doesn't
+# do it for you.
+$make_set_make
# These variables will be used in a future version to make
# the make file more portable to non-unix systems.
@@ -142,12 +154,15 @@ ARCHOBJS = $archobjs
.SUFFIXES: .c \$(OBJ_EXT)
+# grrr
+SHELL = $sh
+
!GROK!THIS!
## In the following dollars and backticks do not need the extra backslash.
$spitshell >>Makefile <<'!NO!SUBS!'
-CCCMD = `sh $(shellflags) cflags $(perllib) $@`
+CCCMD = `sh $(shellflags) cflags $(LIBPERL) $@`
private = preplibrary lib/ExtUtils/Miniperl.pm lib/Config.pm
@@ -157,7 +172,7 @@ 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
+ makedir perl.exp writemain
# Files to be built with variable substitution after miniperl is
# available. Dependencies handled manually below (for now).
@@ -171,41 +186,37 @@ 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
+h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h
h = $(h1) $(h2) $(h3) $(h4)
c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c
c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c
-c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c globals.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)
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) globals$(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 perllib=libperl<type>.a
+# 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.
#
-# Eventually some form of 'make-a-perl' script will automate this
-# together with linking a perl executable with any desired
-# static modules.
-perllib = libperl$(PLIBSUF)
+# This mechanism is getting clunky and might not even work any more.
+# EMBEDDING is on by default, and MULTIPLICITY doesn't work.
+#
lintflags = -hbvxac
-# grrr
-SHELL = /bin/sh
-
.c$(OBJ_EXT):
$(CCCMD) $(PLDLFLAGS) $*.c
-all: makefile miniperl $(private) $(plextract) $(public) $(dynamic_ext)
+all: $(FIRSTMAKEFILE) miniperl $(private) $(plextract) $(public) $(dynamic_ext)
@echo " "; echo " Everything is up to date."
translators: miniperl lib/Config.pm FORCE
@@ -223,22 +234,10 @@ utilities: miniperl lib/Config.pm FORCE
FORCE:
@sh -c true
-# 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) $(perllib)
- $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(perllib) $(libs)
- @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest
-
miniperlmain$(OBJ_EXT): miniperlmain.c
$(CCCMD) $(PLDLFLAGS) $*.c
-perlmain.c: miniperlmain.c config.sh makefile $(static_ext_autoinit)
+perlmain.c: miniperlmain.c config.sh $(FIRSTMAKEFILE)
sh writemain $(DYNALOADER) $(static_ext) > tmp
sh mv-if-diff tmp perlmain.c
@@ -251,54 +250,83 @@ perlmain$(OBJ_EXT): perlmain.c
ext.libs: $(static_ext)
-@test -f ext.libs || touch ext.libs
-perl: $& perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) ext.libs
- $(SHRPENV) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs)
-
-pureperl: $& perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) ext.libs
- purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs)
-
-quantperl: $& perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) ext.libs
- quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs)
-
-$(perllib): $& perl$(OBJ_EXT) $(obj)
!NO!SUBS!
-case "$d_shrplib" in
-*define*)
-$spitshell >>Makefile <<'!NO!SUBS!'
- $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj)
-!NO!SUBS!
-;;
-custom)
-if test -r $osname/Makefile.SHs ; then
- . $osname/Makefile.SHs
- $spitshell >>Makefile <<!GROK!THIS!
+# 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
- echo "Could not find $osname/Makefile.SH! Skipping target \$(perllib) in Makefile!"
-fi
-;;
-*)
-$spitshell >>Makefile <<'!NO!SUBS!'
- rm -f $(perllib)
- $(AR) rcu $(perllib) perl$(OBJ_EXT) $(obj)
- @$(ranlib) $(perllib)
+ $spitshell >>Makefile <<'!NO!SUBS!'
+$(LIBPERL): $& perl$(OBJ_EXT) $(obj)
!NO!SUBS!
-;;
-esac
+ 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!'
+ 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!'
-$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)
+ $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(LLIBPERL) $(libs)
+ @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest
+
+perl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+ $(SHRPENV) $(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) 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) 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) 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) $(perllib) $(DYNALOADER) $(static_ext) ext.libs
- $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs)
+suidperl: $& sperl$(OBJ_EXT) perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+ $(SHRPENV) $(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
@@ -316,7 +344,9 @@ preplibrary: miniperl lib/Config.pm $(plextract)
autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm
# Take care to avoid modifying lib/Config.pm without reason
-lib/Config.pm: config.sh miniperl
+# (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
./miniperl configpm tmp
sh mv-if-diff tmp lib/Config.pm
@@ -334,9 +364,18 @@ install.perl: all installperl
install.man: all installman
./perl installman
-# Not implemented yet.
-#install.html: all installhtml
-# ./perl installhtml
+# XXX Experimental. Hardwired values, but useful for testing.
+# Eventually Configure could ask for some of these values.
+install.html: all installhtml
+ ./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
@@ -346,12 +385,16 @@ install.man: all installman
# normally shouldn't remake perly.[ch].
run_byacc: FORCE
- @ echo 'Expect' 130 shift/reduce and 1 reduce/reduce conflict
+ @ 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
- mv y.tab.h perly.h
- echo 'extern YYSTYPE yylval;' >>perly.h
- - perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms
+ 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
@@ -386,33 +429,48 @@ regen_headers: FORCE
# DynaLoader may be needed for extensions that use Makefile.PL.
$(DYNALOADER): miniperl preplibrary FORCE
- @sh ext/util/make_ext static $@ LIBPERL_A=$(perllib)
+ @sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
d_dummy $(dynamic_ext): miniperl preplibrary $(DYNALOADER) FORCE
- @sh ext/util/make_ext dynamic $@ LIBPERL_A=$(perllib)
+ @sh ext/util/make_ext dynamic $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
s_dummy $(static_ext): miniperl preplibrary $(DYNALOADER) FORCE
- @sh ext/util/make_ext static $@ LIBPERL_A=$(perllib)
+ @sh ext/util/make_ext static $@ MAKE=$(MAKE) LIBPERL_A=$(LIBPERL)
+
+clean: _tidy _mopup
-clean:
+realclean: _cleaner _mopup
+ @echo "Note that make realclean does not delete config.sh"
+
+clobber: _cleaner _mopup
+ rm -f config.sh cppstdin
+
+distclean: clobber
+
+# Do not 'make _mopup' directly.
+_mopup:
rm -f *$(OBJ_EXT) *$(LIB_EXT) all perlmain.c
rm -f perl.exp ext.libs
- -rm perl.export perl.dll perl.libexp perl.map perl.def
+ -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) ; do \
- sh ext/util/make_ext clean $$x ; \
+ sh ext/util/make_ext clean $$x MAKE=$(MAKE) ; \
done
- rm -f perl suidperl miniperl $(perllib)
-realclean: clean
+# 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) ; do \
- sh ext/util/make_ext realclean $$x ; \
+ sh ext/util/make_ext realclean $$x MAKE=$(MAKE) ; \
done
rm -f *.orig */*.orig *~ */*~ core t/core t/c t/perl
rm -rf $(addedbyconf)
@@ -422,12 +480,6 @@ realclean: clean
rm -f lib/.exists
rm -f h2ph.man pstruct
rm -rf .config
- @echo "Note that make realclean does not delete config.sh"
-
-clobber: realclean
- rm -f config.sh cppstdin
-
-distclean: clobber
# The following lint has practically everything turned on. Unfortunately,
# you have to wade through a lot of mumbo jumbo that can't be suppressed.
@@ -437,19 +489,24 @@ distclean: clobber
lint: perly.c $(c)
lint $(lintflags) $(defs) perly.c $(c) > perl.fuzz
-# Need to unset during recursion to go out of loop
+# 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 = makedepend
+MAKEDEPEND = Makefile makedepend
-$(FIRSTMAKEFILE): Makefile $(MAKEDEPEND)
+$(FIRSTMAKEFILE): README $(MAKEDEPEND)
$(MAKE) depend MAKEDEPEND=
-config.h: config.sh
- /bin/sh config_h.SH
+config.h: config_h.SH config.sh
+ $(SHELL) config_h.SH
+
+perl.exp: perl_exp.SH config.sh
+ $(SHELL) perl_exp.SH
# When done, touch perlmain.c so that it doesn't get remade each time.
depend: makedepend
- sh ./makedepend
+ sh ./makedepend MAKE=$(MAKE)
- test -s perlmain.c && touch perlmain.c
cd x2p; $(MAKE) depend
@@ -457,14 +514,30 @@ depend: makedepend
makedepend: makedepend.SH config.sh
sh ./makedepend.SH
-test: miniperl perl preplibrary $(dynamic_ext)
- - cd t && chmod +x TEST */*.t
- - cd t && (rm -f perl$(EXE_EXT); $(LNS) ../perl$(EXE_EXT) perl$(EXE_EXT)) && ./perl TEST </dev/tty
+test-prep: miniperl perl preplibrary $(dynamic_ext)
+ cd t && (rm -f perl$(EXE_EXT); $(LNS) ../perl$(EXE_EXT) perl$(EXE_EXT))
+
+test check: test-prep
+ cd t && ./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 ./perl TEST
+
+# Can't depend on lib/Config.pm because that might be where miniperl
+# is crashing.
minitest: miniperl
- - cd t && chmod +x TEST */*.t
+ @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)) \
- && ./perl TEST base/*.t comp/*.t cmd/*.t io/*.t op/*.t </dev/tty
+ && ./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, just use "perlbug -Ilib".
+ok:
+ ./perl -Ilib utils/perlbug -ok -s '(UNINSTALLED)'
clist: $(c)
echo $(c) | tr ' ' '\012' >.clist
@@ -478,6 +551,12 @@ shlist: $(sh)
pllist: $(pl)
echo $(pl) | tr ' ' '\012' >.pllist
+Makefile: Makefile.SH ./config.sh
+ $(SHELL) Makefile.SH
+
+distcheck: FORCE
+ perl '-MExtUtils::Manifest=&fullcheck' -e 'fullcheck()'
+
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
# If this runs make out of memory, delete /usr/include lines.
!NO!SUBS!
diff --git a/gnu/usr.bin/perl/Makefile.bsd-wrapper b/gnu/usr.bin/perl/Makefile.bsd-wrapper
index 689807ed3cd..db7de3465cb 100644
--- a/gnu/usr.bin/perl/Makefile.bsd-wrapper
+++ b/gnu/usr.bin/perl/Makefile.bsd-wrapper
@@ -1,4 +1,4 @@
-# $OpenBSD: Makefile.bsd-wrapper,v 1.12 1997/07/24 21:12:14 kstailey Exp $
+# $OpenBSD: Makefile.bsd-wrapper,v 1.13 1997/11/30 07:48:01 millert Exp $
#
# Build wrapper for Perl 5.003.
#
@@ -9,22 +9,69 @@ LNDIR= /usr/bin/lndir
H2PH= /usr/bin/h2ph
-MAN= x2p/a2p.man x2p/s2p.man pod/perl.man pod/perlbook.man \
- pod/perlbot.man pod/perlcall.man pod/perldata.man \
- pod/perldebug.man pod/perldiag.man pod/perldsc.man \
- pod/perlembed.man pod/perlform.man pod/perlfunc.man \
- pod/perlguts.man pod/perlipc.man pod/perllol.man \
- pod/perlmod.man pod/perlobj.man pod/perlop.man \
- pod/perlovl.man pod/perlpod.man pod/perlre.man \
- pod/perlref.man pod/perlrun.man pod/perlsec.man \
- pod/perlstyle.man pod/perlsub.man pod/perlsyn.man \
- pod/perltie.man pod/perltoc.man pod/perltrap.man \
- pod/perlvar.man pod/perlxs.man pod/perlxstut.man
+# Pod (plain old documentation) files. These get turned into man pages.
+# We treat those pod files that don't end in .pod as a special case
+POD= pod/perl.pod pod/perlapio.pod pod/perlbook.pod pod/perlbot.pod \
+ pod/perlcall.pod pod/perldata.pod pod/perldebug.pod \
+ pod/perldelta.pod pod/perldiag.pod pod/perldsc.pod \
+ pod/perlembed.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/perlguts.pod pod/perlipc.pod \
+ pod/perllocale.pod pod/perllol.pod pod/perlmod.pod \
+ pod/perlmodlib.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/perltoot.pod \
+ pod/perltrap.pod pod/perlvar.pod pod/perlxs.pod \
+ pod/perlxstut.pod x2p/a2p.pod
+# Don't install these for now (need special install to do / > ::)
+# lib/Devel/SelfStubber.pm lib/IPC/Open2.pm lib/IPC/Open3.pm \
+# lib/Net/Ping.pm lib/Net/hostent.pm lib/Net/netent.pm \
+# lib/Net/protoent.pm lib/Net/servent.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/Command.pm \
+# lib/ExtUtils/Embed.pm lib/ExtUtils/MM_Win32.pm \
+# lib/File/Basename.pm lib/File/CheckTree.pm lib/File/Copy.pm \
+# lib/File/Find.pm lib/File/Path.pm lib/File/Compare.pm \
+# lib/File/DosGlob.pm lib/File/stat.pm lib/Getopt/Long.pm \
+# lib/Getopt/Std.pm lib/I18N/Collate.pm lib/Math/BigFloat.pm \
+# lib/Math/BigInt.pm lib/Math/Complex.pm lib/Math/Trig.pm \
+# lib/Pod/Functions.pm lib/Pod/Text.pm lib/Pod/Html.pm \
+# lib/Search/Dict.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/Tie/RefHash.pm lib/Time/Local.pm lib/Time/gmtime.pm \
+# lib/Time/localtime.pm lib/Time/tm.pm lib/AnyDBM_File.pm \
+# lib/AutoLoader.pm lib/AutoSplit.pm lib/Benchmark.pm \
+# lib/Carp.pm lib/Cwd.pm lib/DirHandle.pm lib/English.pm \
+# lib/Env.pm lib/Exporter.pm lib/FileCache.pm lib/SelectSaver.pm \
+# lib/SelfLoader.pm lib/Shell.pm lib/Symbol.pm \
+# lib/diagnostics.pm lib/integer.pm lib/less.pm lib/lib.pm \
+# lib/overload.pm lib/sigtrap.pm lib/strict.pm lib/subs.pm \
+# lib/vars.pm lib/Bundle/CPAN.pm lib/CGI/Apache.pm \
+# lib/CGI/Carp.pm lib/CGI/Fast.pm lib/CGI/Push.pm \
+# lib/CGI/Switch.pm lib/CGI.pm lib/CPAN.pm lib/CPAN/FirstTime.pm \
+# lib/CPAN/Nox.pm lib/Class/Struct.pm lib/FileHandle.pm \
+# lib/FindBin.pm lib/UNIVERSAL.pm lib/User/grent.pm \
+# lib/User/pwent.pm lib/autouse.pm lib/base.pm lib/blib.pm \
+# lib/constant.pm lib/locale.pm
.include <bsd.own.mk>
.ifndef NOMAN
-MANALL= ${MAN:S/.man$/.cat1/g}
+MANALL= ${POD:S/.pod$/.cat1/g:S/.pm$/.cat3p/g} \
+ utils/c2ph.cat1 utils/h2ph.cat1 utils/h2xs.cat1 \
+ utils/perldoc.cat1 utils/perlbug.cat1 utils/pl2pm.cat1 \
+ utils/splain.cat1 x2p/s2p.cat1 pod/pod2man.cat1 \
+ pod/pod2html.cat1 utils/pstruct.cat1 lib/ExtUtils/xsubpp.cat1
.else
MANALL=
.endif
@@ -37,16 +84,20 @@ INST_PROG='/usr/bin/install -cs'
INST_PROG='/usr/bin/install -c'
.endif
-.SUFFIXES: .man .cat1
+.SUFFIXES: .pod .pm .cat1 cat3p
-.man.cat1:
- @echo "${NROFF} -mandoc ${.IMPSRC} > ${.TARGET}"
- @${NROFF} -mandoc ${.IMPSRC} > ${.TARGET} || (rm -f ${.TARGET}; false)
+.pod.cat1:
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.IMPSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.IMPSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+# XXX - '/' needs to become :: when installed (need own maninstall target?)
+.pm.cat3p:
+ @echo "./perl -I./lib ./pod/pod2man --section=3p --official ${.IMPSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I./lib ./pod/pod2man --section=1 --official ${.IMPSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
GENERATED= config.sh Makefile cflags config.h makeaperl makedepend \
makedir perl.exp writemain x2p/Makefile x2p/cflags
-CLEANFILES= config.sh ${MANALL}
+CLEANFILES= config.sh ${MAN} ${MANALL}
.BEGIN:
@if [ ${.CURDIR} != ${.OBJDIR} ]; then ${LNDIR} -s -e obj -e obj.${MACHINE_ARCH} -e Makefile.bsd-wrapper ${.CURDIR}; fi
@@ -88,6 +139,54 @@ x2p/Makefile:
x2p/cflags:
(cd ${.OBJDIR}/x2p; /bin/sh cflags.SH)
+utils/c2ph.cat1: utils/c2ph
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
+utils/h2ph.cat1: utils/h2ph
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
+utils/h2xs.cat1: utils/h2xs
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
+utils/perldoc.cat1: utils/perldoc
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
+utils/perlbug.cat1: utils/perlbug
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
+utils/pl2pm.cat1: utils/pl2pm
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
+utils/splain.cat1: utils/splain
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
+x2p/s2p.cat1: x2p/s2p
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
+pod/pod2man.cat1: pod/pod2man
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
+pod/pod2html.cat1: pod/pod2html
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
+utils/pstruct.cat1: utils/pstruct
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
+lib/ExtUtils/xsubpp.cat1: lib/ExtUtils/xsubpp
+ @echo "./perl -I./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET}"
+ ./perl -I$./lib ./pod/pod2man --section=1 --official ${.ALLSRC} | ${NROFF} -man > ${.TARGET} || (rm -f ${.TARGET}; false)
+
.ifdef NOMAN
maninstall:
@echo NOMAN is set
@@ -95,7 +194,7 @@ maninstall:
install: ${MANALL} maninstall
(cd ${.OBJDIR}; INSTALL=${INSTALL} INSTALL_COPY=${INSTALL_COPY} \
- INSTALL_STRIP=${INSTALL_STRIP} ${MAKE} install)
+ INSTALL_STRIP=${INSTALL_STRIP} ${MAKE} install.perl)
(cd ${DESTDIR}/usr/include; ${H2PH} *.h arpa/*.h machine/*.h net/*.h \
protocols/*.h sys/*.h)
-chmod -R a+rX ${DESTDIR}/usr/lib/perl5
diff --git a/gnu/usr.bin/perl/Porting/Glossary b/gnu/usr.bin/perl/Porting/Glossary
new file mode 100644
index 00000000000..c71c199ec4b
--- /dev/null
+++ b/gnu/usr.bin/perl/Porting/Glossary
@@ -0,0 +1,1420 @@
+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.
+
+alignbytes (alignbytes.U):
+ This variable holds the number of bytes required to align a
+ double. Usual values are 2, 4 and 8.
+
+ar (Unix.U):
+ This variable defines the command to use to create an archive
+ library. For unix, it is 'ar'.
+
+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.
+
+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.
+
+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.
+
+bincompat3 (bincompat3.U):
+ This variable contains y if Perl 5.004 should be binary-compatible
+ with Perl 5.003.
+
+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
+
+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_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.
+
+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.
+
+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 "".
+
+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.
+
+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_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_bincompat3 (bincompat3.U):
+ This variable conditionally defines BINCOMPAT3 so that embed.h
+ can take special action if Perl 5.004 should be binary-compatible
+ with Perl 5.003.
+
+d_bsdgetpgrp (d_getpgrp.U):
+ This variable conditionally defines USE_BSD_GETPGRP if
+ getpgrp needs one arguments whereas USG one needs none.
+
+d_bsdpgrp (d_setpgrp.U):
+ This variable conditionally defines USE_BSDPGRP if the notion of
+ process group is the BSD one. This means setpgrp needs two 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_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_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_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_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_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_gethent (d_gethent.U):
+ This variable conditionally defines HAS_GETHOSTENT if gethostent() is
+ available to dup file descriptors.
+
+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).
+
+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_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_getpgrp (d_getpgrp.U):
+ This variable conditionally defines HAS_GETPGRP if getpgrp() is
+ available to get the current process group.
+
+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_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_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_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_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_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_oldarchlib (oldarchlib.U):
+ This variable conditionally defines OLDARCHLIB to hold the pathname
+ of architecture-dependent library files for a previous
+ version of $package.
+
+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_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_pwage (i_pwd.U):
+ This varaible conditionally defines PWAGE, which indicates
+ that struct passwd contains pw_age.
+
+d_pwchange (i_pwd.U):
+ This varaible conditionally defines PWCHANGE, which indicates
+ that struct passwd contains pw_change.
+
+d_pwclass (i_pwd.U):
+ This varaible conditionally defines PWCLASS, which indicates
+ that struct passwd contains pw_class.
+
+d_pwcomment (i_pwd.U):
+ This varaible conditionally defines PWCOMMENT, which indicates
+ that struct passwd contains pw_comment.
+
+d_pwexpire (i_pwd.U):
+ This varaible conditionally defines PWEXPIRE, which indicates
+ that struct passwd contains pw_expire.
+
+d_pwquota (i_pwd.U):
+ This varaible 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_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_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_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_setpgid (d_setpgid.U):
+ This variable conditionally defines the HAS_SETPGID symbol, which
+ indicates to the C program that the setpgid(pid, gpid) function
+ is available to set the process group id.
+
+d_setpgrp (d_setpgrp.U):
+ This variable conditionally defines HAS_SETPGRP if setpgrp() is
+ available to set the current process group.
+
+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_setprior (d_setprior.U):
+ This variable conditionally defines HAS_SETPRIORITY if setpriority()
+ is available to set a process's priority.
+
+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_setsid (d_setsid.U):
+ This variable conditionally defines HAS_SETSID if setsid() is
+ available to set the process group ID.
+
+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_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_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_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_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_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_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.
+
+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.
+
+dynamic_ext (Extensions.U):
+ This variable holds a list of 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).
+
+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 variable defines the extension used for executable files.
+ For unix it is empty. Other possible values include '.exe'.
+
+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.
+
+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.'
+
+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.
+
+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(). Usually, this is the same of gidtype, but
+ sometimes it isn't.
+
+i_dirent (i_dirent.U):
+ This variable conditionally defines I_DIRENT, which indicates
+ to the C program that it should include <dirent.h>.
+
+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_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_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_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_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_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.
+
+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.
+
+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.
+
+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 integer.
+
+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.
+
+lib_ext (Unix.U):
+ This variable defines the extension used for ordinary libraries.
+ For unix, it is '.a'. The '.' is included. Other possible
+ values include '.lib'.
+
+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.
+
+libs (libs.U):
+ This variable holds the additional libraries we want to use.
+ It is up to the Makefile to deal with it.
+
+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'
+
+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 integer.
+
+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).
+
+make (make.U):
+ This variable sets the path to the 'make' command. It is
+ here rather than in Loc.U so that users can override it
+ with Configure -Dmake=pmake, or equivalent.
+
+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 # 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.
+
+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.
+
+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.
+
+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.
+
+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".
+
+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.
+
+oldarchlib (oldarchlib.U):
+ This variable holds the name of the directory in which perl5.000
+ and perl5.001 stored
+ architecture-dependent public library files.
+
+oldarchlibexp (oldarchlib.U):
+ This variable is the same as the oldarchlib variable, but is
+ filename expanded at configuration time, for convenient use.
+
+optimize (ccflags.U):
+ This variable contains any optimizer/debugger flag that should be used.
+ It is up to the Makefile to use it.
+
+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.
+
+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.
+
+path_sep (Unix.U):
+ This variable defines the character used to separate elements in
+ the shell's PATH environment variable. On Unix, it is ':'.
+ This is probably identical to Head.U's p_ variable and can
+ probably be dropped.
+
+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.
+
+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.
+
+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.
+
+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!
+
+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.
+
+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.
+
+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
+
+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 integer.
+
+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).
+
+sig_name (sig_name.U):
+ This variable holds the signal names, space separated. The leading
+ SIG in signals name is removed. See sig_num.
+
+sig_num (sig_name.U):
+ This variable holds the signal numbers, space separated. 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.
+
+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.
+
+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.
+
+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 /usr/bin/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 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".
+
+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.
+
+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.
+
+useperlio (useperlio.U):
+ This variable conditionally defines the USE_PERLIO symbol,
+ and indicates that the PerlIO abstraction should be
+ used throughout.
+
+useshrplib (libperl.U):
+ This variable is set to 'yes' if the user wishes
+ to build a shared libperl, and 'no' otherwise.
+
+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.
+
diff --git a/gnu/usr.bin/perl/Porting/makerel b/gnu/usr.bin/perl/Porting/makerel
new file mode 100644
index 00000000000..f719a5e9361
--- /dev/null
+++ b/gnu/usr.bin/perl/Porting/makerel
@@ -0,0 +1,100 @@
+#!/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";
+
+$patchlevel_h = `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);
+$vers.= sprintf( "_%02d", $subversion) if $subversion;
+
+$perl = "perl$vers";
+$reldir = "$relroot/$perl";
+$reldir .= "-$ARGV[0]" if $ARGV[0];
+
+print "\nMaking a release for $perl in $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";
+
+
+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");
+system("chmod +w configure"); # special case (see pumpkin.pod)
+@exe = qw(
+ Configure
+ configpm
+ configure
+ 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
+ vms/fndvers.com
+ x2p/*.SH
+ Porting/patchls
+ Porting/makerel
+);
+system("chmod +x @exe");
+print "\n";
+
+
+print "Creating $reldir release directory...\n";
+die "$reldir release directory already exists\n" if -e "../$perl";
+die "$reldir.tar.gz release file already exists\n" if -e "../$reldir.tar.gz";
+mkdir($reldir, 0755) or die "mkdir $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 $reldir";
+system($cmd) == 0 or die "$cmd failed";
+print "\n";
+
+chdir $relroot or die $!;
+
+print "Creating and compressing the tar file...\n";
+$cmd = "tar cf - $perl | gzip --best > $perl.tar.gz";
+system($cmd) == 0 or die "$cmd failed";
+print "\n";
+
+system("ls -ld $perl*");
diff --git a/gnu/usr.bin/perl/Porting/patchls b/gnu/usr.bin/perl/Porting/patchls
new file mode 100644
index 00000000000..1d4bd5ac400
--- /dev/null
+++ b/gnu/usr.bin/perl/Porting/patchls
@@ -0,0 +1,431 @@
+#!/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.04;
+
+sub usage {
+die q{
+ 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).
+ -f F only list patches which patch files matching regexp F
+ (F has $ appended unless it contains a /).
+ 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.
+ -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)
+}
+}
+
+$::opt_p = undef; # undef != 0
+$::opt_d = 0;
+$::opt_v = 0;
+$::opt_m = 0;
+$::opt_i = 0;
+$::opt_h = 0;
+$::opt_l = 0;
+$::opt_c = 0;
+$::opt_f = '';
+
+# special purpose options
+$::opt_I = 0;
+$::opt_4 = 0; # output PerForce commands to prepare for patching
+$::opt_M = ''; # like -m but only output these meta items (-M Title)
+$::opt_W = 70; # set wrap width columns (see Text::Wrap module)
+
+usage unless @ARGV;
+
+getopts("mihlvc4p:f:IM:W:") or usage;
+
+$columns = $::opt_W || 9999999;
+
+$::opt_m = 1 if $::opt_M;
+my @show_meta = split(' ', $::opt_M || 'Title From Msg-ID');
+
+my %cat_title = (
+ 'BUILD' => 'BUILD PROCESS',
+ 'CORE' => 'CORE LANGUAGE',
+ 'DOC' => 'DOCUMENTATION',
+ 'LIB' => 'LIBRARY AND EXTENSIONS',
+ 'PORT1' => 'PORTABILITY - WIN32',
+ 'PORT2' => 'PORTABILITY - GENERAL',
+ 'TEST' => 'TESTS',
+ 'UTIL' => 'UTILITIES',
+ 'OTHER' => 'OTHER CHANGES',
+);
+
+my %ls;
+
+# 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($in, $prevline, $prevtype, $ls);
+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/;
+ }
+ next unless $::opt_m;
+ $ls->{From}{$1}=1,next if /^From:\s+(.*\S)/i;
+ $ls->{Title}{$1}=1,next if /^Subject:\s+(?:Re: )?(.*\S)/i;
+ $ls->{'Msg-ID'}{$1}=1,next if /^Message-Id:\s+(.*\S)/i;
+ $ls->{Date}{$1}=1,next if /^Date:\s+(.*\S)/i;
+ $ls->{$1}{$2}=1,next if /^([-\w]+):\s+(.*\S)/;
+ next;
+ }
+ $type = $1;
+ next if /^--- [0-9,]+ ----$/ || /^\*\*\* [0-9,]+ \*\*\*\*$/;
+ $prologue = 0;
+
+ print "Last: $prevline","This: ${_}Got: $1\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 bing fixed.
+ add_file($ls, $1), next if /^Index:\s+(\S+)/;
+
+ 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 = '';
+ }
+ # 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>
+ my $out;
+ $::opt_f .= '$' unless $::opt_f =~ m:/:;
+ @ls = grep {
+ my @out = keys %{$_->{out}};
+ my $match = 0;
+ for $out (@out) {
+ ++$match if $out =~ 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) {
+ print map { "p4 delete $_\n" } @removed if @removed;
+ print map { "p4 add $_\n" } @added if @added;
+ my @patches = grep { $_->{is_in} } @ls;
+ my %patched = map { ($_, 1) } map { keys %{$_->{out}} } @patches;
+ delete @patched{@added};
+ my @patched = sort keys %patched;
+ print map { "p4 edit $_\n" } @patched if @patched;
+ exit 0;
+}
+
+if ($::opt_I) {
+ my $n_patches = 0;
+ my($in,$out);
+ my %all_out;
+ foreach $in (@ls) {
+ next unless $in->{is_in};
+ ++$n_patches;
+ my @outs = keys %{$in->{out}};
+ @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 "(use -v to list patches which patch 'missing' files)\n"
+ if @missing && !$::opt_v;
+ if ($::opt_v and @missing) {
+ print "Missing files:\n";
+ foreach $out (@missing) {
+ printf " %-20s\t%s\n", $out, $all_out{$out};
+ }
+ }
+ 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};
+ 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;
+ my $out = trim_name(shift);
+
+ $ls->{out}->{$out} = 1;
+
+ # 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 { s/\[?PATCH\]?:?\s*//g; "\"$_\""; } @list
+ }
+ 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};
+ print("$ls->{in}\n"),return if $::opt_l; # -l = no listing
+
+ # a twisty maze of little options
+ my $cat = ($ls->{category} and !$::opt_m) ? "\t$ls->{category}" : "";
+ print "$name$cat: " unless ($::opt_h and !$::opt_v) or !"$name$cat";
+ print join('',"\n",@meta) if @meta;
+
+ my @v = sort PATORDER keys %{ $ls->{out} };
+ my $v = "@v\n";
+ print $::opt_m ? " Files: ".my_wrap(""," ",$v) : $v;
+}
+
+
+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{LIB} += 10,next
+ if m:^(lib|ext)/:;
+ $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 ||= 'OTHER'; $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/gnu/usr.bin/perl/Porting/pumpkin.pod b/gnu/usr.bin/perl/Porting/pumpkin.pod
new file mode 100644
index 00000000000..6706c6c3c42
--- /dev/null
+++ b/gnu/usr.bin/perl/Porting/pumpkin.pod
@@ -0,0 +1,1180 @@
+=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.
+
+=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, minor changes to
+F<Configure> may be made in between major sync-ups with the metaconfig
+units, which tends to be complicated operations.
+
+=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. 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 the same place you found this file. On CPAN, look under my
+directory F<authors/id/ANDYD/> for a file such as F<5.003_07-02.U.tar.gz>.
+That file should be unpacked in your main perl source directory. It
+contains the files needed to run B<metaconfig> to reproduce Perl's
+Configure script. (Those units are for 5.003_07. There have been
+changes since then; please contact me if you want more recent
+versions, and I will try to point you in the right direction.)
+
+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, with one exception. Perl includes
+both a F<Configure> script and a F<configure> script. The
+F<configure> script is a front-end to the main F<Configure>, but
+is there to aid folks who use autoconf-generated F<configure> files
+for other software. The problem is that F<Configure> and F<configure>
+are the same on case-insensitive file systems, so I deliberately put
+F<configure> first in the MANIFEST so that the extraction of
+F<Configure> will overwrite F<configure> and leave you with the
+correct script. (The F<configure> script must also have write
+permission for this to work, so it's the only file in the distribution
+I normally have with write permission.)
+
+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. Probably, the F<t/TEST> script should check for this
+and do the chmod if needed, but it doesn't currently.
+
+In all, the following files should probably be executable:
+
+ Configure
+ configpm
+ configure
+ 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
+ vms/fndvers.com
+ 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.
+
+=head2 Update config_H
+
+The config_H file is provided to help those folks who can't run Configure.
+It is important to keep it 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 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 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.
+
+=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 -Dsrcdir=/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. Eventually, they ought
+to get folded back into the main distribution.
+
+=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.
+
+=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 long long
+
+Can we support C<long long> on systems where C<long long> is larger
+than what we've been using for C<IV>? What if you can't C<sprintf>
+a C<long long>?
+
+=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.13 1997/08/28 18:26:40 doughera Released $
diff --git a/gnu/usr.bin/perl/README b/gnu/usr.bin/perl/README
index 0a7ab1ce967..83b9ab578f9 100644
--- a/gnu/usr.bin/perl/README
+++ b/gnu/usr.bin/perl/README
@@ -1,7 +1,7 @@
Perl Kit, Version 5.0
- Copyright 1989-1996, Larry Wall
+ Copyright 1989-1997, Larry Wall
All rights reserved.
This program is free software; you can redistribute it and/or modify
@@ -62,20 +62,21 @@ in MANIFEST.
Installation
-1) Detailed instructions are in the file INSTALL. In brief, the
-following should work on most systems:
+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.
+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 me, lwall@sems.com (Larry Wall), so we can
+patches to me, larry@wall.org (Larry Wall), 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
diff --git a/gnu/usr.bin/perl/README.amiga b/gnu/usr.bin/perl/README.amiga
new file mode 100644
index 00000000000..55167cb44d8
--- /dev/null
+++ b/gnu/usr.bin/perl/README.amiga
@@ -0,0 +1,240 @@
+If you read this file _as_is_, just ignore the funny characters you
+see. It is written in the POD format (see perlpod manpage) which is
+specially designed to be readable as is.
+
+=head1 NAME
+
+perlamiga - Perl under Amiga OS
+
+=head1 SYNOPSIS
+
+One can read this document in the following formats:
+
+ man perlamiga
+ multiview perlamiga.guide
+
+to list some (not all may be available simultaneously), or it may
+be read I<as is>: either as F<README.amiga>, or F<pod/perlamiga.pod>.
+
+=cut
+
+Contents
+
+ perlamiga - Perl under Amiga OS
+
+ NAME
+ SYNOPSIS
+ DESCRIPTION
+ - Prerequisites
+ - Starting Perl programs under AmigaOS
+ - Shortcomings of Perl under AmigaOS
+ INSTALLATION
+ Accessing documentation
+ - Manpages
+ - HTML
+ - GNU info files
+ - LaTeX docs
+ BUILD
+ - Prerequisites
+ - Getting the perl source
+ - Application of the patches
+ - Making
+ - Testing
+ - Installing the built perl
+ AUTHOR
+ SEE ALSO
+
+=head1 DESCRIPTION
+
+=head2 Prerequisites
+
+=over 6
+
+=item B<Unix emulation for AmigaOS: ixemul.library>
+
+You need the Unix emulation for AmigaOS, whose most important part is
+B<ixemul.library>. For a minimum setup, get the following archives from
+ftp://ftp.ninemoons.com/pub/ade/current or a mirror:
+
+ixemul-46.0-bin.lha
+ixemul-46.0-env-bin.lha
+pdksh-4.9-bin.lha
+ADE-misc-bin.lha
+
+Note that there might be newer versions available by the time you read
+this.
+
+Note also that this is a minimum setup; you might want to add other
+packages of B<ADE> (the I<Amiga Developers Environment>).
+
+=item B<Version of Amiga OS>
+
+You need at the very least AmigaOS version 2.0. Recommended is version 3.1.
+
+=back
+
+=head2 Starting Perl programs under AmigaOS
+
+Start your Perl program F<foo> with arguments C<arg1 arg2 arg3> the
+same way as on any other platform, by
+
+ perl foo arg1 arg2 arg3
+
+If you want to specify perl options C<-my_opts> to the perl itself (as
+opposed to to your program), use
+
+ perl -my_opts foo arg1 arg2 arg3
+
+Alternately, you can try to get a replacement for the system's B<Execute>
+command that honors the #!/usr/bin/perl syntax in scripts and set the s-Bit
+of your scripts. Then you can invoke your scripts like under UNIX with
+
+ foo arg1 arg2 arg3
+
+(Note that having *nixish full path to perl F</usr/bin/perl> is not
+necessary, F<perl> would be enough, but having full path would make it
+easier to use your script under *nix.)
+
+=head2 Shortcomings of Perl under AmigaOS
+
+Perl under AmigaOS lacks some features of perl under UNIX because of
+deficiencies in the UNIX-emulation, most notably:
+
+=over 6
+
+=item fork()
+
+=item some features of the UNIX filesystem regarding link count and file dates
+
+=item inplace operation (the -i switch) without backup file
+
+=item umask() works, but the correct permissions are only set when the file is
+ finally close()d
+
+=back
+
+=head1 INSTALLATION
+
+Change to the installation directory (most probably ADE:), and
+extract the binary distribution:
+
+lha -mraxe x perl-5.003-bin.lha
+
+or
+
+tar xvzpf perl-5.003-bin.tgz
+
+(Of course you need lha or tar and gunzip for this.)
+
+For installation of the Unix emulation, read the appropriate docs.
+
+=head1 Accessing documentation
+
+=head2 Manpages
+
+If you have C<man> installed on your system, and you installed perl
+manpages, use something like this:
+
+ man perlfunc
+ man less
+ man ExtUtils.MakeMaker
+
+to access documentation for different components of Perl. Start with
+
+ man perl
+
+Note: You have to modify your man.conf file to search for manpages
+in the /ade/lib/perl5/man/man3 directory, or the man pages for the
+perl library will not be found.
+
+Note that dot (F<.>) is used as a package separator for documentation
+for packages, and as usual, sometimes you need to give the section - C<3>
+above - to avoid shadowing by the I<less(1) manpage>.
+
+
+=head2 B<HTML>
+
+If you have some WWW browser available, you can build B<HTML> docs.
+Cd to directory with F<.pod> files, and do like this
+
+ cd /ade/lib/perl5/pod
+ pod2html
+
+After this you can direct your browser the file F<perl.html> in this
+directory, and go ahead with reading docs.
+
+Alternatively you may be able to get these docs prebuilt from C<CPAN>.
+
+=head2 B<GNU> C<info> files
+
+Users of C<Emacs> would appreciate it very much, especially with
+C<CPerl> mode loaded. You need to get latest C<pod2info> from C<CPAN>,
+or, alternately, prebuilt info pages.
+
+=head2 C<LaTeX> docs
+
+can be constructed using C<pod2latex>.
+
+=head1 BUILD
+
+Here we discuss how to build Perl under AmigaOS.
+
+=head2 Prerequisites
+
+You need to have the latest B<ADE> (Amiga Developers Environment)
+from ftp://ftp.ninemoons.com/pub/ade/current.
+Also, you need a lot of free memory, probably at least 8MB.
+
+=head2 Getting the perl source
+
+You can either get the latest perl-for-amiga source from Ninemoons
+and extract it with:
+
+ tar xvzpf perl-5.004-src.tgz
+
+or get the official source from CPAN:
+
+ http://www.perl.com/CPAN/src/5.0
+
+Extract it like this
+
+ tar xvzpf perl5.004.tar.gz
+
+You will see a message about errors while extracting F<Configure>. This
+is normal and expected. (There is a conflict with a similarly-named file
+F<configure>, but it causes no harm.)
+
+=head2 Making
+
+ sh configure.gnu --prefix=/ade
+
+Now
+
+ make
+
+=head2 Testing
+
+Now run
+
+ make test
+
+Some tests will be skipped because they need the fork() function:
+
+F<io/pipe.t>, F<op/fork.t>, F<lib/filehand.t>, F<lib/open2.t>, F<lib/open3.t>,
+F<lib/io_pipe.t>, F<lib/io_sock.t>
+
+=head2 Installing the built perl
+
+Run
+
+ make install
+
+=head1 AUTHOR
+
+Norbert Pueschel, pueschel@imsdd.meb.uni-bonn.de
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
diff --git a/gnu/usr.bin/perl/README.cygwin32 b/gnu/usr.bin/perl/README.cygwin32
new file mode 100644
index 00000000000..d7950f63d44
--- /dev/null
+++ b/gnu/usr.bin/perl/README.cygwin32
@@ -0,0 +1,59 @@
+The following assumes you have the GNU-Win32 package, version b17.1 or
+later, installed and configured on your system. See
+http://www.cygnus.com/misc/gnu-win32/ for details on the GNU-Win32
+project and the Cygwin32 API.
+
+1) Copy the contents of the cygwin32 directory to the Perl source
+ root directory.
+
+2) Modify the ld2 script by making the PERLPATH variable contain the
+ Perl source root directory. For example, if you extracted perl to
+ "/perl5.004", change the script so it contains the line:
+
+ PERLPATH=/perl5.004
+
+3) Copy the two scripts ld2 and gcc2 from the cygwin32 subdirectory to a
+ directory in your PATH environment variable. For example, copy to
+ /bin, assuming /bin is in your PATH. (These two scripts are 'wrapper'
+ scripts that encapsulate the multiple-pass dll building steps used by
+ GNU-Win32 ld/gcc.)
+
+4) Run the perl Configuration script as stated in the perl README file:
+
+ sh Configure
+
+ When confronted with this prompt:
+
+ First time through, eh? I have some defaults handy for the
+ following systems:
+ .
+ .
+ .
+ Which of these apply, if any?
+
+ Select "cygwin32".
+
+ The defaults should be OK for everything, except for the specific
+ pathnames for the cygwin32 libs, include files, installation dirs,
+ etc. on your system; answer those questions appropriately.
+
+ NOTE: On windows 95, the configuration script only stops every other
+ time for responses from the command line. In this case you can manually
+ copy hints/cygwin32.sh to config.sh, edit config.sh for your paths, and
+ run Configure non-interactively using sh Configure -d.
+
+5) Run "make" as stated in the perl README file.
+
+6) Run "make test". Some tests will fail, but you should get around a
+ 83% success rate. (Most failures seem to be due to Unixisms that don't
+ apply to win32.)
+
+7) Install. If you just run "perl installperl", it appears that perl
+ can't find itself when it forks because it changes to another directory
+ during the install process. You can get around this by invoking the
+ install script using a full pathname for perl, such as:
+
+ /perl5.004/perl installperl
+
+ This should complete the installation process.
+
diff --git a/gnu/usr.bin/perl/README.os2 b/gnu/usr.bin/perl/README.os2
new file mode 100644
index 00000000000..667423c382a
--- /dev/null
+++ b/gnu/usr.bin/perl/README.os2
@@ -0,0 +1,1493 @@
+If you read this file _as_is_, just ignore the funny characters you
+see. It is written in the POD format (see perlpod manpage) which is
+specially designed to be readable as is.
+
+=head1 NAME
+
+perlos2 - Perl under OS/2, DOS, Win0.3*, Win0.95 and WinNT.
+
+=head1 SYNOPSIS
+
+One can read this document in the following formats:
+
+ man perlos2
+ view perl perlos2
+ explorer perlos2.html
+ info perlos2
+
+to list some (not all may be available simultaneously), or it may
+be read I<as is>: either as F<README.os2>, or F<pod/perlos2.pod>.
+
+To read the F<.INF> version of documentation (B<very> recommended)
+outside of OS/2, one needs an IBM's reader (may be available on IBM
+ftp sites (?) (URL anyone?)) or shipped with PC DOS 7.0 and IBM's
+Visual Age C++ 3.5.
+
+A copy of a Win* viewer is contained in the "Just add OS/2 Warp" package
+
+ ftp://ftp.software.ibm.com/ps/products/os2/tools/jaow/jaow.zip
+
+in F<?:\JUST_ADD\view.exe>. This gives one an access to EMX's
+F<.INF> docs as well (text form is available in F</emx/doc> in
+EMX's distribution).
+
+Note that if you have F<lynx.exe> installed, you can follow WWW links
+from this document in F<.INF> format. If you have EMX docs installed
+correctly, you can follow library links (you need to have C<view emxbook>
+working by setting C<EMXBOOK> environment variable as it is described
+in EMX docs).
+
+=cut
+
+Contents
+
+ perlos2 - Perl under OS/2, DOS, Win0.3*, Win0.95 and WinNT.
+
+ NAME
+ SYNOPSIS
+ DESCRIPTION
+ - Target
+ - Other OSes
+ - Prerequisites
+ - Starting Perl programs under OS/2 (and DOS and...)
+ - Starting OS/2 (and DOS) programs under Perl
+ Frequently asked questions
+ - I cannot run external programs
+ - I cannot embed perl into my program, or use perl.dll from my program.
+ - `` and pipe-open do not work under DOS.
+ - Cannot start find.exe "pattern" file
+ INSTALLATION
+ - Automatic binary installation
+ - Manual binary installation
+ - Warning
+ Accessing documentation
+ - OS/2 .INF file
+ - Plain text
+ - Manpages
+ - HTML
+ - GNU info files
+ - .PDF files
+ - LaTeX docs
+ BUILD
+ - Prerequisites
+ - Getting perl source
+ - Application of the patches
+ - Hand-editing
+ - Making
+ - Testing
+ - Installing the built perl
+ - a.out-style build
+ Build FAQ
+ - Some / became \ in pdksh.
+ - 'errno' - unresolved external
+ - Problems with tr
+ - Some problem (forget which ;-)
+ - Library ... not found
+ - Segfault in make
+ Specific (mis)features of EMX port
+ - setpriority, getpriority
+ - system()
+ - extproc on the first line
+ - Additional modules:
+ - Prebuilt methods:
+ - Misfeatures
+ - Modifications
+ Perl flavors
+ - perl.exe
+ - perl_.exe
+ - perl__.exe
+ - perl___.exe
+ - Why strange names?
+ - Why dynamic linking?
+ - Why chimera build?
+ ENVIRONMENT
+ - PERLLIB_PREFIX
+ - PERL_BADLANG
+ - PERL_BADFREE
+ - PERL_SH_DIR
+ - TMP or TEMP
+ Evolution
+ - Priorities
+ - DLL name mangling
+ - Threading
+ - Calls to external programs
+ - Memory allocation
+ AUTHOR
+ SEE ALSO
+
+=head1 DESCRIPTION
+
+=head2 Target
+
+The target is to make OS/2 the best supported platform for
+using/building/developing Perl and I<Perl applications>, as well as
+make Perl the best language to use under OS/2. The secondary target is
+to try to make this work under DOS and Win* as well (but not B<too> hard).
+
+The current state is quite close to this target. Known limitations:
+
+=over 5
+
+=item *
+
+Some *nix programs use fork() a lot, but currently fork() is not
+supported after I<use>ing dynamically loaded extensions.
+
+=item *
+
+You need a separate perl executable F<perl__.exe> (see L<perl__.exe>)
+to use PM code in your application (like the forthcoming Perl/Tk).
+
+=item *
+
+There is no simple way to access WPS objects. The only way I know
+is via C<OS2::REXX> extension (see L<OS2::REXX>), and we do not have access to
+convenience methods of Object-REXX. (Is it possible at all? I know
+of no Object-REXX API.)
+
+=back
+
+Please keep this list up-to-date by informing me about other items.
+
+=head2 Other OSes
+
+Since OS/2 port of perl uses a remarkable EMX environment, it can
+run (and build extensions, and - possibly - be build itself) under any
+environment which can run EMX. The current list is DOS,
+DOS-inside-OS/2, Win0.3*, Win0.95 and WinNT. Out of many perl flavors,
+only one works, see L<"perl_.exe">.
+
+Note that not all features of Perl are available under these
+environments. This depends on the features the I<extender> - most
+probably RSX - decided to implement.
+
+Cf. L<Prerequisites>.
+
+=head2 Prerequisites
+
+=over 6
+
+=item EMX
+
+EMX runtime is required (may be substituted by RSX). Note that
+it is possible to make F<perl_.exe> to run under DOS without any
+external support by binding F<emx.exe>/F<rsx.exe> to it, see L<emxbind>. Note
+that under DOS for best results one should use RSX runtime, which
+has much more functions working (like C<fork>, C<popen> and so on). In
+fact RSX is required if there is no VCPI present. Note the
+RSX requires DPMI.
+
+Only the latest runtime is supported, currently C<0.9c>. Perl may run
+under earlier versions of EMX, but this is not tested.
+
+One can get different parts of EMX from, say
+
+ ftp://ftp.cdrom.com/pub/os2/emx09c/
+ ftp://hobbes.nmsu.edu/os2/unix/emx09c/
+
+The runtime component should have the name F<emxrt.zip>.
+
+B<NOTE>. It is enough to have F<emx.exe>/F<rsx.exe> on your path. One
+does not need to specify them explicitly (though this
+
+ emx perl_.exe -de 0
+
+will work as well.)
+
+=item RSX
+
+To run Perl on DPMI platforms one needs RSX runtime. This is
+needed under DOS-inside-OS/2, Win0.3*, Win0.95 and WinNT (see
+L<"Other OSes">). RSX would not work with VCPI
+only, as EMX would, it requires DMPI.
+
+Having RSX and the latest F<sh.exe> one gets a fully functional
+B<*nix>-ish environment under DOS, say, C<fork>, C<``> and
+pipe-C<open> work. In fact, MakeMaker works (for static build), so one
+can have Perl development environment under DOS.
+
+One can get RSX from, say
+
+ ftp://ftp.cdrom.com/pub/os2/emx09c/contrib
+ ftp://ftp.uni-bielefeld.de/pub/systems/msdos/misc
+ ftp://ftp.leo.org/pub/comp/os/os2/leo/devtools/emx+gcc/contrib
+
+Contact the author on C<rainer@mathematik.uni-bielefeld.de>.
+
+The latest F<sh.exe> with DOS hooks is available at
+
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2/sh_dos.zip
+
+=item HPFS
+
+Perl does not care about file systems, but to install the whole perl
+library intact one needs a file system which supports long file names.
+
+Note that if you do not plan to build the perl itself, it may be
+possible to fool EMX to truncate file names. This is not supported,
+read EMX docs to see how to do it.
+
+=item pdksh
+
+To start external programs with complicated command lines (like with
+pipes in between, and/or quoting of arguments), Perl uses an external
+shell. With EMX port such shell should be named <sh.exe>, and located
+either in the wired-in-during-compile locations (usually F<F:/bin>),
+or in configurable location (see L<"PERL_SH_DIR">).
+
+For best results use EMX pdksh. The soon-to-be-available standard
+binary (5.2.12?) runs under DOS (with L<RSX>) as well, meanwhile use
+the binary from
+
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2/sh_dos.zip
+
+=back
+
+=head2 Starting Perl programs under OS/2 (and DOS and...)
+
+Start your Perl program F<foo.pl> with arguments C<arg1 arg2 arg3> the
+same way as on any other platform, by
+
+ perl foo.pl arg1 arg2 arg3
+
+If you want to specify perl options C<-my_opts> to the perl itself (as
+opposed to to your program), use
+
+ perl -my_opts foo.pl arg1 arg2 arg3
+
+Alternately, if you use OS/2-ish shell, like CMD or 4os2, put
+the following at the start of your perl script:
+
+ extproc perl -S -my_opts
+
+rename your program to F<foo.cmd>, and start it by typing
+
+ foo arg1 arg2 arg3
+
+Note that because of stupid OS/2 limitations the full path of the perl
+script is not available when you use C<extproc>, thus you are forced to
+use C<-S> perl switch, and your script should be on path. As a plus
+side, if you know a full path to your script, you may still start it
+with
+
+ perl ../../blah/foo.cmd arg1 arg2 arg3
+
+(note that the argument C<-my_opts> is taken care of by the C<extproc> line
+in your script, see L<C<extproc> on the first line>).
+
+To understand what the above I<magic> does, read perl docs about C<-S>
+switch - see L<perlrun>, and cmdref about C<extproc>:
+
+ view perl perlrun
+ man perlrun
+ view cmdref extproc
+ help extproc
+
+or whatever method you prefer.
+
+There are also endless possibilities to use I<executable extensions> of
+4os2, I<associations> of WPS and so on... However, if you use
+*nixish shell (like F<sh.exe> supplied in the binary distribution),
+you need to follow the syntax specified in L<perlrun/"Switches">.
+
+Note that B<-S> switch enables a search with additional extensions
+F<.cmd>, F<.btm>, F<.bat>, F<.pl> as well.
+
+=head2 Starting OS/2 (and DOS) programs under Perl
+
+This is what system() (see L<perlfunc/system>), C<``> (see
+L<perlop/"I/O Operators">), and I<open pipe> (see L<perlfunc/open>)
+are for. (Avoid exec() (see L<perlfunc/exec>) unless you know what you
+do).
+
+Note however that to use some of these operators you need to have a
+sh-syntax shell installed (see L<"Pdksh">,
+L<"Frequently asked questions">), and perl should be able to find it
+(see L<"PERL_SH_DIR">).
+
+The only cases when the shell is not used is the multi-argument
+system() (see L<perlfunc/system>)/exec() (see L<perlfunc/exec>), and
+one-argument version thereof without redirection and shell
+meta-characters.
+
+=head1 Frequently asked questions
+
+=head2 I cannot run external programs
+
+=over 4
+
+=item
+
+Did you run your programs with C<-w> switch? See
+L<Starting OS/2 (and DOS) programs under Perl>.
+
+=item
+
+Do you try to run I<internal> shell commands, like C<`copy a b`>
+(internal for F<cmd.exe>), or C<`glob a*b`> (internal for ksh)? You
+need to specify your shell explicitly, like C<`cmd /c copy a b`>,
+since Perl cannot deduce which commands are internal to your shell.
+
+=back
+
+=head2 I cannot embed perl into my program, or use F<perl.dll> from my
+program.
+
+=over 4
+
+=item Is your program EMX-compiled with C<-Zmt -Zcrtdll>?
+
+If not, you need to build a stand-alone DLL for perl. Contact me, I
+did it once. Sockets would not work, as a lot of other stuff.
+
+=item Did you use L<ExtUtils::Embed>?
+
+I had reports it does not work. Somebody would need to fix it.
+
+=back
+
+=head2 C<``> and pipe-C<open> do not work under DOS.
+
+This may a variant of just L<"I cannot run external programs">, or a
+deeper problem. Basically: you I<need> RSX (see L<"Prerequisites">)
+for these commands to work, and you may need a port of F<sh.exe> which
+understands command arguments. One of such ports is listed in
+L<"Prerequisites"> under RSX. Do not forget to set variable
+C<L<"PERL_SH_DIR">> as well.
+
+DPMI is required for RSX.
+
+=head2 Cannot start C<find.exe "pattern" file>
+
+Use one of
+
+ system 'cmd', '/c', 'find "pattern" file';
+ `cmd /c 'find "pattern" file'`
+
+This would start F<find.exe> via F<cmd.exe> via C<sh.exe> via
+C<perl.exe>, but this is a price to pay if you want to use
+non-conforming program. In fact F<find.exe> cannot be started at all
+using C library API only. Otherwise the following command-lines were
+equivalent:
+
+ find "pattern" file
+ find pattern file
+
+=head1 INSTALLATION
+
+=head2 Automatic binary installation
+
+The most convenient way of installing perl is via perl installer
+F<install.exe>. Just follow the instructions, and 99% of the
+installation blues would go away.
+
+Note however, that you need to have F<unzip.exe> on your path, and
+EMX environment I<running>. The latter means that if you just
+installed EMX, and made all the needed changes to F<Config.sys>,
+you may need to reboot in between. Check EMX runtime by running
+
+ emxrev
+
+A folder is created on your desktop which contains some useful
+objects.
+
+B<Things not taken care of by automatic binary installation:>
+
+=over 15
+
+=item C<PERL_BADLANG>
+
+may be needed if you change your codepage I<after> perl installation,
+and the new value is not supported by EMX. See L<"PERL_BADLANG">.
+
+=item C<PERL_BADFREE>
+
+see L<"PERL_BADFREE">.
+
+=item F<Config.pm>
+
+This file resides somewhere deep in the location you installed your
+perl library, find it out by
+
+ perl -MConfig -le "print $INC{'Config.pm'}"
+
+While most important values in this file I<are> updated by the binary
+installer, some of them may need to be hand-edited. I know no such
+data, please keep me informed if you find one.
+
+=back
+
+B<NOTE>. Because of a typo the binary installer of 5.00305
+would install a variable C<PERL_SHPATH> into F<Config.sys>. Please
+remove this variable and put C<L<PERL_SH_DIR>> instead.
+
+=head2 Manual binary installation
+
+As of version 5.00305, OS/2 perl binary distribution comes split
+into 11 components. Unfortunately, to enable configurable binary
+installation, the file paths in the zip files are not absolute, but
+relative to some directory.
+
+Note that the extraction with the stored paths is still necessary
+(default with unzip, specify C<-d> to pkunzip). However, you
+need to know where to extract the files. You need also to manually
+change entries in F<Config.sys> to reflect where did you put the
+files. Note that if you have some primitive unzipper (like
+pkunzip), you may get a lot of warnings/errors during
+unzipping. Upgrade to C<(w)unzip>.
+
+Below is the sample of what to do to reproduce the configuration on my
+machine:
+
+=over 3
+
+=item Perl VIO and PM executables (dynamically linked)
+
+ unzip perl_exc.zip *.exe *.ico -d f:/emx.add/bin
+ unzip perl_exc.zip *.dll -d f:/emx.add/dll
+
+(have the directories with C<*.exe> on PATH, and C<*.dll> on
+LIBPATH);
+
+=item Perl_ VIO executable (statically linked)
+
+ unzip perl_aou.zip -d f:/emx.add/bin
+
+(have the directory on PATH);
+
+=item Executables for Perl utilities
+
+ unzip perl_utl.zip -d f:/emx.add/bin
+
+(have the directory on PATH);
+
+=item Main Perl library
+
+ unzip perl_mlb.zip -d f:/perllib/lib
+
+If this directory is preserved, you do not need to change
+anything. However, for perl to find it if it is changed, you need to
+C<set PERLLIB_PREFIX> in F<Config.sys>, see L<"PERLLIB_PREFIX">.
+
+=item Additional Perl modules
+
+ unzip perl_ste.zip -d f:/perllib/lib/site_perl
+
+If you do not change this directory, do nothing. Otherwise put this
+directory and subdirectory F<./os2> in C<PERLLIB> or C<PERL5LIB>
+variable. Do not use C<PERL5LIB> unless you have it set already. See
+L<perl/"ENVIRONMENT">.
+
+=item Tools to compile Perl modules
+
+ unzip perl_blb.zip -d f:/perllib/lib
+
+If this directory is preserved, you do not need to change
+anything. However, for perl to find it if it is changed, you need to
+C<set PERLLIB_PREFIX> in F<Config.sys>, see L<"PERLLIB_PREFIX">.
+
+=item Manpages for Perl and utilities
+
+ unzip perl_man.zip -d f:/perllib/man
+
+This directory should better be on C<MANPATH>. You need to have a
+working man to access these files.
+
+=item Manpages for Perl modules
+
+ unzip perl_mam.zip -d f:/perllib/man
+
+This directory should better be on C<MANPATH>. You need to have a
+working man to access these files.
+
+=item Source for Perl documentation
+
+ unzip perl_pod.zip -d f:/perllib/lib
+
+This is used by by C<perldoc> program (see L<perldoc>), and may be used to
+generate HTML documentation usable by WWW browsers, and
+documentation in zillions of other formats: C<info>, C<LaTeX>,
+C<Acrobat>, C<FrameMaker> and so on.
+
+=item Perl manual in F<.INF> format
+
+ unzip perl_inf.zip -d d:/os2/book
+
+This directory should better be on C<BOOKSHELF>.
+
+=item Pdksh
+
+ unzip perl_sh.zip -d f:/bin
+
+This is used by perl to run external commands which explicitly
+require shell, like the commands using I<redirection> and I<shell
+metacharacters>. It is also used instead of explicit F</bin/sh>.
+
+Set C<PERL_SH_DIR> (see L<"PERL_SH_DIR">) if you move F<sh.exe> from
+the above location.
+
+B<Note.> It may be possible to use some other sh-compatible shell
+(I<not tested>).
+
+=back
+
+After you installed the components you needed and updated the
+F<Config.sys> correspondingly, you need to hand-edit
+F<Config.pm>. This file resides somewhere deep in the location you
+installed your perl library, find it out by
+
+ perl -MConfig -le "print $INC{'Config.pm'}"
+
+You need to correct all the entries which look like file paths (they
+currently start with C<f:/>).
+
+=head2 B<Warning>
+
+The automatic and manual perl installation leave precompiled paths
+inside perl executables. While these paths are overwriteable (see
+L<"PERLLIB_PREFIX">, L<"PERL_SH_DIR">), one may get better results by
+binary editing of paths inside the executables/DLLs.
+
+=head1 Accessing documentation
+
+Depending on how you built/installed perl you may have (otherwise
+identical) Perl documentation in the following formats:
+
+=head2 OS/2 F<.INF> file
+
+Most probably the most convenient form. Under OS/2 view it as
+
+ view perl
+ view perl perlfunc
+ view perl less
+ view perl ExtUtils::MakeMaker
+
+(currently the last two may hit a wrong location, but this may improve
+soon). Under Win* see L<"SYNOPSIS">.
+
+If you want to build the docs yourself, and have I<OS/2 toolkit>, run
+
+ pod2ipf > perl.ipf
+
+in F</perllib/lib/pod> directory, then
+
+ ipfc /inf perl.ipf
+
+(Expect a lot of errors during the both steps.) Now move it on your
+BOOKSHELF path.
+
+=head2 Plain text
+
+If you have perl documentation in the source form, perl utilities
+installed, and GNU groff installed, you may use
+
+ perldoc perlfunc
+ perldoc less
+ perldoc ExtUtils::MakeMaker
+
+to access the perl documentation in the text form (note that you may get
+better results using perl manpages).
+
+Alternately, try running pod2text on F<.pod> files.
+
+=head2 Manpages
+
+If you have man installed on your system, and you installed perl
+manpages, use something like this:
+
+ man perlfunc
+ man 3 less
+ man ExtUtils.MakeMaker
+
+to access documentation for different components of Perl. Start with
+
+ man perl
+
+Note that dot (F<.>) is used as a package separator for documentation
+for packages, and as usual, sometimes you need to give the section - C<3>
+above - to avoid shadowing by the I<less(1) manpage>.
+
+Make sure that the directory B<above> the directory with manpages is
+on our C<MANPATH>, like this
+
+ set MANPATH=c:/man;f:/perllib/man
+
+=head2 HTML
+
+If you have some WWW browser available, installed the Perl
+documentation in the source form, and Perl utilities, you can build
+HTML docs. Cd to directory with F<.pod> files, and do like this
+
+ cd f:/perllib/lib/pod
+ pod2html
+
+After this you can direct your browser the file F<perl.html> in this
+directory, and go ahead with reading docs, like this:
+
+ explore file:///f:/perllib/lib/pod/perl.html
+
+Alternatively you may be able to get these docs prebuilt from CPAN.
+
+=head2 GNU C<info> files
+
+Users of Emacs would appreciate it very much, especially with
+C<CPerl> mode loaded. You need to get latest C<pod2info> from C<CPAN>,
+or, alternately, prebuilt info pages.
+
+=head2 F<.PDF> files
+
+for C<Acrobat> are available on CPAN (for slightly old version of
+perl).
+
+=head2 C<LaTeX> docs
+
+can be constructed using C<pod2latex>.
+
+=head1 BUILD
+
+Here we discuss how to build Perl under OS/2. There is an alternative
+(but maybe older) view on L<http://www.shadow.net/~troc/os2perl.html>.
+
+=head2 Prerequisites
+
+You need to have the latest EMX development environment, the full
+GNU tool suite (gawk renamed to awk, and GNU F<find.exe>
+earlier on path than the OS/2 F<find.exe>, same with F<sort.exe>, to
+check use
+
+ find --version
+ sort --version
+
+). You need the latest version of F<pdksh> installed as F<sh.exe>.
+
+Possible locations to get this from are
+
+ ftp://hobbes.nmsu.edu/os2/unix/
+ ftp://ftp.cdrom.com/pub/os2/unix/
+ ftp://ftp.cdrom.com/pub/os2/dev32/
+ ftp://ftp.cdrom.com/pub/os2/emx09c/
+
+It is reported that the following archives contain enough utils to
+build perl: gnufutil.zip, gnusutil.zip, gnututil.zip, gnused.zip,
+gnupatch.zip, gnuawk.zip, gnumake.zip and ksh527rt.zip. Note that
+all these utilities are known to be available from LEO:
+
+ ftp://ftp.leo.org/pub/comp/os/os2/leo/gnu
+
+Make sure that no copies or perl are currently running. Later steps
+of the build may fail since an older version of perl.dll loaded into
+memory may be found.
+
+Also make sure that you have F</tmp> directory on the current drive,
+and F<.> directory in your C<LIBPATH>. One may try to correct the
+latter condition by
+
+ set BEGINLIBPATH .
+
+if you use something like F<CMD.EXE> or latest versions of F<4os2.exe>.
+
+Make sure your gcc is good for C<-Zomf> linking: run C<omflibs>
+script in F</emx/lib> directory.
+
+Check that you have link386 installed. It comes standard with OS/2,
+but may be not installed due to customization. If typing
+
+ link386
+
+shows you do not have it, do I<Selective install>, and choose C<Link
+object modules> in I<Optional system utilities/More>. If you get into
+link386, press C<Ctrl-C>.
+
+=head2 Getting perl source
+
+You need to fetch the latest perl source (including developers
+releases). With some probability it is located in
+
+ http://www.perl.com/CPAN/src/5.0
+ http://www.perl.com/CPAN/src/5.0/unsupported
+
+If not, you may need to dig in the indices to find it in the directory
+of the current maintainer.
+
+Quick cycle of developers release may break the OS/2 build time to
+time, looking into
+
+ http://www.perl.com/CPAN/ports/os2/ilyaz/
+
+may indicate the latest release which was publicly released by the
+maintainer. Note that the release may include some additional patches
+to apply to the current source of perl.
+
+Extract it like this
+
+ tar vzxf perl5.00409.tar.gz
+
+You may see a message about errors while extracting F<Configure>. This is
+because there is a conflict with a similarly-named file F<configure>.
+
+Change to the directory of extraction.
+
+=head2 Application of the patches
+
+You need to apply the patches in F<./os2/diff.*> and
+F<./os2/POSIX.mkfifo> like this:
+
+ gnupatch -p0 < os2\POSIX.mkfifo
+ gnupatch -p0 < os2\diff.configure
+
+You may also need to apply the patches supplied with the binary
+distribution of perl.
+
+Note also that the F<db.lib> and F<db.a> from the EMX distribution
+are not suitable for multi-threaded compile (note that currently perl
+is not multithread-safe, but is compiled as multithreaded for
+compatibility with XFree86-OS/2). Get a corrected one from
+
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2/db_mt.zip
+
+=head2 Hand-editing
+
+You may look into the file F<./hints/os2.sh> and correct anything
+wrong you find there. I do not expect it is needed anywhere.
+
+=head2 Making
+
+ sh Configure -des -D prefix=f:/perllib
+
+C<prefix> means: where to install the resulting perl library. Giving
+correct prefix you may avoid the need to specify C<PERLLIB_PREFIX>,
+see L<"PERLLIB_PREFIX">.
+
+I<Ignore the message about missing C<ln>, and about C<-c> option to
+tr>. In fact if you can trace where the latter spurious warning
+comes from, please inform me.
+
+Now
+
+ make
+
+At some moment the built may die, reporting a I<version mismatch> or
+I<unable to run F<perl>>. This means that most of the build has been
+finished, and it is the time to move the constructed F<perl.dll> to
+some I<absolute> location in LIBPATH. After this is done the build
+should finish without a lot of fuss. I<One can avoid the interruption
+if one has the correct prebuilt version of F<perl.dll> on LIBPATH, but
+probably this is not needed anymore, since F<miniperl.exe> is linked
+statically now.>
+
+Warnings which are safe to ignore: I<mkfifo() redefined> inside
+F<POSIX.c>.
+
+=head2 Testing
+
+Now run
+
+ make test
+
+Some tests (4..6) should fail. Some perl invocations should end in a
+segfault (system error C<SYS3175>). To get finer error reports,
+
+ cd t
+ perl harness
+
+The report you get may look like
+
+ Failed Test Status Wstat Total Fail Failed List of failed
+ ---------------------------------------------------------------
+ io/fs.t 26 11 42.31% 2-5, 7-11, 18, 25
+ lib/io_pipe.t 3 768 6 ?? % ??
+ lib/io_sock.t 3 768 5 ?? % ??
+ op/stat.t 56 5 8.93% 3-4, 20, 35, 39
+ Failed 4/140 test scripts, 97.14% okay. 27/2937 subtests failed, 99.08% okay.
+
+Note that using `make test' target two more tests may fail: C<op/exec:1>
+because of (mis)feature of pdksh, and C<lib/posix:15>, which checks
+that the buffers are not flushed on C<_exit> (this is a bug in the test
+which assumes that tty output is buffered).
+
+I submitted a patch to EMX which makes it possible to fork() with EMX
+dynamic libraries loaded, which makes F<lib/io*> tests pass. This means
+that soon the number of failing tests may decrease yet more.
+
+However, the test F<lib/io_udp.t> is disabled, since it never terminates, I
+do not know why. Comments/fixes welcome.
+
+The reasons for failed tests are:
+
+=over 8
+
+=item F<io/fs.t>
+
+Checks I<file system> operations. Tests:
+
+=over 10
+
+=item 2-5, 7-11
+
+Check C<link()> and C<inode count> - nonesuch under OS/2.
+
+=item 18
+
+Checks C<atime> and C<mtime> of C<stat()> - I could not understand this test.
+
+=item 25
+
+Checks C<truncate()> on a filehandle just opened for write - I do not
+know why this should or should not work.
+
+=back
+
+=item F<lib/io_pipe.t>
+
+Checks C<IO::Pipe> module. Some feature of EMX - test fork()s with
+dynamic extension loaded - unsupported now.
+
+=item F<lib/io_sock.t>
+
+Checks C<IO::Socket> module. Some feature of EMX - test fork()s
+with dynamic extension loaded - unsupported now.
+
+=item F<op/stat.t>
+
+Checks C<stat()>. Tests:
+
+=over 4
+
+=item 3
+
+Checks C<inode count> - nonesuch under OS/2.
+
+=item 4
+
+Checks C<mtime> and C<ctime> of C<stat()> - I could not understand this test.
+
+=item 20
+
+Checks C<-x> - determined by the file extension only under OS/2.
+
+=item 35
+
+Needs F</usr/bin>.
+
+=item 39
+
+Checks C<-t> of F</dev/null>. Should not fail!
+
+=back
+
+=back
+
+In addition to errors, you should get a lot of warnings.
+
+=over 4
+
+=item A lot of `bad free'
+
+in databases related to Berkeley DB. This is a confirmed bug of
+DB. You may disable this warnings, see L<"PERL_BADFREE">.
+
+=item Process terminated by SIGTERM/SIGINT
+
+This is a standard message issued by OS/2 applications. *nix
+applications die in silence. It is considered a feature. One can
+easily disable this by appropriate sighandlers.
+
+However the test engine bleeds these message to screen in unexpected
+moments. Two messages of this kind I<should> be present during
+testing.
+
+=item F<*/sh.exe>: ln: not found
+
+=item C<ls>: /dev: No such file or directory
+
+The last two should be self-explanatory. The test suite discovers that
+the system it runs on is not I<that much> *nixish.
+
+=back
+
+A lot of `bad free'... in databases, bug in DB confirmed on other
+platforms. You may disable it by setting PERL_BADFREE environment variable
+to 1.
+
+=head2 Installing the built perl
+
+Run
+
+ make install
+
+It would put the generated files into needed locations. Manually put
+F<perl.exe>, F<perl__.exe> and F<perl___.exe> to a location on your
+PATH, F<perl.dll> to a location on your LIBPATH.
+
+Run
+
+ make cmdscripts INSTALLCMDDIR=d:/ir/on/path
+
+to convert perl utilities to F<.cmd> files and put them on
+PATH. You need to put F<.EXE>-utilities on path manually. They are
+installed in C<$prefix/bin>, here C<$prefix> is what you gave to
+F<Configure>, see L<Making>.
+
+=head2 C<a.out>-style build
+
+Proceed as above, but make F<perl_.exe> (see L<"perl_.exe">) by
+
+ make perl_
+
+test and install by
+
+ make aout_test
+ make aout_install
+
+Manually put F<perl_.exe> to a location on your PATH.
+
+Since C<perl_> has the extensions prebuilt, it does not suffer from
+the I<dynamic extensions + fork()> syndrome, thus the failing tests
+look like
+
+ Failed Test Status Wstat Total Fail Failed List of failed
+ ---------------------------------------------------------------
+ io/fs.t 26 11 42.31% 2-5, 7-11, 18, 25
+ op/stat.t 56 5 8.93% 3-4, 20, 35, 39
+ Failed 2/118 test scripts, 98.31% okay. 16/2445 subtests failed, 99.35% okay.
+
+B<Note.> The build process for C<perl_> I<does not know> about all the
+dependencies, so you should make sure that anything is up-to-date,
+say, by doing
+
+ make perl.dll
+
+first.
+
+=head1 Build FAQ
+
+=head2 Some C</> became C<\> in pdksh.
+
+You have a very old pdksh. See L<Prerequisites>.
+
+=head2 C<'errno'> - unresolved external
+
+You do not have MT-safe F<db.lib>. See L<Prerequisites>.
+
+=head2 Problems with tr
+
+reported with very old version of tr.
+
+=head2 Some problem (forget which ;-)
+
+You have an older version of F<perl.dll> on your LIBPATH, which
+broke the build of extensions.
+
+=head2 Library ... not found
+
+You did not run C<omflibs>. See L<Prerequisites>.
+
+=head2 Segfault in make
+
+You use an old version of GNU make. See L<Prerequisites>.
+
+=head1 Specific (mis)features of OS/2 port
+
+=head2 C<setpriority>, C<getpriority>
+
+Note that these functions are compatible with *nix, not with the older
+ports of '94 - 95. The priorities are absolute, go from 32 to -95,
+lower is quicker. 0 is the default priority.
+
+=head2 C<system()>
+
+Multi-argument form of C<system()> allows an additional numeric
+argument. The meaning of this argument is described in
+L<OS2::Process>.
+
+=head2 C<extproc> on the first line
+
+If the first chars of a script are C<"extproc ">, this line is treated
+as C<#!>-line, thus all the switches on this line are processed (twice
+if script was started via cmd.exe).
+
+=head2 Additional modules:
+
+L<OS2::Process>, L<OS2::REXX>, L<OS2::PrfDB>, L<OS2::ExtAttr>. This
+modules provide access to additional numeric argument for C<system>,
+to DLLs having functions with REXX signature and to REXX runtime, to
+OS/2 databases in the F<.INI> format, and to Extended Attributes.
+
+Two additional extensions by Andreas Kaiser, C<OS2::UPM>, and
+C<OS2::FTP>, are included into my ftp directory, mirrored on CPAN.
+
+=head2 Prebuilt methods:
+
+=over 4
+
+=item C<File::Copy::syscopy>
+
+used by C<File::Copy::copy>, see L<File::Copy>.
+
+=item C<DynaLoader::mod2fname>
+
+used by C<DynaLoader> for DLL name mangling.
+
+=item C<Cwd::current_drive()>
+
+Self explanatory.
+
+=item C<Cwd::sys_chdir(name)>
+
+leaves drive as it is.
+
+=item C<Cwd::change_drive(name)>
+
+
+=item C<Cwd::sys_is_absolute(name)>
+
+means has drive letter and is_rooted.
+
+=item C<Cwd::sys_is_rooted(name)>
+
+means has leading C<[/\\]> (maybe after a drive-letter:).
+
+=item C<Cwd::sys_is_relative(name)>
+
+means changes with current dir.
+
+=item C<Cwd::sys_cwd(name)>
+
+Interface to cwd from EMX. Used by C<Cwd::cwd>.
+
+=item C<Cwd::sys_abspath(name, dir)>
+
+Really really odious function to implement. Returns absolute name of
+file which would have C<name> if CWD were C<dir>. C<Dir> defaults to the
+current dir.
+
+=item C<Cwd::extLibpath([type])
+
+Get current value of extended library search path. If C<type> is
+present and I<true>, works with END_LIBPATH, otherwise with
+C<BEGIN_LIBPATH>.
+
+=item C<Cwd::extLibpath_set( path [, type ] )>
+
+Set current value of extended library search path. If C<type> is
+present and I<true>, works with END_LIBPATH, otherwise with
+C<BEGIN_LIBPATH>.
+
+=back
+
+(Note that some of these may be moved to different libraries -
+eventually).
+
+
+=head2 Misfeatures
+
+=over 4
+
+=item
+
+Since L<flock(3)> is present in EMX, but is not functional, it is
+emulated by perl. To disable the emulations, set environment variable
+C<USE_PERL_FLOCK=0>.
+
+=item
+
+Here is the list of things which may be "broken" on
+EMX (from EMX docs):
+
+=over
+
+=item *
+
+The functions L<recvmsg(3)>, L<sendmsg(3)>, and L<socketpair(3)> are not
+implemented.
+
+=item *
+
+L<sock_init(3)> is not required and not implemented.
+
+=item *
+
+L<flock(3)> is not yet implemented (dummy function). (Perl has a workaround.)
+
+=item *
+
+L<kill(3)>: Special treatment of PID=0, PID=1 and PID=-1 is not implemented.
+
+=item *
+
+L<waitpid(3)>:
+
+ WUNTRACED
+ Not implemented.
+ waitpid() is not implemented for negative values of PID.
+
+=back
+
+Note that C<kill -9> does not work with the current version of EMX.
+
+=item
+
+Since F<sh.exe> is used for globing (see L<perlfunc/glob>), the bugs
+of F<sh.exe> plague perl as well.
+
+In particular, uppercase letters do not work in C<[...]>-patterns with
+the current pdksh.
+
+=back
+
+=head2 Modifications
+
+Perl modifies some standard C library calls in the following ways:
+
+=over 9
+
+=item C<popen>
+
+C<my_popen> uses F<sh.exe> if shell is required, cf. L<"PERL_SH_DIR">.
+
+=item C<tmpnam>
+
+is created using C<TMP> or C<TEMP> environment variable, via
+C<tempnam>.
+
+=item C<tmpfile>
+
+If the current directory is not writable, file is created using modified
+C<tmpnam>, so there may be a race condition.
+
+=item C<ctermid>
+
+a dummy implementation.
+
+=item C<stat>
+
+C<os2_stat> special-cases F</dev/tty> and F</dev/con>.
+
+=item C<flock>
+
+Since L<flock(3)> is present in EMX, but is not functional, it is
+emulated by perl. To disable the emulations, set environment variable
+C<USE_PERL_FLOCK=0>.
+
+=back
+
+=head1 Perl flavors
+
+Because of idiosyncrasies of OS/2 one cannot have all the eggs in the
+same basket (though EMX environment tries hard to overcome this
+limitations, so the situation may somehow improve). There are 4
+executables for Perl provided by the distribution:
+
+=head2 F<perl.exe>
+
+The main workhorse. This is a chimera executable: it is compiled as an
+C<a.out>-style executable, but is linked with C<omf>-style dynamic
+library F<perl.dll>, and with dynamic CRT DLL. This executable is a
+VIO application.
+
+It can load perl dynamic extensions, and it can fork(). Unfortunately,
+with the current version of EMX it cannot fork() with dynamic
+extensions loaded (may be fixed by patches to EMX).
+
+B<Note.> Keep in mind that fork() is needed to open a pipe to yourself.
+
+=head2 F<perl_.exe>
+
+This is a statically linked C<a.out>-style executable. It can fork(),
+but cannot load dynamic Perl extensions. The supplied executable has a
+lot of extensions prebuilt, thus there are situations when it can
+perform tasks not possible using F<perl.exe>, like fork()ing when
+having some standard extension loaded. This executable is a VIO
+application.
+
+B<Note.> A better behaviour could be obtained from C<perl.exe> if it
+were statically linked with standard I<Perl extensions>, but
+dynamically linked with the I<Perl DLL> and CRT DLL. Then it would
+be able to fork() with standard extensions, I<and> would be able to
+dynamically load arbitrary extensions. Some changes to Makefiles and
+hint files should be necessary to achieve this.
+
+I<This is also the only executable with does not require OS/2.> The
+friends locked into C<M$> world would appreciate the fact that this
+executable runs under DOS, Win0.3*, Win0.95 and WinNT with an
+appropriate extender. See L<"Other OSes">.
+
+=head2 F<perl__.exe>
+
+This is the same executable as F<perl___.exe>, but it is a PM
+application.
+
+B<Note.> Usually STDIN, STDERR, and STDOUT of a PM
+application are redirected to C<nul>. However, it is possible to see
+them if you start C<perl__.exe> from a PM program which emulates a
+console window, like I<Shell mode> of Emacs or EPM. Thus it I<is
+possible> to use Perl debugger (see L<perldebug>) to debug your PM
+application.
+
+This flavor is required if you load extensions which use PM, like
+the forthcoming C<Perl/Tk>.
+
+=head2 F<perl___.exe>
+
+This is an C<omf>-style executable which is dynamically linked to
+F<perl.dll> and CRT DLL. I know no advantages of this executable
+over C<perl.exe>, but it cannot fork() at all. Well, one advantage is
+that the build process is not so convoluted as with C<perl.exe>.
+
+It is a VIO application.
+
+=head2 Why strange names?
+
+Since Perl processes the C<#!>-line (cf.
+L<perlrun/DESCRIPTION>, L<perlrun/Switches>,
+L<perldiag/"Not a perl script">,
+L<perldiag/"No Perl script found in input">), it should know when a
+program I<is a Perl>. There is some naming convention which allows
+Perl to distinguish correct lines from wrong ones. The above names are
+almost the only names allowed by this convention which do not contain
+digits (which have absolutely different semantics).
+
+=head2 Why dynamic linking?
+
+Well, having several executables dynamically linked to the same huge
+library has its advantages, but this would not substantiate the
+additional work to make it compile. The reason is stupid-but-quick
+"hard" dynamic linking used by OS/2.
+
+The address tables of DLLs are patched only once, when they are
+loaded. The addresses of entry points into DLLs are guaranteed to be
+the same for all programs which use the same DLL, which reduces the
+amount of runtime patching - once DLL is loaded, its code is
+read-only.
+
+While this allows some performance advantages, this makes life
+terrible for developers, since the above scheme makes it impossible
+for a DLL to be resolved to a symbol in the .EXE file, since this
+would need a DLL to have different relocations tables for the
+executables which use it.
+
+However, a Perl extension is forced to use some symbols from the perl
+executable, say to know how to find the arguments provided on the perl
+internal evaluation stack. The solution is that the main code of
+interpreter should be contained in a DLL, and the F<.EXE> file just loads
+this DLL into memory and supplies command-arguments.
+
+This I<greatly> increases the load time for the application (as well as
+the number of problems during compilation). Since interpreter is in a DLL,
+the CRT is basically forced to reside in a DLL as well (otherwise
+extensions would not be able to use CRT).
+
+=head2 Why chimera build?
+
+Current EMX environment does not allow DLLs compiled using Unixish
+C<a.out> format to export symbols for data. This forces C<omf>-style
+compile of F<perl.dll>.
+
+Current EMX environment does not allow F<.EXE> files compiled in
+C<omf> format to fork(). fork() is needed for exactly three Perl
+operations:
+
+=over 4
+
+=item explicit fork()
+
+in the script, and
+
+=item open FH, "|-"
+
+=item open FH, "-|"
+
+opening pipes to itself.
+
+=back
+
+While these operations are not questions of life and death, a lot of
+useful scripts use them. This forces C<a.out>-style compile of
+F<perl.exe>.
+
+
+=head1 ENVIRONMENT
+
+Here we list environment variables with are either OS/2- and DOS- and
+Win*-specific, or are more important under OS/2 than under other OSes.
+
+=head2 C<PERLLIB_PREFIX>
+
+Specific for EMX port. Should have the form
+
+ path1;path2
+
+or
+
+ path1 path2
+
+If the beginning of some prebuilt path matches F<path1>, it is
+substituted with F<path2>.
+
+Should be used if the perl library is moved from the default
+location in preference to C<PERL(5)LIB>, since this would not leave wrong
+entries in @INC. Say, if the compiled version of perl looks for @INC
+in F<f:/perllib/lib>, and you want to install the library in
+F<h:/opt/gnu>, do
+
+ set PERLLIB_PREFIX=f:/perllib/lib;h:/opt/gnu
+
+=head2 C<PERL_BADLANG>
+
+If 1, perl ignores setlocale() failing. May be useful with some
+strange I<locale>s.
+
+=head2 C<PERL_BADFREE>
+
+If 1, perl would not warn of in case of unwarranted free(). May be
+useful in conjunction with the module DB_File, since Berkeley DB
+memory handling code is buggy.
+
+=head2 C<PERL_SH_DIR>
+
+Specific for EMX port. Gives the directory part of the location for
+F<sh.exe>.
+
+=head2 C<USE_PERL_FLOCK>
+
+Specific for EMX port. Since L<flock(3)> is present in EMX, but is not
+functional, it is emulated by perl. To disable the emulations, set
+environment variable C<USE_PERL_FLOCK=0>.
+
+=head2 C<TMP> or C<TEMP>
+
+Specific for EMX port. Used as storage place for temporary files, most
+notably C<-e> scripts.
+
+=head1 Evolution
+
+Here we list major changes which could make you by surprise.
+
+=head2 Priorities
+
+C<setpriority> and C<getpriority> are not compatible with earlier
+ports by Andreas Kaiser. See C<"setpriority, getpriority">.
+
+=head2 DLL name mangling
+
+With the release 5.003_01 the dynamically loadable libraries
+should be rebuilt. In particular, DLLs are now created with the names
+which contain a checksum, thus allowing workaround for OS/2 scheme of
+caching DLLs.
+
+=head2 Threading
+
+As of release 5.003_01 perl is linked to multithreaded CRT
+DLL. Perl itself is not multithread-safe, as is not perl
+malloc(). However, extensions may use multiple thread on their own
+risk.
+
+Needed to compile C<Perl/Tk> for XFree86-OS/2 out-of-the-box.
+
+=head2 Calls to external programs
+
+Due to a popular demand the perl external program calling has been
+changed wrt Andreas Kaiser's port. I<If> perl needs to call an
+external program I<via shell>, the F<f:/bin/sh.exe> will be called, or
+whatever is the override, see L<"PERL_SH_DIR">.
+
+Thus means that you need to get some copy of a F<sh.exe> as well (I
+use one from pdksh). The drive F: above is set up automatically during
+the build to a correct value on the builder machine, but is
+overridable at runtime,
+
+B<Reasons:> a consensus on C<perl5-porters> was that perl should use
+one non-overridable shell per platform. The obvious choices for OS/2
+are F<cmd.exe> and F<sh.exe>. Having perl build itself would be impossible
+with F<cmd.exe> as a shell, thus I picked up C<sh.exe>. Thus assures almost
+100% compatibility with the scripts coming from *nix. As an added benefit
+this works as well under DOS if you use DOS-enabled port of pdksh
+(see L<"Prerequisites">).
+
+B<Disadvantages:> currently F<sh.exe> of pdksh calls external programs
+via fork()/exec(), and there is I<no> functioning exec() on
+OS/2. exec() is emulated by EMX by asyncroneous call while the caller
+waits for child completion (to pretend that the C<pid> did not change). This
+means that 1 I<extra> copy of F<sh.exe> is made active via fork()/exec(),
+which may lead to some resources taken from the system (even if we do
+not count extra work needed for fork()ing).
+
+Note that this a lesser issue now when we do not spawn F<sh.exe>
+unless needed (metachars found).
+
+One can always start F<cmd.exe> explicitly via
+
+ system 'cmd', '/c', 'mycmd', 'arg1', 'arg2', ...
+
+If you need to use F<cmd.exe>, and do not want to hand-edit thousands of your
+scripts, the long-term solution proposed on p5-p is to have a directive
+
+ use OS2::Cmd;
+
+which will override system(), exec(), C<``>, and
+C<open(,'...|')>. With current perl you may override only system(),
+readpipe() - the explicit version of C<``>, and maybe exec(). The code
+will substitute the one-argument call to system() by
+C<CORE::system('cmd.exe', '/c', shift)>.
+
+If you have some working code for C<OS2::Cmd>, please send it to me,
+I will include it into distribution. I have no need for such a module, so
+cannot test it.
+
+=head2 Memory allocation
+
+Perl uses its own malloc() under OS/2 - interpreters are usually malloc-bound
+for speed, but perl is not, since its malloc is lightning-fast.
+Unfortunately, it is also quite frivolous with memory usage as well.
+
+Since kitchen-top machines are usually low on memory, perl is compiled with
+all the possible memory-saving options. This probably makes perl's
+malloc() as greedy with memory as the neighbor's malloc(), but still
+much quickier. Note that this is true only for a "typical" usage,
+it is possible that the perl malloc will be worse for some very special usage.
+
+Combination of perl's malloc() and rigid DLL name resolution creates
+a special problem with library functions which expect their return value to
+be free()d by system's free(). To facilitate extensions which need to call
+such functions, system memory-allocation functions are still available with
+the prefix C<emx_> added. (Currently only DLL perl has this, it should
+propagate to F<perl_.exe> shortly.)
+
+=cut
+
+OS/2 extensions
+~~~~~~~~~~~~~~~
+I include 3 extensions by Andreas Kaiser, OS2::REXX, OS2::UPM, and OS2::FTP,
+into my ftp directory, mirrored on CPAN. I made
+some minor changes needed to compile them by standard tools. I cannot
+test UPM and FTP, so I will appreciate your feedback. Other extensions
+there are OS2::ExtAttr, OS2::PrfDB for tied access to EAs and .INI
+files - and maybe some other extensions at the time you read it.
+
+Note that OS2 perl defines 2 pseudo-extension functions
+OS2::Copy::copy and DynaLoader::mod2fname (many more now, see
+L<Prebuilt methods>).
+
+The -R switch of older perl is deprecated. If you need to call a REXX code
+which needs access to variables, include the call into a REXX compartment
+created by
+ REXX_call {...block...};
+
+Two new functions are supported by REXX code,
+ REXX_eval 'string';
+ REXX_eval_with 'string', REXX_function_name => \&perl_sub_reference;
+
+If you have some other extensions you want to share, send the code to
+me. At least two are available: tied access to EA's, and tied access
+to system databases.
+
+=head1 AUTHOR
+
+Ilya Zakharevich, ilya@math.ohio-state.edu
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
+
diff --git a/gnu/usr.bin/perl/README.plan9 b/gnu/usr.bin/perl/README.plan9
new file mode 100644
index 00000000000..f10f1d9b920
--- /dev/null
+++ b/gnu/usr.bin/perl/README.plan9
@@ -0,0 +1,27 @@
+WELCOME to Plan 9 Perl, brave soul!
+ This is a preliminary alpha version of Plan 9 Perl. Still to be implemented are MakeMaker and DynaLoader. Many perl commands are missing or currently behave in an inscrutable manner. These gaps will, with perserverance and a modicum of luck, be remedied in the near future.To install this software:
+
+ 1. Create the source directories and libraries for perl by running the plan9/setup.rc command (i.e., located in the plan9 subdirectory). Note: the setup routine assumes that you haven't dearchived these files into /sys/src/cmd/perl. After running setup.rc you may delete the copy of the source you originally detarred, as source code has now been installed in /sys/src/cmd/perl. If you plan on installing perl binaries for all architectures, run "setup.rc -a".
+After
+ 2. Making sure that you have adequate privileges to build system software, from /sys/src/cmd/perl/5.00301 run:
+mk install
+ If you wish to install perl versions for all architectures (68020, mips, sparc and 386) run:
+mk installall
+
+ 3. Wait. The build process will take a *long* time because perl bootstraps itself. A 75MHz Pentium, 16MB RAM machine takes roughly 30 minutes to build the distribution from scratch.
+
+INSTALLING DOCUMENTATION
+This perl distribution comes with a tremendous amount of documentation. To add these to the built-in manuals that come with Plan 9, from /sys/src/cmd/perl/5.00301 run:
+mk man
+To begin your reading, start with:
+man perl
+This is a good introduction and will direct you towards other man pages that may interest you. For information specific to Plan 9 Perl, try:
+man perlplan9
+
+(Note: "mk man" may produce some extraneous noise. Fear not.)
+
+Direct questions, comments, and the unlikely bug report (ahem) direct comments toward:
+lutherh@stratcom.com
+
+Luther Huffman
+Strategic Computer Solutions, Inc.
diff --git a/gnu/usr.bin/perl/README.qnx b/gnu/usr.bin/perl/README.qnx
new file mode 100644
index 00000000000..0cfe3533cac
--- /dev/null
+++ b/gnu/usr.bin/perl/README.qnx
@@ -0,0 +1,22 @@
+README.qnx
+
+Please see hints/qnx.sh for more detailed information about compiling
+perl under QNX4.
+
+The files in the "qnx" directory are:
+
+ * "qnx/ar" is a script that emulates the standard unix archive (aka
+ library) utility. Under Watcom 10.6, ar is linked to wlib and
+ provides the expected interface. With Watcom 9.5, a cover function
+ is required. This one is fairly crude but has proved adequate for
+ compiling perl. A more thorough version is available at:
+
+ http://www.fdma.com/pub/qnx/porting/ar
+
+ * "qnx/cpp" is a script that provides C preprocessing functionality.
+ Configure can generate a similar cover, but it doesn't handle all
+ the command-line options that perl throws at it. This might be
+ reasonably placed in /usr/local/bin.
+
+--
+Norton T. Allen (allen@huarp.harvard.edu)
diff --git a/gnu/usr.bin/perl/README.vms b/gnu/usr.bin/perl/README.vms
index ba0ba190fd7..4b8c29d3458 100644
--- a/gnu/usr.bin/perl/README.vms
+++ b/gnu/usr.bin/perl/README.vms
@@ -1,3 +1,383 @@
+Last Revised 11-September-1997 by Dan Sugalski <sugalsd@lbcc.cc.or.us>
+Originally by Charles Bailey <bailey@newman.upenn.edu>
+
+* Intro
+
+The VMS port of Perl is as functionally complete as any other Perl port
+(and as complete as the ports on some Unix systems). The Perl binaries
+provide all the Perl system calls that are either available under VMS or
+reasonably emulated. There are some incompatibilites in process handling
+(e.g the fork/exec model for creating subprocesses doesn't do what you
+might expect under Unix), mainly because VMS and Unix handle processes and
+sub-processes very differently.
+
+There are still some unimplemented system functions, and of coursse we
+could use modules implementing useful VMS system services, so if you'd like
+to lend a hand we'd love to have you. Join the Perl Porting Team Now!
+
+The current sources and build procedures have been tested on a VAX using
+VaxC and Dec C, and on an AXP using Dec C. If you run into problems with
+other compilers, please let us know.
+
+There are issues with varions versions of Dec C, so if you're not running a
+relatively modern version, check the Dec C issues section later on in this
+document.
+
+* Other required software
+
+In addition to VMS, you'll need:
+ 1) A C compiler. Dec C for AXP, or VAX C, Dec C, or gcc for the
+ VAX.
+ 2) A make tool. Dec's MMS (v2.6 or later), or MadGoat's free MMS
+ analog MMK (available from ftp.madgoat.com/madgoat) both work
+ just fine. Gnu Make might work, but it's been so long since
+ anyone's tested it that we're not sure. MMK's free, though, so
+ go ahead and use that.
+
+
+If you want to include socket support, you'll need a TCP stack and either
+Dec C, or socket libraries. See the Socket Support topic for more details.
+
+* Compiling Perl
+
+>From the top level of the Perl source directory, do this:
+
+MMS/DESCRIP=[.VMS]DESCRIP.MMS
+
+If you're on an Alpha, add /Macro=("__AXP__=1","decc=1")
+If you're using Dec C as your C compiler (you are on all alphas), add
+/Macro=("decc=1")
+If Vac C is your default C compiler and you want to use Dec C, add
+/Macro=("CC=CC/DECC") (Don't forget the /macro=("decc=1")
+If Dec C is your default C compiler and you want to use Vax C, add
+/Macro=("CC=CC/VAXC")
+If you want Socket support and are using the SOCKETSHR socket library, add
+/Macro=("SOCKETSHR_SOCKETS=1")
+If you want Socket support and are using the Dec C RTL socket interface
+(You must be using Dec C for this), add /Macro=("DECC_SOCKETS=1")
+
+If you have multiple /macro= items, combine them together in one /Macro=()
+switch, with all the options inside the parentheses separated by commas.
+
+Samples:
+
+VMS AXP, with Socketshr sockets:
+
+$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("decc=1","__AXP__=1","SOCKETSHR_SOCKETS=1")
+
+VMS AXP with no sockets
+
+$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("decc=1","__AXP__=1")
+
+VMS AXP with the Dec C RTL sockets
+
+$MMS/DESCRIP=[.VMS]/Macro=("decc=1","__AXP__=1","DECC_SOCKETS=1")
+
+VMS VAX with default system compiler, no sockets
+
+$MMS/DESCRIP=[.VMS]DESCRIP.MMS
+
+VMS VAX with Dec C compiler, no sockets
+
+$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("CC=CC/DECC","decc=1")
+
+VMS VAX with Dec C compiler, Dec C RTL sockets
+
+$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("CC=CC/DECC","decc=1","DECC_SOCKETS=1")
+
+VMS VAX with Dec C compiler, Socketshr sockets
+
+$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("CC=CC/DECC","decc=1","SOCKETSHR_SOCKETS=1")
+
+Using Dec C is recommended over Vax C. The compiler is newer, and
+supported. (Vax C was decommisioned around 1993) Various older versions had
+some gotchas, so if you're using a version older than 5.2, check the Dec C
+Issues section.
+
+We'll also point out that Dec C will get you at least a ten-fold increase
+in line-oriented IO over Vax C. The optimizer is amazingly better, too. If
+you can use Dec C, then you *really*, *really* should.
+
+
+Once you issue your MMS command, sit back and wait. Perl should build and
+link without a problem. If it doesn't, check the Gotchas to watch out for
+section. If that doesn't help, send some mail to the VMSPERL mailing list.
+Instructions are in the Mailing Lists section.
+
+* Testing Perl
+
+Once Perl has built cleanly, you need to test it to make sure things work.
+This step is very important--there are always things that can go wrong
+somehow and get you a dysfunctional Perl.
+
+Testing is very easy, though, as there's a full test suite in the perl
+distribution. To run the tests, enter the *exact* MMS line you used to
+compile Perl and add the word "test" to the end, like this:
+
+Compile Command:
+
+$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("__AXP__=1","decc=1","DECCRTL_SOCKETS=1")
+
+Test Command:
+
+$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("__AXP__=1","decc=1","DECCRTL_SOCKETS=1") test
+
+MMS will run all the tests. This may take some time, as there are a lot of
+tests. If any tests fail, there will be a note made on-screen. At the end
+of all the tests, a summary of the tests, the number passed and failed, and
+the time taken will be displayed.
+
+If any tests fail, it means something's wrong with Perl. If the test suite
+hangs (some tests can take upwards of two or three minutes, or more if
+you're on an especially slow machine, depending on you machine speed, so
+don't be hasty), then the test *after* the last one displayed failed. Don't
+install Perl unless you're confident that you're OK. Regardless of how
+confident you are, make a bug report to the VMSPerl mailing list.
+
+If one or more tests fail, you can get more info on the failure by issuing
+this command sequence:
+
+$ SET DEFAULT [.T]
+$ @[-.VMS]TEST .typ -v [.subdir]test.T
+
+where ".typ" is the file type of the Perl images you just built (if you
+didn't do anything special, use .EXE), and "[.subdir]test.T" is the test
+that failed. For example, with a normal Perl build, if the test indicated
+that [.op]time failed, then you'd do this:
+
+$ SET DEFAULT [.T]
+$ @[-.VMS]TEST .EXE -v [.OP]TIME.T
+
+When you send in a bug report for failed tests, please include the output
+from this command, which is run from the main source directory:
+
+MCR []MINIPERL "-V"
+
+Note that "-V" really is a capital V in double quotes. This will dump out a
+couple of screens worth of config info, and can help us diagnose the problem.
+
+* Cleaning up and starting fresh
+
+If you need to recompile from scratch, you have to make sure you clean up
+first. There's a procedure to do it--enter the *exact* MMS line you used to
+compile and add "realclean" at the end, like this:
+
+Compile Command:
+
+$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("__AXP__=1","decc=1","DECCRTL_SOCKETS=1")
+
+Cleanup Command:
+
+$MMS/DESCRIP=[.VMS]DESCRIP.MMS/Macro=("__AXP__=1","decc=1","DECCRTL_SOCKETS=1") realclean
+
+If you don't do this, things may behave erratically. They might not, too,
+so it's best to be sure and do it.
+
+* Installing Perl
+
+There are several steps you need to take to get Perl installed and
+running. At some point we'll have a working install in DESCRIP.MMS, but for
+right now the procedure's manual, and goes like this.
+
+1) Create a directory somewhere and define the concealed logical PERL_ROOT
+to point to it. For example, DEFINE/TRANS=(CONC,TERM) PERL_ROOT dka200:[perl.]
+
+2) Copy perl.exe into PERL_ROOT:[000000]
+
+3) Copy everything in [.LIB] and [.UTILS] (including all the
+subdirectories!) to PERL_ROOT:[LIB] and PERL_ROOT:[UTILS].
+
+4) Either copy PERLSHR.EXE to SYS$SHARE, or to somewhere globally accessble
+and define the logical PERLSHR to point to it (DEFINE PERLSHR
+PERL_ROOT:[000000]PERLSHR.EXE or something like that). The PerlShr image
+should have W:RE protections on it. (Just W:E triggers increased security in
+the image activator. Not a huge problem, but Perl will need to have any
+other shared image it accesses INSTALLed. It's a huge pain, so don't unless
+you know what you're doing)
+
+5) Either define the symbol PERL somewhere, such as
+SYS$MANAGER:SYLOGIN.COM, to be "PERL :== $PERL_ROOT:[000000]PERL.EXE", or
+install Perl into DCLTABLES.EXE )Check out the section "Installing Perl
+into DCLTABLES" for more info), or put the image in a directory that's in
+your DCL$PATH (if you're using VMS 6.2 or higher).
+
+6) Optionally define the command PERLDOC as
+PERLDOC :== $PERL_ROOT:[000000]PERL PERL_ROOT:[LIB.POD]PERLDOC.COM -T
+
+7) Optionally define the command PERLBUG (the Perl bug report generator) as
+PERLBUG :== $PERL_ROOT:[000000]PERL PERL_ROOT:[LIB]PERLBUG.COM"
+
+* Installing Perl into DCLTABLES
+
+Courtesy of Brad Hughes:
+
+Put the following, modified to reflect where your .exe is, in PERL.CLD:
+
+define verb perl
+image perl_root:[exe]perl.exe
+cliflags (foreign)
+
+and then
+
+$ set command perl /table=sys$common:[syslib]dcltables.exe -
+ /output=sys$common:[syslib]dcltables.exe
+$ install replace sys$common:[syslib]dcltables.exe
+
+and you don't need perl :== $perl_root:[exe]perl.exe.
+
+* Changing compile-time things
+
+Most of the user-definable features of Perl are enabled or disabled in
+[.VMS]CONFIG.VMS. There's code in there to Do The Right Thing, but that may
+end up being the wrong thing for you. Make sure you understand what you're
+doing, since changes here can get you a busted perl.
+
+Odds are that there's nothing here to change, unless you're on a version of
+VMS later than 6.2 and Dec C later than 5.6. Even if you are, the correct
+values will still be chosen, most likely. Poking around here should be
+unnecessary.
+
+The one exception is the various *DIR install locations. Changing those
+requires changes in genconfig.pl as well. Be really careful if you need to
+change these,a s they can cause some fairly subtle problems.
+
+* Extra things in the Perl distribution
+
+In addition to the standard stuff that gets installed, there are two
+optional extensions, DCLSYM and STDIO, that are handy. Instructions for
+these two modules are in [.VMS.EXT.DCLSYM] and [.VMS.EXT.STDIO],
+respectively.
+
+* Socket Support
+
+Perl includes a number of functions for IP sockets, which are available if
+you choose to compile Perl with socket support. (See the section Compiling
+Perl for more info on selecting a socket stack) Since IP networking is an
+optional addition to VMS, there are several different IP stacks
+available. How well integrated they are into the system depends on the
+stack, your version of VMS, and the version of your C compiler.
+
+The most portable solution uses the SOCKETSHR library. In combination with
+either UCX or NetLib, this supports all the major TCP stacks (Multinet,
+Pathways, TCPWare, UCX, and CMU) on all versions of VMS Perl runs on, with
+all the compilers on both VAX and Alpha. The socket interface is also
+consistent across versions of VMS and C compilers. It has a problem with
+UDP sockets when used with Multinet, though, so you should be aware of
+that.
+
+The other solution available is to use the socket routines built into Dec
+C. Which routines are available depend on the version of VMS you're
+running, and require proper UCX emulation by your TCP/IP vendor.
+Relatively current versions of Multinet, TCPWare, Pathway, and UCX all
+provide the required libraries--check your manuals or release notes to see
+if your version is new enough.
+
+* Reporting Bugs
+
+If you come across what you think might be a bug in Perl, please report
+it. There's a script in PERL_ROOT:[UTILS], perlbug, that walks you through
+the process of creating a bug report. This script includes details of your
+installation, and is very handy. Completed bug reports should go to
+PERLBUG@PERL.COM.
+
+* Gotchas to watch out for
+
+Probably the single biggest gotcha in compiling Perl is giving the wrong
+switches to MMS/MMK when you build. If Perl's building oddly, double-check
+your switches. If you're on a VAX, be sure to add a /Macro=("decc=1") if
+you're using Dec C, and if you're on an alpha and using MMS, you'll need a
+/Macro=("__AXP__=1")
+
+The next big gotcha is directory depth. Perl can create directories four
+and five levels deep during the build, so you don't have to be too deep to
+start to hit the RMS 8 level point. It's best to do a
+$DEFINE/TRANS=(CONC,TERM) PERLSRC disk:[dir.dir.dir.perldir.]" (note the
+trailing period) and $SET DEFAULT PERLSRC:[000000] before building. Perl
+modules can be just as bad (or worse), so watch out for them, too.
+
+Finally, the third thing that bites people is leftover pieces from a failed
+build. If things go wrong, make sure you do a "(MMK|MMS|make) realclean"
+before you rebuild.
+
+* Dec C issues
+
+Note to DECC users: Some early versions (pre-5.2, some pre-4. If you're Dec
+C 5.x or higher, with current patches if anym you're fine) of the DECCRTL
+contained a few bugs which affect Perl performance:
+ - Newlines are lost on I/O through pipes, causing lines to run together.
+ This shows up as RMS RTB errors when reading from a pipe. You can
+ work around this by having one process write data to a file, and
+ then having the other read the file, instead of the pipe. This is
+ fixed in version 4 of DECC.
+ - The modf() routine returns a non-integral value for some values above
+ INT_MAX; the Perl "int" operator will return a non-integral value in
+ these cases. This is fixed in version 4 of DECC.
+ - On the AXP, if SYSNAM privilege is enabled, the CRTL chdir() routine
+ changes the process default device and directory permanently, even
+ though the call specified that the change should not persist after
+ Perl exited. This is fixed by DEC CSC patch AXPACRT04_061.
+
+* Mailing Lists
+
+There are several mailing lists available to the Perl porter. For VMS
+specific issues (including both Perl questions and installation problems)
+there is the VMSPERL mailing list. It's usually a low-volume (10-12
+messages a week) mailing list.
+
+The subscription address is VMSPERL-REQUEST@NEWMAN.UPENN.EDU. Send a mail
+message with just the words SUBSCRIBE VMSPERL in the body of the message.
+
+The VMSPERL mailing list address is VMSPERL@NEWMAN.UPENN.EDU. Any mail
+sent there gets echoed to all subscribers of the list.
+
+The Perl5-Porters list is for anyone involved in porting Perl to a
+platform. This includes you, if you want to participate. It's a high-volume
+list (60-100 messages a day during active development times), so be sure
+you want to be there. The subscription address is
+Perl5-Porters-request@perl.org. Send a message with just the word SUBSCRIBE
+in the body. The posting address is Perl5-Porters@perl.org.
+
+* Acknowledgements
+
+A real big thanks needs to go to Charles Bailey
+<bailey@newman.upenn.edu>, who is ultimately responsible for Perl 5.004
+running on VMS. Without him, nothing the rest of us have done would be at
+all important.
+
+There are, of course, far too many people involved in the porting and testing
+of Perl to mention everyone who deserves it, so please forgive us if we've
+missed someone. That said, special thanks are due to the following:
+ Tim Adye <T.J.Adye@rl.ac.uk>
+ for the VMS emulations of getpw*()
+ David Denholm <denholm@conmat.phys.soton.ac.uk>
+ for extensive testing and provision of pipe and SocketShr code,
+ Mark Pizzolato <mark@infocomm.com>
+ for the getredirection() code
+ Rich Salz <rsalz@bbn.com>
+ for readdir() and related routines
+ Peter Prymmer <pvhp@lns62.lns.cornell.edu)
+ for extensive testing, as well as development work on
+ configuration and documentation for VMS Perl,
+ Dan Sugalski <sugalsd@stargate.lbcc.cc.or.us>
+ for extensive contributions to recent version support,
+ development of VMS-specific extensions, and dissemination
+ of information about VMS Perl,
+ the Stanford Synchrotron Radiation Laboratory and the
+ Laboratory of Nuclear Studies at Cornell University for
+ the the opportunity to test and develop for the AXP,
+and to the entire VMSperl group for useful advice and suggestions. In
+addition the perl5-porters deserve credit for their creativity and
+willingness to work with the VMS newcomers. Finally, the greatest debt of
+gratitude is due to Larry Wall <larry@wall.org>, for having the ideas which
+have made our sleepless nights possible.
+
+Thanks,
+The VMSperl group
+
+
+---------------------------------------------------------------------------
+[Here's the pre-5.004_04 version of README.vms, for the record.]
+
Last revised: 19-Jan-1996 by Charles Bailey bailey@genetics.upenn.edu
The VMS port of Perl is still under development. At this time, the Perl
@@ -292,10 +672,10 @@ of to the Perl bug reporting address, perlbug@perl.com.
* For more information
-If you're interested in more information on Perl in general, consult the Usenet
-newsgroups comp.lang.perl.announce and comp.lang.perl.misc. The FAQ for these
-groups provides pointers to other online sources of information, as well as
-books describing Perl in depth.
+If you're interested in more information on Perl in general, you may wish to
+consult the Usenet newsgroups comp.lang.perl.announce and comp.lang.perl.misc.
+The FAQ for these groups provides pointers to other online sources of
+information, as well as books describing Perl in depth.
If you're interested in up-to-date information on Perl development and
internals, you might want to subscribe to the perl5-porters mailing list. You
@@ -305,11 +685,12 @@ subscribe perl5-porters
This is a high-volume list at the moment (>50 messages/day).
If you're interested in ongoing information about the VMS port, you can
-subscribe to the VMSperl mailing list by sending a request to
-bailey@genetics.upenn.edu (it's to a human, not a list server - this is a small
-operation at the moment). And, as always, we welcome any help or code you'd
+subscribe to the VMSPerl mailing list by sending a request to
+vmsperl-request@genetics.upenn.edu, containing the single line
+subscribe VMSPerl
+as the body of the message. And, as always, we welcome any help or code you'd
like to offer - you can send mail to bailey@genetics.upenn.edu or directly to
-the VMSperl list at vmsperl@genetics.upenn.edu.
+the VMSPerl list at vmsperl@genetics.upenn.edu.
Finally, if you'd like to try out the latest changes to VMS Perl, you can
retrieve a test distribution kit by anonymous ftp from genetics.upenn.edu, in
@@ -341,14 +722,17 @@ missed someone. That said, special thanks are due to the following:
for the getredirection() code
Rich Salz <rsalz@bbn.com>
for readdir() and related routines
- Richard Dyson <dyson@blaze.physics.uiowa.edu> and
- Kent Covert <kacovert@miavx1.acs.muohio.edu>
- for additional testing on the AXP.
+ Peter Prymmer <pvhp@lns62.lns.cornell.edu)
+ for extensive testing, as well as development work on
+ configuration and documentation for VMS Perl,
+ the Stanford Synchrotron Radiation Laboratory and the
+ Laboratory of Nuclear Studies at Cornell University for
+ the the opportunity to test and develop for the AXP,
and to the entire VMSperl group for useful advice and suggestions. In addition
the perl5-porters, especially Andy Dougherty <doughera@lafcol.lafayette.edu>
and Tim Bunce <Tim.Bunce@ig.co.uk>, deserve credit for their creativity and
willingness to work with the VMS newcomers. Finally, the greatest debt of
-gratitude is due to Larry Wall <lwall@sems.com>, for having the ideas which
+gratitude is due to Larry Wall <larry@wall.org>, for having the ideas which
have made our sleepless nights possible.
Thanks,
diff --git a/gnu/usr.bin/perl/README.win32 b/gnu/usr.bin/perl/README.win32
new file mode 100644
index 00000000000..1f8dd07f5f6
--- /dev/null
+++ b/gnu/usr.bin/perl/README.win32
@@ -0,0 +1,583 @@
+If you read this file _as_is_, just ignore the funny characters you
+see. It is written in the POD format (see pod/perlpod.pod) which is
+specially designed to be readable as is.
+
+=head1 NAME
+
+perlwin32 - Perl under Win32
+
+=head1 SYNOPSIS
+
+These are instructions for building Perl under Windows NT (versions
+3.51 or 4.0), using Visual C++ (versions 2.0 through 5.0) or Borland
+C++ (version 5.x). Currently, this port may also build under Windows95,
+but you can expect problems stemming from the unmentionable command
+shell that infests that platform. Note this caveat is only about
+B<building> perl. Once built, you should be able to B<use> it on
+either Win32 platform (modulo the problems arising from the inferior
+command shell).
+
+=head1 DESCRIPTION
+
+Before you start, you should glance through the README file
+found in the top-level directory where the Perl distribution
+was extracted. Make sure you read and understand the terms under
+which this software is being distributed.
+
+Also make sure you read L<BUGS AND CAVEATS> below for the
+known limitations of this port.
+
+The INSTALL file in the perl top-level has much information that is
+only relevant to people building Perl on Unix-like systems. In
+particular, you can safely ignore any information that talks about
+"Configure".
+
+You may also want to look at two other options for building
+a perl that will work on Windows NT: the README.cygwin32 and
+README.os2 files, which each give a different set of rules to build
+a Perl that will work on Win32 platforms. Those two methods will
+probably enable you to build a more Unix-compatible perl, but you
+will also need to download and use various other build-time and
+run-time support software described in those files.
+
+This set of instructions is meant to describe a so-called "native"
+port of Perl to Win32 platforms. The resulting Perl requires no
+additional software to run (other than what came with your operating
+system). Currently, this port is capable of using either the
+Microsoft Visual C++ compiler, or the Borland C++ compiler. The
+ultimate goal is to support the other major compilers that can
+generally be used to build Win32 applications.
+
+This port currently supports MakeMaker (the set of modules that
+is used to build extensions to perl). Therefore, you should be
+able to build and install most extensions found in the CPAN sites.
+See L<Usage Hints> below for general hints about this.
+
+=head2 Setting Up
+
+=over 4
+
+=item Command Shell
+
+Use the default "cmd" shell that comes with NT. In particular, do
+*not* use the 4DOS/NT shell. The Makefile has commands that are not
+compatible with that shell. The Makefile also has known
+incompatibilites with the default shell that comes with Windows95,
+so building under Windows95 should be considered "unsupported".
+
+=item Borland C++
+
+If you are using the Borland compiler, you will need dmake, a freely
+available make that has very nice macro features and parallelability.
+(The make that Borland supplies is seriously crippled, and will not
+work for MakeMaker builds--if you *have* to bug someone about this,
+I suggest you bug Borland to fix their make :)
+
+A port of dmake for win32 platforms is available from
+"http://www-personal.umich.edu/~gsar/dmake-4.0-win32.tar.gz".
+Fetch and install dmake somewhere on your path. Also make sure you
+copy the Borland dmake.ini file to some location where you keep
+*.ini files. If you use the binary that comes with the above port, you
+will need to set INIT in your environment to the directory where you
+put the dmake.ini file.
+
+=item Microsoft Visual C++
+
+The NMAKE that comes with Visual C++ will suffice for building.
+If you did not choose to always initialize the Visual C++ compilation
+environment variables when you installed Visual C++ on your system, you
+will need to run the VCVARS32.BAT file usually found somewhere like
+C:\MSDEV4.2\BIN. This will set your build environment.
+
+You can also use dmake to build using Visual C++, provided: you
+copied the dmake.ini for Visual C++; set INIT to point to the
+directory where you put it, as above; and edit win32/config.vc
+and change "make=nmake" to "make=dmake". The last step is only
+essential if you want to use dmake to be your default make for
+building extensions using MakeMaker.
+
+=item Permissions
+
+Depending on how you extracted the distribution, you have to make sure
+some of the files are writable by you. The easiest way to make sure of
+this is to execute:
+
+ attrib -R *.* /S
+
+from the perl toplevel directory. You don't I<have> to do this if you
+used the right tools to extract the files in the standard distribution,
+but it doesn't hurt to do so.
+
+=back
+
+=head2 Building
+
+=over 4
+
+=item *
+
+Make sure you are in the "win32" subdirectory under the perl toplevel.
+This directory contains a "Makefile" that will work with
+versions of NMAKE that come with Visual C++ ver. 2.0 and above, and
+a dmake "makefile.mk" that will work for both Borland and Visual C++
+builds. The defaults in the dmake makefile are setup to build using the
+Borland compiler.
+
+=item *
+
+Edit the Makefile (or makefile.mk, if using dmake) and change the values
+of INST_DRV and INST_TOP if you want perl to be installed in a location
+other than "C:\PERL". If you are using Visual C++ ver. 2.0, uncomment
+the line that sets "CCTYPE=MSVC20".
+
+You will also have to make sure CCHOME points to wherever you installed
+your compiler.
+
+=item *
+
+Type "nmake" (or "dmake" if you are using that make).
+
+This should build everything. Specifically, it will create perl.exe,
+perl.dll, and perlglob.exe at the perl toplevel, and various other
+extension dll's under the lib\auto directory. If the build fails for
+any reason, make sure you have done the previous steps correctly.
+
+The build process may produce "harmless" compiler warnings (more or
+less copiously, depending on how picky your compiler gets). The
+maintainers are aware of these warnings, thankyouverymuch. :)
+
+When building using Visual C++, a perl95.exe will also get built. This
+executable is only needed on Windows95, and should be used instead of
+perl.exe, and then only if you want sockets to work properly on Windows95.
+This is necessitated by a bug in the Microsoft C Runtime that cannot be
+worked around in the "normal" perl.exe. Again, if this bugs you, please
+bug Microsoft :). perl95.exe gets built with its own private copy of the
+C Runtime that is not accessible to extensions (which see the DLL version
+of the CRT). Be aware, therefore, that this perl95.exe will have
+esoteric problems with extensions like perl/Tk that themselves use the C
+Runtime heavily, or want to free() pointers malloc()-ed by perl.
+
+You can avoid the perl95.exe problems completely if you use Borland
+C++ for building perl (perl95.exe is not needed and will not be built
+in that case).
+
+=back
+
+=head2 Testing
+
+Type "nmake test" (or "dmake test"). This will run most of the tests from
+the testsuite (many tests will be skipped, and but no test should fail).
+
+If some tests do fail, it may be because you are using a different command
+shell than the native "cmd.exe".
+
+If you used the Borland compiler, you may see a failure in op/taint.t
+arising from the inability to find the Borland Runtime DLLs on the system
+default path. You will need to copy the DLLs reported by the messages
+from where Borland chose to install it, into the Windows system directory
+(usually somewhere like C:\WINNT\SYSTEM32), and rerun the test.
+
+Please report any other failures as described under L<BUGS AND CAVEATS>.
+
+=head2 Installation
+
+Type "nmake install" (or "dmake install"). This will put the newly
+built perl and the libraries under "C:\perl" (actually whatever you set
+C<INST_TOP> to in the Makefile). It will also install the pod
+documentation under C<$INST_TOP\lib\pod> and HTML versions of the same
+under C<$INST_TOP\lib\pod\html>. To use the Perl you just installed,
+set your PATH environment variable to "C:\perl\bin" (or C<$INST_TOP\bin>,
+if you changed the default as above).
+
+=head2 Usage Hints
+
+=over 4
+
+=item Environment Variables
+
+The installation paths that you set during the build get compiled
+into perl, so you don't have to do anything additional to start
+using that perl (except add its location to your PATH variable).
+
+If you put extensions in unusual places, you can set PERL5LIB
+to a list of paths separated by semicolons where you want perl
+to look for libraries. Look for descriptions of other environment
+variables you can set in the perlrun podpage.
+
+Sometime in the future, some of the configuration information
+for perl will be moved into the Windows registry.
+
+=item File Globbing
+
+By default, perl spawns an external program to do file globbing.
+The install process installs both a perlglob.exe and a perlglob.bat
+that perl can use for this purpose. Note that with the default
+installation, perlglob.exe will be found by the system before
+perlglob.bat.
+
+perlglob.exe relies on the argv expansion done by the C Runtime of
+the particular compiler you used, and therefore behaves very
+differently depending on the Runtime used to build it. To preserve
+compatiblity, perlglob.bat (a perl script/module that can be
+used portably) is installed. Besides being portable, perlglob.bat
+also offers enhanced globbing functionality.
+
+If you want perl to use perlglob.bat instead of perlglob.exe, just
+delete perlglob.exe from the install location (or move it somewhere
+perl cannot find). Using File::DosGlob.pm (which is the same
+as perlglob.bat) to override the internal CORE::glob() works about 10
+times faster than spawing perlglob.exe, and you should take this
+approach when writing new modules. See File::DosGlob for details.
+
+=item Using perl from the command line
+
+If you are accustomed to using perl from various command-line
+shells found in UNIX environments, you will be less than pleased
+with what Windows NT offers by way of a command shell.
+
+The crucial thing to understand about the "cmd" shell (which is
+the default on Windows NT) is that it does not do any wildcard
+expansions of command-line arguments (so wildcards need not be
+quoted). It also provides only rudimentary quoting. The only
+(useful) quote character is the double quote ("). It can be used to
+protect spaces in arguments and other special characters. The
+Windows NT documentation has almost no description of how the
+quoting rules are implemented, but here are some general observations
+based on experiments: The shell breaks arguments at spaces and
+passes them to programs in argc/argv. Doublequotes can be used
+to prevent arguments with spaces in them from being split up.
+You can put a double quote in an argument by escaping it with
+a backslash and enclosing the whole argument within double quotes.
+The backslash and the pair of double quotes surrounding the
+argument will be stripped by the shell.
+
+The file redirection characters "<", ">", and "|" cannot be quoted
+by double quotes (there are probably more such). Single quotes
+will protect those three file redirection characters, but the
+single quotes don't get stripped by the shell (just to make this
+type of quoting completely useless). The caret "^" has also
+been observed to behave as a quoting character (and doesn't get
+stripped by the shell also).
+
+Here are some examples of usage of the "cmd" shell:
+
+This prints two doublequotes:
+
+ perl -e "print '\"\"' "
+
+This does the same:
+
+ perl -e "print \"\\\"\\\"\" "
+
+This prints "bar" and writes "foo" to the file "blurch":
+
+ perl -e "print 'foo'; print STDERR 'bar'" > blurch
+
+This prints "foo" ("bar" disappears into nowhereland):
+
+ perl -e "print 'foo'; print STDERR 'bar'" 2> nul
+
+This prints "bar" and writes "foo" into the file "blurch":
+
+ perl -e "print 'foo'; print STDERR 'bar'" 1> blurch
+
+This pipes "foo" to the "less" pager and prints "bar" on the console:
+
+ perl -e "print 'foo'; print STDERR 'bar'" | less
+
+This pipes "foo\nbar\n" to the less pager:
+
+ perl -le "print 'foo'; print STDERR 'bar'" 2>&1 | less
+
+This pipes "foo" to the pager and writes "bar" in the file "blurch":
+
+ perl -e "print 'foo'; print STDERR 'bar'" 2> blurch | less
+
+
+Discovering the usefulness of the "command.com" shell on Windows95
+is left as an exercise to the reader :)
+
+=item Building Extensions
+
+The Comprehensive Perl Archive Network (CPAN) offers a wealth
+of extensions, some of which require a C compiler to build.
+Look in http://www.perl.com/ for more information on CPAN.
+
+Most extensions (whether they require a C compiler or not) can
+be built, tested and installed with the standard mantra:
+
+ perl Makefile.PL
+ $MAKE
+ $MAKE test
+ $MAKE install
+
+where $MAKE stands for NMAKE or DMAKE. Some extensions may not
+provide a testsuite (so "$MAKE test" may not do anything, or fail),
+but most serious ones do.
+
+If a module implements XSUBs, you will need one of the supported
+C compilers. You must make sure you have set up the environment for
+the compiler for command-line compilation.
+
+If a module does not build for some reason, look carefully for
+why it failed, and report problems to the module author. If
+it looks like the extension building support is at fault, report
+that with full details of how the build failed using the perlbug
+utility.
+
+=item Win32 Specific Extensions
+
+A number of extensions specific to the Win32 platform are available
+from CPAN. You may find that many of these extensions are meant to
+be used under the Activeware port of Perl, which used to be the only
+native port for the Win32 platform. Since the Activeware port does not
+have adequate support for Perl's extension building tools, these
+extensions typically do not support those tools either, and therefore
+cannot be built using the generic steps shown in the previous section.
+
+To ensure smooth transitioning of existing code that uses the
+Activeware port, there is a bundle of Win32 extensions that contains
+all of the Activeware extensions and most other Win32 extensions from
+CPAN in source form, along with many added bugfixes, and with MakeMaker
+support. This bundle is available at:
+
+ http://www.perl.com/CPAN/authors/id/GSAR/libwin32-0.08.tar.gz
+
+See the README in that distribution for building and installation
+instructions. Look for later versions that may be available at the
+same location.
+
+It is expected that authors of Win32 specific extensions will begin
+distributing their work in MakeMaker compatible form subsequent to
+the 5.004 release of perl, at which point the need for a dedicated
+bundle such as the above should diminish.
+
+=item Running Perl Scripts
+
+Perl scripts on UNIX use the "#!" (a.k.a "shebang") line to
+indicate to the OS that it should execute the file using perl.
+Win32 has no comparable means to indicate arbitrary files are
+executables.
+
+Instead, all available methods to execute plain text files on
+Win32 rely on the file "extension". There are three methods
+to use this to execute perl scripts:
+
+=over 8
+
+=item 1
+
+There is a facility called "file extension associations" that will
+work in Windows NT 4.0. This can be manipulated via the two
+commands "assoc" and "ftype" that come standard with Windows NT
+4.0. Type "ftype /?" for a complete example of how to set this
+up for perl scripts (Say what? You thought Windows NT wasn't
+perl-ready? :).
+
+=item 2
+
+Since file associations don't work everywhere, and there are
+reportedly bugs with file associations where it does work, the
+old method of wrapping the perl script to make it look like a
+regular batch file to the OS, may be used. The install process
+makes available the "pl2bat.bat" script which can be used to wrap
+perl scripts into batch files. For example:
+
+ pl2bat foo.pl
+
+will create the file "FOO.BAT". Note "pl2bat" strips any
+.pl suffix and adds a .bat suffix to the generated file.
+
+If you use the 4DOS/NT or similar command shell, note that
+"pl2bat" uses the "%*" variable in the generated batch file to
+refer to all the command line arguments, so you may need to make
+sure that construct works in batch files. As of this writing,
+4DOS/NT users will need a "ParameterChar = *" statement in their
+4NT.INI file, or will need to execute "setdos /p*" in the 4DOS/NT
+startup file to enable this to work.
+
+=item 3
+
+Using "pl2bat" has a few problems: the file name gets changed,
+so scripts that rely on C<$0> to find what they must do may not
+run properly; running "pl2bat" replicates the contents of the
+original script, and so this process can be maintenance intensive
+if the originals get updated often. A different approach that
+avoids both problems is possible.
+
+A script called "runperl.bat" is available that can be copied
+to any filename (along with the .bat suffix). For example,
+if you call it "foo.bat", it will run the file "foo" when it is
+executed. Since you can run batch files on Win32 platforms simply
+by typing the name (without the extension), this effectively
+runs the file "foo", when you type either "foo" or "foo.bat".
+With this method, "foo.bat" can even be in a different location
+than the file "foo", as long as "foo" is available somewhere on
+the PATH. If your scripts are on a filesystem that allows symbolic
+links, you can even avoid copying "runperl.bat".
+
+Here's a diversion: copy "runperl.bat" to "runperl", and type
+"runperl". Explain the observed behavior, or lack thereof. :)
+Hint: .gnidnats llits er'uoy fi ,"lrepnur" eteled :tniH
+
+=back
+
+=item Miscellaneous Things
+
+A full set of HTML documentation is installed, so you should be
+able to use it if you have a web browser installed on your
+system.
+
+C<perldoc> is also a useful tool for browsing information contained
+in the documentation, especially in conjunction with a pager
+like C<less> (recent versions of which have Win32 support). You may
+have to set the PAGER environment variable to use a specific pager.
+"perldoc -f foo" will print information about the perl operator
+"foo".
+
+If you find bugs in perl, you can run C<perlbug> to create a
+bug report (you may have to send it manually if C<perlbug> cannot
+find a mailer on your system).
+
+=back
+
+=head1 BUGS AND CAVEATS
+
+This port should be considered beta quality software at the present
+time because some details are still in flux and there may be
+changes in any of these areas: build process, installation structure,
+supported utilities/modules, and supported perl functionality.
+In particular, functionality specific to the Win32 environment may
+ultimately be supported as either core modules or extensions. The
+beta status implies, among other things, that you should be prepared
+to recompile extensions when binary incompatibilites arise due to
+changes in the internal structure of the code.
+
+An effort has been made to ensure that the DLLs produced by the two
+supported compilers are compatible with each other (despite the
+best efforts of the compiler vendors). Extension binaries produced
+by one compiler should also coexist with a perl binary built by
+a different compiler. In order to accomplish this, PERL.DLL provides
+a layer of runtime code that uses the C Runtime that perl was compiled
+with. Extensions which include "perl.h" will transparently access
+the functions in this layer, thereby ensuring that both perl and
+extensions use the same runtime functions.
+
+If you have had prior exposure to Perl on Unix platforms, you will notice
+this port exhibits behavior different from what is documented. Most of the
+differences fall under one of these categories. We do not consider
+any of them to be serious limitations (especially when compared to the
+limited nature of some of the Win32 OSes themselves :)
+
+=over 8
+
+=item *
+
+C<stat()> and C<lstat()> functions may not behave as documented. They
+may return values that bear no resemblance to those reported on Unix
+platforms, and some fields (like the the one for inode) may be completely
+bogus.
+
+=item *
+
+The following functions are currently unavailable: C<fork()>,
+C<dump()>, C<chown()>, C<link()>, C<symlink()>, C<chroot()>,
+C<setpgrp()>, C<getpgrp()>, C<setpriority()>, C<getpriority()>,
+C<syscall()>, C<fcntl()>. This list is possibly very incomplete.
+
+=item *
+
+crypt() is not available due to silly export restrictions. It may
+become available when the laws change. Meanwhile, look in CPAN for
+extensions that provide it.
+
+=item *
+
+Various C<socket()> related calls are supported, but they may not
+behave as on Unix platforms.
+
+=item *
+
+The four-argument C<select()> call is only supported on sockets.
+
+=item *
+
+C<$?> ends up with the exitstatus of the subprocess (this is different
+from Unix, where the exitstatus is actually given by "$? >> 8").
+Failure to spawn() the subprocess is indicated by setting $? to
+"255<<8". This is subject to change.
+
+=item *
+
+Building modules available on CPAN is mostly supported, but this
+hasn't been tested much yet. Expect strange problems, and be
+prepared to deal with the consequences.
+
+=item *
+
+C<utime()>, C<times()> and process-related functions may not
+behave as described in the documentation, and some of the
+returned values or effects may be bogus.
+
+=item *
+
+Signal handling may not behave as on Unix platforms (where it
+doesn't exactly "behave", either :). For instance, calling C<die()>
+or C<exit()> from signal handlers will cause an exception, since most
+implementations of C<signal()> on Win32 are severely crippled.
+Thus, signals may work only for simple things like setting a flag
+variable in the handler. Using signals under this port should
+currently be considered unsupported.
+
+=item *
+
+File globbing may not behave as on Unix platforms. In particular,
+if you don't use perlglob.bat for globbing, it will understand
+wildcards only in the filename component (and not in the pathname).
+In other words, something like "print <*/*.pl>" will not print all the
+perl scripts in all the subdirectories one level under the current one
+(like it does on UNIX platforms). perlglob.exe is also dependent on
+the particular implementation of wildcard expansion in the vendor
+libraries used to build it (which varies wildly at the present time).
+Using perlglob.bat (or File::DosGlob) avoids these limitations, but
+still only provides DOS semantics (read "warts") for globbing.
+
+=back
+
+Please send detailed descriptions of any problems and solutions that
+you may find to <F<perlbug@perl.com>>, along with the output produced
+by C<perl -V>.
+
+=head1 AUTHORS
+
+=over 4
+
+Gary Ng E<lt>71564.1743@CompuServe.COME<gt>
+
+Gurusamy Sarathy E<lt>gsar@umich.eduE<gt>
+
+Nick Ing-Simmons E<lt>nick@ni-s.u-net.comE<gt>
+
+=back
+
+This document is maintained by Gurusamy Sarathy.
+
+=head1 SEE ALSO
+
+L<perl>
+
+=head1 HISTORY
+
+This port was originally contributed by Gary Ng around 5.003_24,
+and borrowed from the Hip Communications port that was available
+at the time.
+
+Nick Ing-Simmons and Gurusamy Sarathy have made numerous and
+sundry hacks since then.
+
+Borland support was added in 5.004_01 (Gurusamy Sarathy).
+
+Last updated: 25 July 1997
+
+=cut
+
diff --git a/gnu/usr.bin/perl/Todo b/gnu/usr.bin/perl/Todo
index 114a488691e..627045c9520 100644
--- a/gnu/usr.bin/perl/Todo
+++ b/gnu/usr.bin/perl/Todo
@@ -5,27 +5,22 @@ Tie Modules
ShiftSplice Defines shift et al in terms of splice method
Would be nice to have
- Profiler
pack "(stuff)*"
Contiguous bitfields in pack/unpack
lexperl
Bundled perl preprocessor
Use posix calls internally where possible
- const variables
gettimeofday
- bytecompiler
format BOTTOM
- $obj->can("method") to probe method inheritance
-iprefix.
-i rename file only when successfully changed
All ARGV input should act like <>
- Multiple levels of warning
report HANDLE [formats].
- tie(FILEHANDLE, ...)
- __DATA__
support in perlmain to rerun debugger
- make 'r' print return value like gdb 'fini'
- regression tests using __WARN__ and __DIE__ hooks
+ regression tests using __DIE__ hook
+ reference to compiled regexp
+ lexically scoped functions: my sub foo { ... }
+ lvalue functions
Possible pragmas
debugger
@@ -43,25 +38,20 @@ Optimizations
Shrink opcode tables via multiple implementations selected in peep
Cache hash value? (Not a win, according to Guido)
Optimize away @_ where possible
- sfio?
"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
- Populate %SIG at startup if appropriate
data prettyprint function? (or is it, as I suspect, a lib routine?)
make tr/// return histogram in list context?
- undef wantarray in void context
Loop control on do{} et al
Explicit switch statements
- perl to C translator
- multi-thread scheduling
built-in globbing
compile to real threaded code
structured types
- paren counting in tokener to queue remote expectations
autocroak?
Modifiable $1 et al
substr EXPR,OFFSET,LENGTH,STRING
diff --git a/gnu/usr.bin/perl/XSUB.h b/gnu/usr.bin/perl/XSUB.h
index af452ea5d77..0b82a270b46 100644
--- a/gnu/usr.bin/perl/XSUB.h
+++ b/gnu/usr.bin/perl/XSUB.h
@@ -38,19 +38,22 @@
#ifdef XS_VERSION
# define XS_VERSION_BOOTCHECK \
- STMT_START { \
- char vn[255], *module = SvPV(ST(0),na); \
- if (items >= 2) /* version supplied as bootstrap arg */ \
- Sv=ST(1); \
- else { /* read version from module::VERSION */ \
- sprintf(vn,"%s::VERSION", module); \
- Sv = perl_get_sv(vn, FALSE); /* XXX GV_ADDWARN */ \
- } \
- if (Sv && (!SvOK(Sv) || strNE(XS_VERSION, SvPV(Sv,na))) ) \
- croak("%s object version %s does not match %s.pm $VERSION %s", \
- module,XS_VERSION, module,(Sv && SvOK(Sv))?SvPV(Sv,na):"(undef)");\
+ STMT_START { \
+ char *vn = "", *module = SvPV(ST(0),na); \
+ if (items >= 2) /* version supplied as bootstrap arg */ \
+ Sv = ST(1); \
+ else { \
+ /* XXX GV_ADDWARN */ \
+ Sv = perl_get_sv(form("%s::%s", module, \
+ vn = "XS_VERSION"), FALSE); \
+ if (!Sv || !SvOK(Sv)) \
+ Sv = perl_get_sv(form("%s::%s", module, \
+ vn = "VERSION"), FALSE); \
+ } \
+ if (Sv && (!SvOK(Sv) || strNE(XS_VERSION, SvPV(Sv, na)))) \
+ croak("%s object version %s does not match $%s::%s %_", \
+ module, XS_VERSION, module, vn, Sv); \
} STMT_END
#else
# define XS_VERSION_BOOTCHECK
#endif
-
diff --git a/gnu/usr.bin/perl/av.c b/gnu/usr.bin/perl/av.c
index b27ec762a63..4a87eaf2b51 100644
--- a/gnu/usr.bin/perl/av.c
+++ b/gnu/usr.bin/perl/av.c
@@ -1,6 +1,6 @@
/* av.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -15,15 +15,15 @@
#include "EXTERN.h"
#include "perl.h"
-static void av_reify _((AV* av));
-
-static void
+void
av_reify(av)
AV* av;
{
I32 key;
SV* sv;
-
+
+ if (AvREAL(av))
+ return;
key = AvMAX(av) + 1;
while (key > AvFILL(av) + 1)
AvARRAY(av)[--key] = &sv_undef;
@@ -33,6 +33,9 @@ AV* av;
if (sv != &sv_undef)
(void)SvREFCNT_inc(sv);
}
+ key = AvARRAY(av) - AvALLOC(av);
+ while (key)
+ AvALLOC(av)[--key] = &sv_undef;
AvREAL_on(av);
}
@@ -94,7 +97,7 @@ I32 key;
#endif
ary = AvALLOC(av) + AvMAX(av) + 1;
tmp = newmax - AvMAX(av);
- if (av == stack) { /* Oops, grew stack (via av_store()?) */
+ if (av == curstack) { /* Oops, grew stack (via av_store()?) */
stack_sp = AvALLOC(av) + (stack_sp - stack_base);
stack_base = AvALLOC(av);
stack_max = stack_base + newmax;
@@ -153,12 +156,19 @@ I32 lval;
return av_store(av,key,sv);
}
if (AvARRAY(av)[key] == &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] = &sv_undef; /* 1/2 reify */
+ goto emptyness;
+ }
return &AvARRAY(av)[key];
}
@@ -172,10 +182,13 @@ SV *val;
if (!av)
return 0;
+ if (!val)
+ val = &sv_undef;
if (SvRMAGICAL(av)) {
if (mg_find((SV*)av,'P')) {
- mg_copy((SV*)av, val, 0, key);
+ if (val != &sv_undef)
+ mg_copy((SV*)av, val, 0, key);
return 0;
}
}
@@ -185,18 +198,16 @@ SV *val;
if (key < 0)
return 0;
}
- if (!val)
- val = &sv_undef;
-
+ if (SvREADONLY(av) && key >= AvFILL(av))
+ croak(no_modify);
+ if (!AvREAL(av) && AvREIFY(av))
+ av_reify(av);
if (key > AvMAX(av))
av_extend(av,key);
- if (AvREIFY(av))
- av_reify(av);
-
ary = AvARRAY(av);
if (AvFILL(av) < key) {
if (!AvREAL(av)) {
- if (av == stack && key > stack_sp - stack_base)
+ if (av == curstack && key > stack_sp - stack_base)
stack_sp = stack_base + key; /* XPUSH in disguise */
do
ary[++AvFILL(av)] = &sv_undef;
@@ -242,17 +253,19 @@ register SV **strp;
av = (AV*)NEWSV(8,0);
sv_upgrade((SV *) av,SVt_PVAV);
- New(4,ary,size+1,SV*);
- AvALLOC(av) = ary;
AvFLAGS(av) = AVf_REAL;
- SvPVX(av) = (char*)ary;
- AvFILL(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++;
+ if (size) { /* `defined' was returning undef for size==0 anyway. */
+ New(4,ary,size,SV*);
+ AvALLOC(av) = ary;
+ SvPVX(av) = (char*)ary;
+ AvFILL(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;
}
@@ -289,6 +302,11 @@ register AV *av;
register I32 key;
SV** ary;
+#ifdef DEBUGGING
+ if (SvREFCNT(av) <= 0) {
+ warn("Attempt to clear deleted array");
+ }
+#endif
if (!av || AvMAX(av) < 0)
return;
/*SUPPRESS 560*/
@@ -306,6 +324,9 @@ register AV *av;
SvPVX(av) = (char*)AvALLOC(av);
}
AvFILL(av) = -1;
+
+ if (SvRMAGICAL(av))
+ mg_clear((SV*)av);
}
void
@@ -322,10 +343,6 @@ register AV *av;
while (key)
SvREFCNT_dec(AvARRAY(av)[--key]);
}
- if (key = AvARRAY(av) - AvALLOC(av)) {
- AvMAX(av) += key;
- SvPVX(av) = (char*)AvALLOC(av);
- }
Safefree(AvALLOC(av));
AvALLOC(av) = 0;
SvPVX(av) = 0;
@@ -354,6 +371,8 @@ register AV *av;
if (!av || AvFILL(av) < 0)
return &sv_undef;
+ if (SvREADONLY(av))
+ croak(no_modify);
retval = AvARRAY(av)[AvFILL(av)];
AvARRAY(av)[AvFILL(av)--] = &sv_undef;
if (SvSMAGICAL(av))
@@ -371,12 +390,10 @@ register I32 num;
if (!av || num <= 0)
return;
- if (!AvREAL(av)) {
- if (AvREIFY(av))
- av_reify(av);
- else
- croak("Can't unshift");
- }
+ if (SvREADONLY(av))
+ croak(no_modify);
+ if (!AvREAL(av) && AvREIFY(av))
+ av_reify(av);
i = AvARRAY(av) - AvALLOC(av);
if (i) {
if (i > num)
@@ -414,6 +431,8 @@ register AV *av;
if (!av || AvFILL(av) < 0)
return &sv_undef;
+ if (SvREADONLY(av))
+ croak(no_modify);
retval = *AvARRAY(av);
if (AvREAL(av))
*AvARRAY(av) = &sv_undef;
diff --git a/gnu/usr.bin/perl/av.h b/gnu/usr.bin/perl/av.h
index 93dcc0cfdc9..a8dc60b4cde 100644
--- a/gnu/usr.bin/perl/av.h
+++ b/gnu/usr.bin/perl/av.h
@@ -1,6 +1,6 @@
/* av.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -8,7 +8,7 @@
*/
struct xpvav {
- char* xav_array; /* pointer to malloced string */
+ char* xav_array; /* pointer to first array element */
SSize_t xav_fill;
SSize_t xav_max;
IV xof_off; /* ptr is incremented by offset */
@@ -16,7 +16,7 @@ struct xpvav {
MAGIC* xmg_magic; /* magic for scalar array */
HV* xmg_stash; /* class package */
- SV** xav_alloc;
+ SV** xav_alloc; /* pointer to malloced string */
SV* xav_arylen;
U8 xav_flags;
};
@@ -44,5 +44,5 @@ struct xpvav {
#define AvREUSED_on(av) (AvFLAGS(av) |= AVf_REUSED)
#define AvREUSED_off(av) (AvFLAGS(av) &= ~AVf_REUSED)
-#define AvREALISH(av) AvFLAGS(av) /* REAL or REIFY -- shortcut */
+#define AvREALISH(av) (AvFLAGS(av) & (AVf_REAL|AVf_REIFY))
diff --git a/gnu/usr.bin/perl/cflags.SH b/gnu/usr.bin/perl/cflags.SH
index 9dc5c90127b..39e96cc1ee1 100644
--- a/gnu/usr.bin/perl/cflags.SH
+++ b/gnu/usr.bin/perl/cflags.SH
@@ -21,6 +21,7 @@ echo "Extracting cflags (with variable substitutions)"
: 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!
@@ -122,8 +123,8 @@ for file do
optimize="$optdebug"
fi
- echo "$cc -c $ccflags $optimize $perltype $large $split"
- eval "$also "'"$cc -c $ccflags $optimize $perltype $large $split"'
+ echo "$cc -c -DPERL_CORE $ccflags $optimize $perltype $large $split"
+ eval "$also "'"$cc -DPERL_CORE -c $ccflags $optimize $perltype $large $split"'
. $TOP/config.sh
diff --git a/gnu/usr.bin/perl/compat3.sym b/gnu/usr.bin/perl/compat3.sym
new file mode 100644
index 00000000000..db53dd67bef
--- /dev/null
+++ b/gnu/usr.bin/perl/compat3.sym
@@ -0,0 +1,46 @@
+# Global symbols that should handled differently when Perl 5.004 is
+# compiled for binary compatibility with version 5.003.
+
+# Variables from "interp.sym" that _should_ be hidden.
+
+curcop
+curcopdb
+envgv
+siggv
+tainting
+
+# Variables from "global.sym" that should _not_ be hidden.
+
+Error
+block_type
+comppad_name_floor
+debug
+nice_chunk
+nice_chunk_size
+no_myglob
+no_symref
+no_wrongref
+pad_reset_pending
+padix_floor
+regflags
+warn_uninit
+
+# Functions from "global.sym" that should _not_ be hidden.
+
+SvIV
+SvNV
+SvTRUE
+SvUV
+boot_core_UNIVERSAL
+do_undump
+safecalloc
+safefree
+safemalloc
+saferealloc
+safexcalloc
+safexfree
+safexmalloc
+safexrealloc
+save_iv
+sv_pvn
+yydestruct
diff --git a/gnu/usr.bin/perl/config.sh.OpenBSD b/gnu/usr.bin/perl/config.sh.OpenBSD
index ff3c466e4fc..29a64525a16 100644
--- a/gnu/usr.bin/perl/config.sh.OpenBSD
+++ b/gnu/usr.bin/perl/config.sh.OpenBSD
@@ -1,13 +1,13 @@
#!/bin/sh
-# $OpenBSD: config.sh.OpenBSD,v 1.10 1997/03/13 09:39:52 maja Exp $
+# $OpenBSD: config.sh.OpenBSD,v 1.11 1997/11/30 07:48:21 millert Exp $
#
-# 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".
+# This file was produced by running the Configure script. It holds all
+# the definitions figured out by Configure. Should you modify any of
+# these values, do not forget to propagate your changes by running
+# "Configure -S"; or, equivalently, you may run each .SH file yourself.
#
-# Configuration time: Sun Aug 18 18:11:40 PDT 1996
+# Configuration time: Tue Nov 25 19:39:46 MST 1997
# Configured by: root
# Target system: openbsd
@@ -38,8 +38,8 @@ afs='false'
alignbytes=''
aphostname=''
ar='ar'
-archlib="/usr/lib/perl5/`arch |cut -f2 -d.`-openbsd/5.003"
-archlibexp="/usr/lib/perl5/`arch |cut -f2 -d.`-openbsd/5.003"
+archlib="/usr/lib/perl5/`arch |cut -f2 -d.`-openbsd/5.00404"
+archlibexp="/usr/lib/perl5/`arch |cut -f2 -d.`-openbsd/5.00404"
archname="`arch |cut -f2 -d.`-openbsd"
archobjs=''
awk='awk'
@@ -54,12 +54,12 @@ c=''
castflags='0'
cat='cat'
cc='cc'
-cccdlflags='-DPIC -fpic'
+cccdlflags='-DPIC -fPIC '
ccdlflags=' '
ccflags=''
cf_by='root'
cf_email='root@localhost'
-cf_time='Sun Aug 18 18:11:40 PDT 1996'
+cf_time='Tue Nov 25 19:39:46 MST 1997'
chgrp=''
chmod=''
chown=''
@@ -86,7 +86,9 @@ d_attribut='define'
d_bcmp='define'
d_bcopy='define'
d_bsd='define'
+d_bsdgetpgrp='undef'
d_bsdpgrp='define'
+d_bsdsetpgrp='define'
d_bzero='define'
d_casti32='define'
d_castneg='define'
@@ -105,7 +107,7 @@ d_dirnamlen='define'
if [ $_dynaload -ne 0 ]; then
d_dlerror='define'
d_dlopen='define'
- d_dlsymun=''
+ d_dlsymun='define'
else
d_dlerror='undef'
d_dlopen='undef'
@@ -127,16 +129,22 @@ d_flock='define'
d_fork='define'
d_fpathconf='define'
d_fsetpos='define'
+d_ftime='undef'
d_getgrps='define'
+d_setgrps='define'
d_gethent='undef'
d_gethname='undef'
d_getlogin='define'
+d_getpgid='define'
d_getpgrp2='undef'
d_getpgrp='define'
d_getppid='define'
d_getprior='define'
+d_gettimeod='define'
+d_gnulibc='undef'
d_htonl='define'
d_index='undef'
+d_inetaton='define'
d_isascii='define'
d_killpg='define'
d_link='define'
@@ -182,6 +190,7 @@ d_rewinddir='define'
d_rmdir='define'
d_safebcpy='define'
d_safemcpy='define'
+d_sanemcmp='define'
d_seekdir='define'
d_select='define'
d_sem='define'
@@ -203,18 +212,15 @@ d_setreuid='undef'
d_setrgid='undef'
d_setruid='undef'
d_setsid='define'
+d_sfio='undef'
d_shm='define'
d_shmat='define'
d_shmatprototype='define'
d_shmctl='define'
d_shmdt='define'
d_shmget='define'
-d_shrplib='undef'
d_sigaction='define'
-d_sigintrp=''
d_sigsetjmp='define'
-d_sigvec='define'
-d_sigvectr='undef'
d_socket='define'
d_sockpair='define'
d_statblks='define'
@@ -227,6 +233,9 @@ 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='define'
d_symlink='define'
@@ -244,7 +253,7 @@ d_truncate='define'
d_tzname='define'
d_umask='define'
d_uname='define'
-d_vfork='undef'
+d_vfork='define'
d_void_closedir='undef'
d_voidsig='define'
d_voidtty=''
@@ -263,7 +272,7 @@ direntrytype='struct dirent'
if [ $_dynaload -ne 0 ]; then
dlext='so'
dlsrc='dl_dlopen.xs'
- dynamic_ext='DB_File Fcntl FileHandle POSIX SDBM_File Safe Socket'
+ dynamic_ext='DB_File Fcntl IO NDBM_File Opcode POSIX SDBM_File Socket'
else
dlext=''
dlsrc='dl_none.xs'
@@ -276,7 +285,7 @@ emacs=''
eunicefix=':'
exe_ext=''
expr='expr'
-extensions='DB_File Fcntl FileHandle POSIX SDBM_File Safe Socket'
+extensions='DB_File Fcntl IO NDBM_File Opcode POSIX SDBM_File Socket'
find='find'
firstmakefile='makefile'
flex=''
@@ -287,7 +296,7 @@ full_sed='/usr/bin/sed'
gcc=''
gccversion='2.7.2.1'
gidtype='gid_t'
-glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib '
+glibpth='/usr/shlib /shlib /usr/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 '
grep='grep'
groupcat=''
groupstype='gid_t'
@@ -320,6 +329,7 @@ i_neterrno='undef'
i_niin='define'
i_pwd='define'
i_rpcsvcdbm='undef'
+i_sfio='undef'
i_sgtty='undef'
i_stdarg='define'
i_stddef='define'
@@ -332,6 +342,7 @@ i_sysin='undef'
i_sysioctl='define'
i_sysndir='undef'
i_sysparam='define'
+i_sysresrc='define'
i_sysselct='define'
i_syssockio=''
i_sysstat='define'
@@ -340,17 +351,19 @@ 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_varargs='undef'
+i_values='undef'
i_varhdr='stdarg.h'
i_vfork='undef'
incpath=''
inews=''
-installarchlib="/usr/lib/perl5/`arch |cut -f2 -d.`-openbsd/5.003"
+installarchlib="/usr/lib/perl5/`arch |cut -f2 -d.`-openbsd/5.00404"
installbin='/usr/bin'
installman1dir=''
installman3dir=''
@@ -359,7 +372,7 @@ installscript='/usr/bin'
installsitearch="/usr/lib/perl5/site_perl/`arch |cut -f2 -d.`-openbsd"
installsitelib='/usr/lib/perl5/site_perl'
intsize='4'
-known_extensions='DB_File Fcntl FileHandle GDBM_File NDBM_File ODBM_File POSIX SDBM_File Safe Socket'
+known_extensions='DB_File Fcntl GDBM_File IO NDBM_File ODBM_File Opcode POSIX SDBM_File Socket'
ksh=''
large=''
ld='ld'
@@ -367,10 +380,11 @@ lddlflags='-Bforcearchive -Bshareable '
ldflags=''
less='less'
lib_ext='.a'
-libc='/usr/lib/libc.so.12.6'
+libc='/usr/lib/libc.a'
+libperl='libperl.a'
libpth='/usr/lib'
libs='-lm -lc'
-libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
+libswanted='sfio net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
line='line'
lint=''
lkflags=''
@@ -378,13 +392,20 @@ ln='ln'
lns='/bin/ln -s'
locincpth=''
loclibpth=''
+
+case "`arch |cut -f2 -d.`" in
+"alpha") longsize='8';;
+*) longsize='4';;
+esac
+
lp=''
lpr=''
ls='ls'
lseektype='off_t'
mail=''
mailx=''
-make=''
+make='/usr/bin/make'
+make_set_make='#'
mallocobj=''
mallocsrc=''
malloctype='void *'
@@ -419,9 +440,9 @@ orderlib='false'
osname='openbsd'
osvers="`uname -r`"
package='perl5'
-pager='/usr/bin/more'
+pager='/usr/bin/less'
passcat=''
-patchlevel='3'
+patchlevel='4'
path_sep=':'
perl='perl'
perladmin='root@localhost'
@@ -447,11 +468,12 @@ scriptdirexp='/usr/bin'
sed='sed'
selecttype='fd_set *'
sendmail='sendmail'
-sh=''
+sh='/bin/sh'
shar=''
sharpbang='#!'
shmattype='char *'
-shrpdir='none'
+shortsize='2'
+shrpenv=''
shsharp='true'
sig_name='ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CHLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2 IOT '
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 '
@@ -482,8 +504,8 @@ stdio_cnt='((fp)->_cnt)'
stdio_ptr='((fp)->_ptr)'
strings='/usr/include/string.h'
submit=''
-subversion='0'
-sysman='/usr/man/man1'
+subversion='4'
+sysman='/usr/share/man/man1'
tail=''
tar=''
tbl=''
@@ -504,17 +526,17 @@ fi
usemymalloc='n'
usenm='true'
useposix='true'
-usesafe='true'
-usevfork='false'
+usesfio='false'
+useshrplib='false'
+usevfork='true'
usrinc='/usr/include'
uuname=''
vi=''
voidflags='15'
xlibpth=''
zcat=''
-PATCHLEVEL=3
-SUBVERSION=0
-LOCAL_PATCH_COUNT=\
+PATCHLEVEL=4
+SUBVERSION=4
CONFIG=true
# Variables propagated from previous config.sh file.
pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"'
diff --git a/gnu/usr.bin/perl/config_H b/gnu/usr.bin/perl/config_H
index da9c35b50ee..8d320cb5e10 100644
--- a/gnu/usr.bin/perl/config_H
+++ b/gnu/usr.bin/perl/config_H
@@ -11,12 +11,12 @@
* 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,v 1.1.1.1 1996/08/19 10:11:36 downsj Exp $
+ * $Id: config_H,v 1.2 1997/11/30 07:48:22 millert Exp $
*/
-/* Configuration time: Mon Mar 18 23:11:24 EST 1996
- * Configured by: bailey
- * Target system: sunos agave.humgen.upenn.edu 5.4 generic_101945-13 sun4m sparc
+/* Configuration time: Wed Sep 11 15:24:25 EDT 1996
+ * Configured by: doughera
+ * Target system: sunos fractal 5.5 generic i86pc i386 i86pc
*/
#ifndef _config_h_
@@ -28,15 +28,31 @@
*/
#define MEM_ALIGNBYTES 4 /**/
+/* 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 "unknown" /**/
+
/* 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.
*/
-#define BIN "/usr/local/bin" /**/
+/* 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" /**/
/* 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 CAT3(a,b,c)a/**/b/**/c
@@ -86,7 +102,7 @@
* 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 /**/
+/*#define HASATTRIBUTE / **/
#ifndef HASATTRIBUTE
#define __attribute__(_arg_)
#endif
@@ -95,19 +111,19 @@
* This symbol is defined if the bcmp() routine is available to
* compare blocks of memory.
*/
-/*#define HAS_BCMP /**/
+#define HAS_BCMP /**/
/* HAS_BCOPY:
* This symbol is defined if the bcopy() routine is available to
* copy blocks of memory.
*/
-/*#define HAS_BCOPY /**/
+#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 /**/
+#define HAS_BZERO /**/
/* CASTI32:
* This symbol is defined if the C compiler can cast negative
@@ -146,13 +162,13 @@
* 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 /**/
+/*#define HAS_CHSIZE / **/
/* VOID_CLOSEDIR:
* This symbol, if defined, indicates that the closedir() routine
* does not return a value.
*/
-/*#define VOID_CLOSEDIR /**/
+/*#define VOID_CLOSEDIR / **/
/* HASCONST:
* This symbol, if defined, indicates that this C compiler knows about
@@ -238,7 +254,7 @@
* This symbol, if defined, indicates that the flock routine is
* available to do file locking.
*/
-/*#define HAS_FLOCK /**/
+/*#define HAS_FLOCK / **/
/* HAS_FORK:
* This symbol, if defined, indicates that the fork routine is
@@ -252,12 +268,29 @@
*/
#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.
*/
+/* 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_GETGROUPS /**/
+#define HAS_SETGROUPS /**/
/* HAS_GETHOSTENT:
* This symbol, if defined, indicates that the gethostent routine is
@@ -278,17 +311,11 @@
*/
#define HAS_GETLOGIN /**/
-/* HAS_GETPGRP:
- * This symbol, if defined, indicates that the getpgrp routine is
- * available to get the current process group.
- */
-#define HAS_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 /**/
+/*#define HAS_GETPGRP2 / **/
/* HAS_GETPPID:
* This symbol, if defined, indicates that the getppid routine is
@@ -300,7 +327,7 @@
* This symbol, if defined, indicates that the getpriority routine is
* available to get a process's priority.
*/
-/*#define HAS_GETPRIORITY /**/
+#define HAS_GETPRIORITY /**/
/* HAS_HTONL:
* This symbol, if defined, indicates that the htonl() routine (and
@@ -338,7 +365,7 @@
* to kill process groups. If unavailable, you probably should use kill
* with a negative process number.
*/
-/*#define HAS_KILLPG /**/
+#define HAS_KILLPG /**/
/* HAS_LINK:
* This symbol, if defined, indicates that the link routine is
@@ -529,7 +556,7 @@
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
-/*#define HAS_SAFE_BCOPY /**/
+#define HAS_SAFE_BCOPY /**/
/* HAS_SAFE_MEMCPY:
* This symbol, if defined, indicates that the memcpy routine is available
@@ -537,7 +564,14 @@
* probably use memmove() or memcpy(). If neither is defined, roll your
* own version.
*/
-/*#define HAS_SAFE_MEMCPY /**/
+/*#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_SELECT:
* This symbol, if defined, indicates that the select routine is
@@ -569,7 +603,7 @@
* available to change stderr or stdout from block-buffered or unbuffered
* to a line-buffered mode.
*/
-/*#define HAS_SETLINEBUF /**/
+#define HAS_SETLINEBUF /**/
/* HAS_SETLOCALE:
* This symbol, if defined, indicates that the setlocale routine is
@@ -577,35 +611,17 @@
*/
#define HAS_SETLOCALE /**/
-/* HAS_SETPGID:
- * This symbol, if defined, indicates that the setpgid 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_BSDPGRP:
- * This symbol, if defined, indicates that the BSD notion of process
- * group is to be used. For instance, you have to say setpgrp(pid, pgrp)
- * instead of the USG setpgrp().
- */
-#define HAS_SETPGRP /**/
-/*#define USE_BSDPGRP /**/
-
/* 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 /**/
+/*#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 /**/
+#define HAS_SETPRIORITY /**/
/* HAS_SETREGID:
* This symbol, if defined, indicates that the setregid routine is
@@ -617,8 +633,8 @@
* available to change the real, effective and saved gid of the current
* process.
*/
-/*#define HAS_SETREGID /**/
-/*#define HAS_SETRESGID /**/
+#define HAS_SETREGID /**/
+/*#define HAS_SETRESGID / **/
/* HAS_SETREUID:
* This symbol, if defined, indicates that the setreuid routine is
@@ -630,20 +646,20 @@
* available to change the real, effective and saved uid of the current
* process.
*/
-/*#define HAS_SETREUID /**/
-/*#define HAS_SETRESUID /**/
+#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 /**/
+/*#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 /**/
+/*#define HAS_SETRUID / **/
/* HAS_SETSID:
* This symbol, if defined, indicates that the setsid routine is
@@ -701,18 +717,6 @@
* and FILE_cnt(fp) macros will also be defined and should be used
* to access these fields.
*/
-/* 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.
- */
-#define USE_STDIO_PTR /**/
-#define USE_STDIO_BASE /**/
-
/* 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
@@ -731,6 +735,7 @@
* 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)->_ptr)
#define STDIO_PTR_LVALUE /**/
@@ -738,6 +743,15 @@
#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
@@ -749,6 +763,7 @@
* structure pointed to its argument. This macro will always be defined
* if USE_STDIO_BASE is defined.
*/
+#define USE_STDIO_BASE /**/
#ifdef USE_STDIO_BASE
#define FILE_base(fp) ((fp)->_base)
#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
@@ -764,7 +779,7 @@
* functions are available for string searching.
*/
#define HAS_STRCHR /**/
-/*#define HAS_INDEX /**/
+/*#define HAS_INDEX / **/
/* HAS_STRCOLL:
* This symbol, if defined, indicates that the strcoll routine is
@@ -798,6 +813,24 @@
#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.
@@ -875,7 +908,7 @@
/* HAS_VFORK:
* This symbol, if defined, indicates that vfork() exists.
*/
-/*#define HAS_VFORK /**/
+/*#define HAS_VFORK / **/
/* Signal_t:
* This symbol's value is either "void" or "int", corresponding to the
@@ -906,12 +939,12 @@
* symbol.
*/
#define HAS_VPRINTF /**/
-/*#define USE_CHAR_VSPRINTF /**/
+/*#define USE_CHAR_VSPRINTF / **/
/* HAS_WAIT4:
* This symbol, if defined, indicates that wait4() exists.
*/
-/*#define HAS_WAIT4 /**/
+#define HAS_WAIT4 /**/
/* HAS_WAITPID:
* This symbol, if defined, indicates that the waitpid routine is
@@ -949,14 +982,14 @@
/* Groups_t:
* This symbol holds the type used for the second argument to
- * getgroups(). Usually, this is the same of gidtype, but
+ * [gs]etgroups(). Usually, this is the same of gidtype, 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().
+ * getgroups() or setgroups().
*/
-#ifdef HAS_GETGROUPS
-#define Groups_t gid_t /* Type for 2nd arg to getgroups() */
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+#define Groups_t gid_t /* Type for 2nd arg to [gs]etgroups() */
#endif
/* DB_Prefix_t:
@@ -989,7 +1022,7 @@
* portably declare your directory entries.
*/
#define I_DIRENT /**/
-/*#define DIRNAMLEN /**/
+/*#define DIRNAMLEN / **/
#define Direntry_t struct dirent
/* I_DLFCN:
@@ -1033,7 +1066,7 @@
* This symbol, if defined, indicates to the C program that it should
* include <memory.h>.
*/
-/*#define I_MEMORY /**/
+/*#define I_MEMORY / **/
/* I_NDBM:
* This symbol, if defined, indicates that <ndbm.h> exists and should
@@ -1045,7 +1078,7 @@
* This symbol, if defined, indicates that <net/errno.h> exists and
* should be included.
*/
-/*#define I_NET_ERRNO /**/
+/*#define I_NET_ERRNO / **/
/* I_NETINET_IN:
* This symbol, if defined, indicates to the C program that it should
@@ -1082,11 +1115,11 @@
* contains pw_comment.
*/
#define I_PWD /**/
-/*#define PWQUOTA /**/
+/*#define PWQUOTA / **/
#define PWAGE /**/
-/*#define PWCHANGE /**/
-/*#define PWCLASS /**/
-/*#define PWEXPIRE /**/
+/*#define PWCHANGE / **/
+/*#define PWCLASS / **/
+/*#define PWEXPIRE / **/
#define PWCOMMENT /**/
/* I_STDDEF:
@@ -1111,13 +1144,13 @@
* This symbol, if defined, indicates to the C program that it should
* include <sys/dir.h>.
*/
-/*#define I_SYS_DIR /**/
+/*#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 /**/
+/*#define I_SYS_FILE / **/
/* I_SYS_IOCTL:
* This symbol, if defined, indicates that <sys/ioctl.h> exists and should
@@ -1129,7 +1162,7 @@
* This symbol, if defined, indicates to the C program that it should
* include <sys/ndir.h>.
*/
-/*#define I_SYS_NDIR /**/
+/*#define I_SYS_NDIR / **/
/* I_SYS_PARAM:
* This symbol, if defined, indicates to the C program that it should
@@ -1137,6 +1170,12 @@
*/
#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.
@@ -1161,6 +1200,12 @@
*/
#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
@@ -1177,9 +1222,9 @@
* <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_TERMIO / **/
#define I_TERMIOS /**/
-/*#define I_SGTTY /**/
+/*#define I_SGTTY / **/
/* I_TIME:
* This symbol, if defined, indicates to the C program that it should
@@ -1193,9 +1238,9 @@
* This symbol, if defined, indicates to the C program that it should
* include <sys/time.h> with KERNEL defined.
*/
-/*#define I_TIME /**/
+/*#define I_TIME / **/
#define I_SYS_TIME /**/
-/*#define I_SYS_TIME_KERNEL /**/
+/*#define I_SYS_TIME_KERNEL / **/
/* I_UNISTD:
* This symbol, if defined, indicates to the C program that it should
@@ -1209,11 +1254,38 @@
*/
#define I_UTIME /**/
+/* 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 /**/
+/*#define I_VFORK / **/
+
+/* 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 /**/
/* Off_t:
* This symbol holds the type used to declare offsets in the kernel.
@@ -1230,6 +1302,33 @@
*/
#define Mode_t mode_t /* file mode parameter for system calls */
+/* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+/* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+/* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+/* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+#define VAL_O_NONBLOCK O_NONBLOCK
+#define VAL_EAGAIN EAGAIN
+#define RD_NODATA -1
+#define EOF_NONBLOCK
+
/* CAN_PROTOTYPE:
* If defined, this macro indicates that the C compiler can handle
* function prototypes.
@@ -1254,14 +1353,6 @@
*/
#define RANDBITS 15 /**/
-/* SCRIPTDIR:
- * This symbol holds the name of the directory in which the user wants
- * to put publicly executable scripts for the package in question. It
- * is often a directory that is mounted across diverse architectures.
- * Programs must be prepared to deal with ~name expansion.
- */
-#define SCRIPTDIR "/usr/local/script" /**/
-
/* 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
@@ -1301,34 +1392,62 @@
*/
#define Uid_t uid_t /* UID type */
-/* VMS:
- * This symbol, if defined, indicates that the program is running under
- * VMS. It is currently only set in conjunction with the EUNICE symbol.
- */
-/*#define VMS /**/
-
/* LOC_SED:
* This symbol holds the complete pathname to the sed program.
*/
#define LOC_SED "/bin/sed" /**/
+/* 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 "solaris" /**/
+
+/* 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_EXP "/usr/local/lib/perl5/i86pc-solaris/5.002" /**/
+#define ARCHLIB "/opt/perl/lib/i86pc-solaris/5.00305" /**/
+#define ARCHLIB_EXP "/opt/perl/lib/i86pc-solaris/5.00305" /**/
-/* OSNAME:
- * This symbol contains the name of the operating system, as determined
- * by Configure.
+/* BINCOMPAT3:
+ * This symbol, if defined, indicates that Perl 5.004 should be
+ * binary-compatible with Perl 5.003.
*/
-#define OSNAME "solaris" /**/
+#define BINCOMPAT3 /**/
/* BYTEORDER:
- * This symbol hold the hexadecimal constant defined in byteorder,
+ * This symbol holds the hexadecimal constant defined in byteorder,
* i.e. 0x1234 or 0x4321, etc...
- */
+ * On NeXT 4 (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 */
/* CSH:
* This symbol, if defined, indicates that the C-shell exists.
@@ -1342,7 +1461,7 @@
* makes sense if you *have* dlsym, which we will presume is the
* case if you're using dl_dlopen.xs.
*/
-/*#define DLSYM_NEEDS_UNDERSCORE /* */
+/*#define DLSYM_NEEDS_UNDERSCORE / **/
/* SETUID_SCRIPTS_ARE_SECURE_NOW:
* This symbol, if defined, indicates that the bug that prevents
@@ -1362,7 +1481,7 @@
* file descriptor of the script to be executed.
*/
#define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
-/*#define DOSUID /**/
+/*#define DOSUID / **/
/* Gconvert:
* This preprocessor macro is defined to convert a floating point
@@ -1381,26 +1500,85 @@
*/
#define Gconvert(x,n,t,b) gconvert((x),(n),(t),(b))
+/* 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_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_SETPGID:
+ * This symbol, if defined, indicates to the C program that
+ * the setpgid(pid, gpid) function is available to set the
+ * 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.
+ */
+/* USE_BSDPGRP:
+ * This symbol, if defined, indicates that the BSD notion of process
+ * group is to be used. For instance, you have to say setpgrp(pid, pgrp)
+ * instead of the USG setpgrp(). This should be obsolete since
+ * there are systems which have BSD-ish setpgrp but USG-ish getpgrp.
+ */
+#define HAS_SETPGRP /**/
+/*#define USE_BSD_SETPGRP / **/
+/*#define USE_BSDPGRP / **/
+
+/* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+/*#define USE_SFIO / **/
+
/* Sigjmp_buf:
- * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
+ * 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.
+ * 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.
+ * 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)
+#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)
+#define Sigsetjmp(buf,save_mask) setjmp((buf))
+#define Siglongjmp(buf,retval) longjmp((buf),(retval))
#endif
/* USE_DYNAMIC_LOADING:
@@ -1417,7 +1595,7 @@
* This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and
* should be included.
*/
-/*#define I_DBM /**/
+/*#define I_DBM / **/
#define I_RPCSVC_DBM /**/
/* I_LOCALE:
@@ -1426,28 +1604,25 @@
*/
#define I_LOCALE /**/
+/* I_SFIO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sfio.h>.
+ */
+/*#define I_SFIO / **/
+
/* I_SYS_STAT:
* This symbol, if defined, indicates to the C program that it should
* include <sys/stat.h>.
*/
#define I_SYS_STAT /**/
-/* I_STDARG:
- * This symbol, if defined, indicates that <stdarg.h> exists and should
- * be included.
- */
-/* I_VARARGS:
+/* I_VALUES:
* This symbol, if defined, indicates to the C program that it should
- * include <varargs.h>.
+ * 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_STDARG /**/
-/*#define I_VARARGS /**/
-
-/* INTSIZE:
- * This symbol contains the size of an int, so that the C preprocessor
- * can make decisions based on it.
- */
-#define INTSIZE 4 /**/
+#define I_VALUES /**/
/* Free_t:
* This variable contains the return type of free(). It is usually
@@ -1464,45 +1639,42 @@
*/
#define MYMALLOC /**/
-/* 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.
+/* OLDARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user has perl5.000 or perl5.001 architecture-dependent
+ * public library files for perl5. For the most part, these
+ * files will work with 5.002 (and later), but that is not
+ * guaranteed.
*/
-/* 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
-
/* OLDARCHLIB_EXP:
* This symbol contains the ~name expanded version of OLDARCHLIB, to be
* used in programs that are not prepared to deal with ~ expansion at
* run-time.
*/
-/*#define OLDARCHLIB_EXP "" /**/
+/*#define OLDARCHLIB "" / **/
+/*#define OLDARCHLIB_EXP "" / **/
+/* 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_EXP "/usr/local/lib/perl5" /**/
+#define PRIVLIB "/opt/perl/lib" /**/
+#define PRIVLIB_EXP "/opt/perl/lib" /**/
+
+/* 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" /**/
/* SIG_NAME:
* This symbol contains a list of signal names in order of
@@ -1532,27 +1704,54 @@
* 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","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","CHLD","PWR","WINCH","URG","IO","STOP","TSTP","CONT","TTIN","TTOU","VTALRM","PROF","XCPU","XFSZ","WAITING","LWP","FREEZE","THAW","RTMIN","NUM37","NUM38","NUM39","NUM40","NUM41","NUM42","RTMAX","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,32,33,34,35,36,37,38,39,40,41,42,43,6,18,22,0 /**/
+#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","ABRT","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","CHLD","PWR","WINCH","URG","IO","STOP","TSTP","CONT","TTIN","TTOU","VTALRM","PROF","XCPU","XFSZ","WAITING","LWP","FREEZE","THAW","CANCEL","RTMIN","NUM38","NUM39","NUM40","NUM41","NUM42","NUM43","RTMAX","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,32,33,34,35,36,37,38,39,40,41,42,43,44,6,18,22,0 /**/
+/* 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_EXP "/usr/local/lib/perl5/site_perl/i86pc-solaris" /**/
+#define SITEARCH "/opt/perl/lib/site_perl/i86pc-solaris" /**/
+#define SITEARCH_EXP "/opt/perl/lib/site_perl/i86pc-solaris" /**/
+/* 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_EXP "/usr/local/lib/perl5/site_perl" /**/
+#define SITELIB "/opt/perl/lib/site_perl" /**/
+#define SITELIB_EXP "/opt/perl/lib/site_perl" /**/
/* 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 "#!/usr/local/bin/perl" /**/
+#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 / **/
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
diff --git a/gnu/usr.bin/perl/config_h.SH b/gnu/usr.bin/perl/config_h.SH
index f4ecea0faa1..cfae03ad990 100644
--- a/gnu/usr.bin/perl/config_h.SH
+++ b/gnu/usr.bin/perl/config_h.SH
@@ -15,7 +15,7 @@ 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!' -e 's!^#un-def!#undef!'
+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
@@ -39,18 +39,51 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
/* 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.
*/
+#ifndef NeXT
#define MEM_ALIGNBYTES $alignbytes /**/
+#else /* NeXT */
+#ifdef __m68k__
+#define MEM_ALIGNBYTES 2
+#else
+#ifdef __i386__
+#define MEM_ALIGNBYTES 4
+#else /* __hppa__, __sparc__ and default for unknown architectures */
+#define MEM_ALIGNBYTES 8
+#endif /* __i386__ */
+#endif /* __m68k__ */
+#endif /* NeXT */
+
+/* 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" /**/
/* 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" /**/
/* 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 CAT3(a,b,c)a/**/b/**/c
@@ -266,12 +299,29 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#$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.
*/
+/* 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_getgrps HAS_GETGROUPS /**/
+#$d_setgrps HAS_SETGROUPS /**/
/* HAS_GETHOSTENT:
* This symbol, if defined, indicates that the gethostent routine is
@@ -292,12 +342,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#$d_getlogin HAS_GETLOGIN /**/
-/* HAS_GETPGRP:
- * This symbol, if defined, indicates that the getpgrp routine is
- * available to get the current process group.
- */
-#$d_getpgrp HAS_GETPGRP /**/
-
/* HAS_GETPGRP2:
* This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
* routine is available to get the current process group.
@@ -553,6 +597,13 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#$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_SELECT:
* This symbol, if defined, indicates that the select routine is
* available to select active file descriptors. If the timeout field
@@ -591,24 +642,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#$d_setlocale HAS_SETLOCALE /**/
-/* HAS_SETPGID:
- * This symbol, if defined, indicates that the setpgid 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_BSDPGRP:
- * This symbol, if defined, indicates that the BSD notion of process
- * group is to be used. For instance, you have to say setpgrp(pid, pgrp)
- * instead of the USG setpgrp().
- */
-#$d_setpgrp HAS_SETPGRP /**/
-#$d_bsdpgrp USE_BSDPGRP /**/
-
/* HAS_SETPGRP2:
* This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
* routine is available to set the current process group.
@@ -715,18 +748,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
* and FILE_cnt(fp) macros will also be defined and should be used
* to access these fields.
*/
-/* 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.
- */
-#$d_stdstdio USE_STDIO_PTR /**/
-#$d_stdiobase USE_STDIO_BASE /**/
-
/* 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
@@ -745,6 +766,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
* 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 /**/
@@ -752,6 +774,15 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
#$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
@@ -763,6 +794,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
* 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
@@ -812,6 +844,24 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
#$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.
@@ -963,14 +1013,14 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
/* Groups_t:
* This symbol holds the type used for the second argument to
- * getgroups(). Usually, this is the same of gidtype, but
+ * [gs]etgroups(). Usually, this is the same of gidtype, 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().
+ * getgroups() or setgroups().
*/
-#ifdef HAS_GETGROUPS
-#define Groups_t $groupstype /* Type for 2nd arg to getgroups() */
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+#define Groups_t $groupstype /* Type for 2nd arg to [gs]etgroups() */
#endif
/* DB_Prefix_t:
@@ -1151,6 +1201,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#$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.
@@ -1175,6 +1231,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#$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
@@ -1223,12 +1285,39 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#$i_utime I_UTIME /**/
+/* 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 /**/
+/* 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 /**/
+
/* 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
@@ -1244,6 +1333,33 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#define Mode_t $modetype /* file mode parameter for system calls */
+/* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+/* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+/* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+/* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+#define VAL_O_NONBLOCK $o_nonblock
+#define VAL_EAGAIN $eagain
+#define RD_NODATA $rd_nodata
+#$d_eofnblk EOF_NONBLOCK
+
/* CAN_PROTOTYPE:
* If defined, this macro indicates that the C compiler can handle
* function prototypes.
@@ -1268,14 +1384,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#define RANDBITS $randbits /**/
-/* SCRIPTDIR:
- * This symbol holds the name of the directory in which the user wants
- * to put publicly executable scripts for the package in question. It
- * is often a directory that is mounted across diverse architectures.
- * Programs must be prepared to deal with ~name expansion.
- */
-#define SCRIPTDIR "$scriptdir" /**/
-
/* 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
@@ -1315,34 +1423,62 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#define Uid_t $uidtype /* UID type */
-/* VMS:
- * This symbol, if defined, indicates that the program is running under
- * VMS. It is currently only set in conjunction with the EUNICE symbol.
- */
-#$d_eunice VMS /**/
-
/* LOC_SED:
* This symbol holds the complete pathname to the sed program.
*/
#define LOC_SED "$full_sed" /**/
+/* 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" /**/
+
+/* 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" /**/
-/* OSNAME:
- * This symbol contains the name of the operating system, as determined
- * by Configure.
+/* BINCOMPAT3:
+ * This symbol, if defined, indicates that Perl 5.004 should be
+ * binary-compatible with Perl 5.003.
*/
-#define OSNAME "$osname" /**/
+#$d_bincompat3 BINCOMPAT3 /**/
/* BYTEORDER:
- * This symbol hold the hexadecimal constant defined in 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 */
/* CSH:
* This symbol, if defined, indicates that the C-shell exists.
@@ -1356,7 +1492,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
* 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 /* */
+#$d_dlsymun DLSYM_NEEDS_UNDERSCORE /**/
/* SETUID_SCRIPTS_ARE_SECURE_NOW:
* This symbol, if defined, indicates that the bug that prevents
@@ -1395,26 +1531,85 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#define Gconvert(x,n,t,b) $d_Gconvert
+/* 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_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_SETPGID:
+ * This symbol, if defined, indicates to the C program that
+ * the setpgid(pid, gpid) function is available to set the
+ * 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.
+ */
+/* USE_BSDPGRP:
+ * This symbol, if defined, indicates that the BSD notion of process
+ * group is to be used. For instance, you have to say setpgrp(pid, pgrp)
+ * instead of the USG setpgrp(). This should be obsolete since
+ * there are systems which have BSD-ish setpgrp but USG-ish getpgrp.
+ */
+#$d_setpgrp HAS_SETPGRP /**/
+#$d_bsdsetpgrp USE_BSD_SETPGRP /**/
+#$d_bsdpgrp USE_BSDPGRP /**/
+
+/* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+#$d_sfio USE_SFIO /**/
+
/* Sigjmp_buf:
- * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
+ * 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.
+ * 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.
+ * 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)
+#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)
+#define Sigsetjmp(buf,save_mask) setjmp((buf))
+#define Siglongjmp(buf,retval) longjmp((buf),(retval))
#endif
/* USE_DYNAMIC_LOADING:
@@ -1440,28 +1635,25 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#$i_locale I_LOCALE /**/
+/* I_SFIO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sfio.h>.
+ */
+#$i_sfio I_SFIO /**/
+
/* 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_STDARG:
- * This symbol, if defined, indicates that <stdarg.h> exists and should
- * be included.
- */
-/* I_VARARGS:
+/* I_VALUES:
* This symbol, if defined, indicates to the C program that it should
- * include <varargs.h>.
+ * 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_stdarg I_STDARG /**/
-#$i_varargs I_VARARGS /**/
-
-/* INTSIZE:
- * This symbol contains the size of an int, so that the C preprocessor
- * can make decisions based on it.
- */
-#define INTSIZE $intsize /**/
+#$i_values I_VALUES /**/
/* Free_t:
* This variable contains the return type of free(). It is usually
@@ -1478,46 +1670,43 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#$d_mymalloc MYMALLOC /**/
-/* 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!).
+/* OLDARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user has perl5.000 or perl5.001 architecture-dependent
+ * public library files for $package. For the most part, these
+ * files will work with 5.002 (and later), but that is not
+ * guaranteed.
*/
-#define VAL_O_NONBLOCK $o_nonblock
-#define VAL_EAGAIN $eagain
-#define RD_NODATA $rd_nodata
-#$d_eofnblk EOF_NONBLOCK
-
/* OLDARCHLIB_EXP:
* This symbol contains the ~name expanded version of OLDARCHLIB, to be
* used in programs that are not prepared to deal with ~ expansion at
* run-time.
*/
+#$d_oldarchlib OLDARCHLIB "$oldarchlib" /**/
#$d_oldarchlib OLDARCHLIB_EXP "$oldarchlibexp" /**/
+/* 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" /**/
+/* 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" /**/
+
/* SIG_NAME:
* This symbol contains a list of signal names in order of
* signal number. This is intended
@@ -1549,16 +1738,36 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
#define SIG_NAME "`echo $sig_name | sed 's/ /","/g'`",0 /**/
#define SIG_NUM `echo $sig_num 0 | sed 's/ /,/g'` /**/
+/* 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:
@@ -1568,6 +1777,13 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#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 /**/
+
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
* compiler. What various bits mean:
diff --git a/gnu/usr.bin/perl/configpm b/gnu/usr.bin/perl/configpm
index af1e716be6e..0c6a9650728 100644
--- a/gnu/usr.bin/perl/configpm
+++ b/gnu/usr.bin/perl/configpm
@@ -6,7 +6,7 @@ $config_pm = $ARGV[0] || 'lib/Config.pm';
# 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 cc ccflags cppflags
+ sig_name sig_num cc ccflags cppflags
privlibexp archlibexp installprivlib installarchlib
sharpbang startsh shsharp
);
@@ -26,7 +26,7 @@ use Exporter ();
\@EXPORT_OK = qw(myconfig config_sh config_vars);
\$] == $myver
- or die "Perl lib version ($myver) doesn't match executable version (\$])\\n";
+ 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.
@@ -39,19 +39,23 @@ ENDOFBEG
@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/;
- unless (m/^(\w+)='(.*)'\s*$/){
+ unless ($in_v or m/^(\w+)='(.*\n)/){
push(@non_v, "#$_"); # not a name='value' line
next;
}
- $name = $1;
+ if ($in_v) { $val .= $_; }
+ else { ($name,$val) = ($1,$2); }
+ $in_v = $val !~ /'\n/;
+ next if $in_v;
if ($extensions{$name}) { s,/,::,g }
- if (!$fast{$name}){ push(@v_others, $_); next; }
- push(@v_fast,$_);
+ if (!$fast{$name}){ push(@v_others, "$name='$val"); next; }
+ push(@v_fast,"$name='$val");
}
foreach(@non_v){ print CONFIG $_ }
@@ -66,8 +70,8 @@ print CONFIG "\n",
print CONFIG "my \$summary = <<'!END!';\n";
open(MYCONFIG,"<myconfig") || die "open myconfig failed: $!";
-1 while( ($_=<MYCONFIG>) !~ /^Summary of/);
-do { print CONFIG $_ } until ($_ = <MYCONFIG>) =~ /^\s*$/;
+1 while defined($_ = <MYCONFIG>) && !/^Summary of/;
+do { print CONFIG $_ } until !defined($_ = <MYCONFIG>) || /^\s*$/;
close(MYCONFIG);
print CONFIG "\n!END!\n", <<'EOT';
@@ -75,7 +79,8 @@ my $summary_expanded = 0;
sub myconfig {
return $summary if $summary_expanded;
- $summary =~ s/\$(\w+)/$Config{$1}/ge;
+ $summary =~ s{\$(\w+)}
+ { my $c = $Config{$1}; defined($c) ? $c : 'undef' }ge;
$summary_expanded = 1;
$summary;
}
@@ -85,14 +90,21 @@ EOT
print CONFIG <<'ENDOFEND';
-tie %Config, Config;
-sub TIEHASH { bless {} }
sub FETCH {
- # check for cached value (which maybe undef so we use exists not defined)
+ # check for cached value (which may be undef so we use exists not defined)
return $_[0]->{$_[1]} if (exists $_[0]->{$_[1]});
-
- my($value); # search for the item in the big $config_sh string
- return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m);
+
+ # Search for it in the big string
+ my($value, $start, $marker);
+ $marker = "$_[1]='";
+ # return undef unless (($value) = $config_sh =~ m/^$_[1]='(.*)'\s*$/m);
+ $start = index($config_sh, "\n$marker");
+ return undef if ( ($start == -1) && # in case it's first
+ (substr($config_sh, 0, length($marker)) ne $marker) );
+ if ($start == -1) { $start = length($marker) }
+ else { $start += length($marker) + 1 }
+ $value = substr($config_sh, $start,
+ index($config_sh, qq('\n), $start) - $start);
$value = undef if $value eq 'undef'; # So we can say "if $Config{'foo'}".
$_[0]->{$_[1]} = $value; # cache it
@@ -103,19 +115,23 @@ my $prevpos = 0;
sub FIRSTKEY {
$prevpos = 0;
- my($key) = $config_sh =~ m/^(.*?)=/;
- $key;
+ # my($key) = $config_sh =~ m/^(.*?)=/;
+ substr($config_sh, 0, index($config_sh, '=') );
+ # $key;
}
sub NEXTKEY {
- my $pos = index($config_sh, "\n", $prevpos) + 1;
+ my $pos = index($config_sh, qq('\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 $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]='";
}
sub STORE { die "\%Config::Config is read-only\n" }
@@ -126,14 +142,49 @@ 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__
@@ -166,7 +217,7 @@ 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 is a
+values. The perl C<exists> function can be used to check if a
named variable exists.
=over 4
@@ -198,17 +249,23 @@ See also C<-V:name> in L<perlrun/Switches>.
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{$_}] ||= $_;
+ }
+ }
- defined $Config{sig_name} || die "No sigs?";
- foreach $name (split(' ', $Config{sig_name})) {
- $signo{$name} = $i;
- $signame[$i] = $name;
- $i++;
- }
-
- print "signal #17 = $signame[17]\n";
- if ($signo{ALRM}) {
- print "SIGALRM is $signo{ALRM}\n";
+ print "signal #17 = $sig_name[17]\n";
+ if ($sig_num{ALRM}) {
+ print "SIGALRM is $sig_num{ALRM}\n";
}
=head1 WARNING
@@ -229,7 +286,7 @@ outside of it.
=cut
-ENDOFEND
+ENDOFTAIL
close(CONFIG);
diff --git a/gnu/usr.bin/perl/configure b/gnu/usr.bin/perl/configure
index 7264ce76aef..fa01c454514 100644
--- a/gnu/usr.bin/perl/configure
+++ b/gnu/usr.bin/perl/configure
@@ -1,6 +1,6 @@
#! /bin/sh
#
-# $Id: configure,v 1.1.1.1 1996/08/19 10:11:33 downsj Exp $
+# $Id: configure,v 1.2 1997/11/30 07:48:25 millert Exp $
#
# GNU configure-like front end to metaconfig's Configure.
#
@@ -16,15 +16,26 @@
# include this script in your own package.
#
# $Log: configure,v $
-# Revision 1.1.1.1 1996/08/19 10:11:33 downsj
-# Import of Perl 5.003 into the tree. Makefile.bsd-wrapper and
-# config.sh.OpenBSD are the only local changes.
+# Revision 1.2 1997/11/30 07:48:25 millert
+# perl 5.004_04
#
# 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'
@@ -38,6 +49,7 @@ It emulates the following GNU configure options (must be fully spelled out):
--help
--no-create
--prefix=PREFIX
+ --cache-file (ignored)
--quiet
--silent
--verbose
@@ -56,6 +68,9 @@ EOM
opts="$opts $arg"
shift
;;
+ --cache-file=*)
+ shift # Just ignore it.
+ ;;
--quiet|--silent)
exec >/dev/null 2>&1
shift
diff --git a/gnu/usr.bin/perl/configure.gnu b/gnu/usr.bin/perl/configure.gnu
new file mode 100644
index 00000000000..fa465320940
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/cop.h b/gnu/usr.bin/perl/cop.h
index b5033090d97..baedc5a52d1 100644
--- a/gnu/usr.bin/perl/cop.h
+++ b/gnu/usr.bin/perl/cop.h
@@ -1,6 +1,6 @@
/* cop.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -47,13 +47,25 @@ struct block_sub {
(void)SvREFCNT_inc(cx->blk_sub.dfoutgv)
#define POPSUB(cx) \
- if (cx->blk_sub.hasargs) { /* put back old @_ */ \
- GvAV(defgv) = cx->blk_sub.savearray; \
+ { struct block_sub cxsub; \
+ POPSUB1(cx); \
+ POPSUB2(); }
+
+#define POPSUB1(cx) \
+ cxsub = cx->blk_sub; /* because DESTROY may clobber *cx */
+
+#define POPSUB2() \
+ if (cxsub.hasargs) { \
+ /* put back old @_ */ \
+ SvREFCNT_dec(GvAV(defgv)); \
+ GvAV(defgv) = cxsub.savearray; \
+ /* destroy arg array */ \
+ av_clear(cxsub.argarray); \
+ AvREAL_off(cxsub.argarray); \
} \
- if (cx->blk_sub.cv) { \
- if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \
- SvREFCNT_dec((SV*)cx->blk_sub.cv); \
- } \
+ if (cxsub.cv) { \
+ if (!(CvDEPTH(cxsub.cv) = cxsub.olddepth)) \
+ SvREFCNT_dec(cxsub.cv); \
}
#define POPFORMAT(cx) \
@@ -90,6 +102,7 @@ struct block_loop {
OP * last_op;
SV ** itervar;
SV * itersave;
+ SV * iterlval;
AV * iterary;
I32 iterix;
};
@@ -100,12 +113,29 @@ struct block_loop {
cx->blk_loop.redo_op = cLOOP->op_redoop; \
cx->blk_loop.next_op = cLOOP->op_nextop; \
cx->blk_loop.last_op = cLOOP->op_lastop; \
- cx->blk_loop.itervar = ivar; \
- if (ivar) \
- cx->blk_loop.itersave = *cx->blk_loop.itervar;
+ 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) \
- newsp = stack_base + cx->blk_loop.resetsp;
+ { struct block_loop cxloop; \
+ POPLOOP1(cx); \
+ POPLOOP2(); }
+
+#define POPLOOP1(cx) \
+ cxloop = cx->blk_loop; /* because DESTROY may clobber *cx */ \
+ newsp = 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 != curstack) \
+ SvREFCNT_dec(cxloop.iterary);
/* context common to subroutines, evals and loops */
struct block {
@@ -144,7 +174,7 @@ struct block {
cx->blk_oldretsp = retstack_ix, \
cx->blk_oldpm = curpm, \
cx->blk_gimme = gimme; \
- DEBUG_l( fprintf(stderr,"Entering block %ld, type %s\n", \
+ DEBUG_l( PerlIO_printf(PerlIO_stderr(), "Entering block %ld, type %s\n", \
(long)cxstack_ix, block_type[t]); )
/* Exit a block (RETURN and LAST). */
@@ -156,7 +186,7 @@ struct block {
retstack_ix = cx->blk_oldretsp, \
pm = cx->blk_oldpm, \
gimme = cx->blk_gimme; \
- DEBUG_l( fprintf(stderr,"Leaving block %ld, type %s\n", \
+ 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). */
@@ -171,47 +201,53 @@ struct subst {
I32 sbu_iters;
I32 sbu_maxiters;
I32 sbu_safebase;
- I32 sbu_once;
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;
- char * sbu_subbase;
+ 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_once cx_u.cx_subst.sbu_once
#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_subbase cx_u.cx_subst.sbu_subbase
+#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_once = once, \
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
+ cx->cx_type = CXt_SUBST; \
+ rxres_save(&cx->sb_rxres, rx)
-#define POPSUBST(cx) cxstack_ix--
+#define POPSUBST(cx) cx = &cxstack[cxstack_ix--]; \
+ rxres_free(&cx->sb_rxres)
struct context {
I32 cx_type; /* what kind of context this is */
@@ -232,9 +268,10 @@ struct context {
/* "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 $@ rather than overwriting it */
+#define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */
diff --git a/gnu/usr.bin/perl/cv.h b/gnu/usr.bin/perl/cv.h
index b08cf5c1d06..262d44c6357 100644
--- a/gnu/usr.bin/perl/cv.h
+++ b/gnu/usr.bin/perl/cv.h
@@ -1,12 +1,14 @@
/* cv.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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 */
@@ -47,6 +49,9 @@ struct xpvcv {
#define CVf_CLONED 0x02 /* a clone of one of those */
#define CVf_ANON 0x04 /* CvGV() can't be trusted */
#define CVf_OLDSTYLE 0x08
+#define CVf_UNIQUE 0x10 /* can't be cloned */
+#define CVf_NODEBUG 0x20 /* no DB::sub indirection for this CV
+ (esp. useful for special XSUBs) */
#define CvCLONE(cv) (CvFLAGS(cv) & CVf_CLONE)
#define CvCLONE_on(cv) (CvFLAGS(cv) |= CVf_CLONE)
@@ -63,3 +68,11 @@ struct xpvcv {
#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)
diff --git a/gnu/usr.bin/perl/cygwin32/cw32imp.h b/gnu/usr.bin/perl/cygwin32/cw32imp.h
new file mode 100644
index 00000000000..1fb11d3e03c
--- /dev/null
+++ b/gnu/usr.bin/perl/cygwin32/cw32imp.h
@@ -0,0 +1,356 @@
+/* include file for building of extension libs using GNU-Win32 toolkit,
+ which is based on the Cygnus Cygwin32 API. This file is included by
+ the extension dlls when they are built. Global vars defined in perl
+ exe are referenced by the extension module dll by using __imp_varName,
+ where varName is the name of the global variable in perl.exe.
+ GNU-Win32 has no equivalent to MSVC's __declspec(dllimport) keyword to
+ define a imported global, so we have to use this approach to access
+ globals exported by perl.exe.
+ -jc 4/1/97
+*/
+
+#define impure_setupptr (*__imp_impure_setupptr)
+#define Perl_reall_srchlen (*__imp_Perl_reall_srchlen)
+#define Perl_yychar (*__imp_Perl_yychar)
+#define Perl_yycheck (*__imp_Perl_yycheck)
+#define Perl_yydebug (*__imp_Perl_yydebug)
+#define Perl_yydefred (*__imp_Perl_yydefred)
+#define Perl_yydgoto (*__imp_Perl_yydgoto)
+#define Perl_yyerrflag (*__imp_Perl_yyerrflag)
+#define Perl_yygindex (*__imp_Perl_yygindex)
+#define Perl_yylen (*__imp_Perl_yylen)
+#define Perl_yylhs (*__imp_Perl_yylhs)
+#define Perl_yylval (*__imp_Perl_yylval)
+#define Perl_yynerrs (*__imp_Perl_yynerrs)
+#define Perl_yyrindex (*__imp_Perl_yyrindex)
+#define Perl_yysindex (*__imp_Perl_yysindex)
+#define Perl_yytable (*__imp_Perl_yytable)
+#define Perl_yyval (*__imp_Perl_yyval)
+#define Perl_regarglen (*__imp_Perl_regarglen)
+#define Perl_regdummy (*__imp_Perl_regdummy)
+#define Perl_regkind (*__imp_Perl_regkind)
+#define Perl_simple (*__imp_Perl_simple)
+#define Perl_varies (*__imp_Perl_varies)
+#define Perl_watchaddr (*__imp_Perl_watchaddr)
+#define Perl_watchok (*__imp_Perl_watchok)
+#define Argv (*__imp_Argv)
+#define Cmd (*__imp_Cmd)
+#define DBgv (*__imp_DBgv)
+#define DBline (*__imp_DBline)
+#define DBsignal (*__imp_DBsignal)
+#define DBsingle (*__imp_DBsingle)
+#define DBsub (*__imp_DBsub)
+#define DBtrace (*__imp_DBtrace)
+#define Error (*__imp_Error)
+#define Perl_AMG_names (*__imp_Perl_AMG_names)
+#define Perl_No (*__imp_Perl_No)
+#define Perl_Sv (*__imp_Perl_Sv)
+#define Perl_Xpv (*__imp_Perl_Xpv)
+#define Perl_Yes (*__imp_Perl_Yes)
+#define Perl_amagic_generation (*__imp_Perl_amagic_generation)
+#define Perl_an (*__imp_Perl_an)
+#define Perl_buf (*__imp_Perl_buf)
+#define Perl_bufend (*__imp_Perl_bufend)
+#define Perl_bufptr (*__imp_Perl_bufptr)
+#define Perl_check (*__imp_Perl_check)
+#define Perl_collation_ix (*__imp_Perl_collation_ix)
+#define Perl_collation_name (*__imp_Perl_collation_name)
+#define Perl_collation_standard (*__imp_Perl_collation_standard)
+#define Perl_collxfrm_base (*__imp_Perl_collxfrm_base)
+#define Perl_collxfrm_mult (*__imp_Perl_collxfrm_mult)
+#define Perl_compcv (*__imp_Perl_compcv)
+#define Perl_compiling (*__imp_Perl_compiling)
+#define Perl_comppad (*__imp_Perl_comppad)
+#define Perl_comppad_name (*__imp_Perl_comppad_name)
+#define Perl_comppad_name_fill (*__imp_Perl_comppad_name_fill)
+#define Perl_cop_seqmax (*__imp_Perl_cop_seqmax)
+#define Perl_curcop (*__imp_Perl_curcop)
+#define Perl_curcopdb (*__imp_Perl_curcopdb)
+#define Perl_curinterp (*__imp_Perl_curinterp)
+#define Perl_curpad (*__imp_Perl_curpad)
+#define Perl_dc (*__imp_Perl_dc)
+#define Perl_di (*__imp_Perl_di)
+#define Perl_ds (*__imp_Perl_ds)
+#define Perl_egid (*__imp_Perl_egid)
+#define Perl_envgv (*__imp_Perl_envgv)
+#define Perl_error_count (*__imp_Perl_error_count)
+#define Perl_euid (*__imp_Perl_euid)
+#define Perl_evalseq (*__imp_Perl_evalseq)
+#define Perl_expect (*__imp_Perl_expect)
+#define Perl_fold_locale (*__imp_Perl_fold_locale)
+#define Perl_gid (*__imp_Perl_gid)
+#define Perl_he_root (*__imp_Perl_he_root)
+#define Perl_hexdigit (*__imp_Perl_hexdigit)
+#define Perl_hints (*__imp_Perl_hints)
+#define Perl_in_my (*__imp_Perl_in_my)
+#define Perl_last_lop (*__imp_Perl_last_lop)
+#define Perl_last_lop_op (*__imp_Perl_last_lop_op)
+#define Perl_last_uni (*__imp_Perl_last_uni)
+#define Perl_lex_brackets (*__imp_Perl_lex_brackets)
+#define Perl_lex_brackstack (*__imp_Perl_lex_brackstack)
+#define Perl_lex_casemods (*__imp_Perl_lex_casemods)
+#define Perl_lex_casestack (*__imp_Perl_lex_casestack)
+#define Perl_lex_defer (*__imp_Perl_lex_defer)
+#define Perl_lex_dojoin (*__imp_Perl_lex_dojoin)
+#define Perl_lex_expect (*__imp_Perl_lex_expect)
+#define Perl_lex_fakebrack (*__imp_Perl_lex_fakebrack)
+#define Perl_lex_formbrack (*__imp_Perl_lex_formbrack)
+#define Perl_lex_inpat (*__imp_Perl_lex_inpat)
+#define Perl_lex_inwhat (*__imp_Perl_lex_inwhat)
+#define Perl_lex_op (*__imp_Perl_lex_op)
+#define Perl_lex_repl (*__imp_Perl_lex_repl)
+#define Perl_lex_starts (*__imp_Perl_lex_starts)
+#define Perl_lex_state (*__imp_Perl_lex_state)
+#define Perl_lex_stuff (*__imp_Perl_lex_stuff)
+#define Perl_linestr (*__imp_Perl_linestr)
+#define Perl_markstack (*__imp_Perl_markstack)
+#define Perl_markstack_max (*__imp_Perl_markstack_max)
+#define Perl_markstack_ptr (*__imp_Perl_markstack_ptr)
+#define Perl_max_intro_pending (*__imp_Perl_max_intro_pending)
+#define Perl_maxo (*__imp_Perl_maxo)
+#define Perl_min_intro_pending (*__imp_Perl_min_intro_pending)
+#define Perl_multi_close (*__imp_Perl_multi_close)
+#define Perl_multi_end (*__imp_Perl_multi_end)
+#define Perl_multi_open (*__imp_Perl_multi_open)
+#define Perl_multi_start (*__imp_Perl_multi_start)
+#define Perl_na (*__imp_Perl_na)
+#define Perl_nexttoke (*__imp_Perl_nexttoke)
+#define Perl_nexttype (*__imp_Perl_nexttype)
+#define Perl_nextval (*__imp_Perl_nextval)
+#define Perl_nomemok (*__imp_Perl_nomemok)
+#define Perl_numeric_local (*__imp_Perl_numeric_local)
+#define Perl_numeric_name (*__imp_Perl_numeric_name)
+#define Perl_numeric_standard (*__imp_Perl_numeric_standard)
+#define Perl_oldbufptr (*__imp_Perl_oldbufptr)
+#define Perl_oldoldbufptr (*__imp_Perl_oldoldbufptr)
+#define Perl_op (*__imp_Perl_op)
+#define Perl_op_desc (*__imp_Perl_op_desc)
+#define Perl_op_name (*__imp_Perl_op_name)
+#define Perl_op_seqmax (*__imp_Perl_op_seqmax)
+#define Perl_opargs (*__imp_Perl_opargs)
+#define Perl_origalen (*__imp_Perl_origalen)
+#define Perl_origenviron (*__imp_Perl_origenviron)
+#define Perl_osname (*__imp_Perl_osname)
+#define Perl_padix (*__imp_Perl_padix)
+#define Perl_patleave (*__imp_Perl_patleave)
+#define Perl_pidstatus (*__imp_Perl_pidstatus)
+#define Perl_ppaddr (*__imp_Perl_ppaddr)
+#define Perl_profiledata (*__imp_Perl_profiledata)
+#define Perl_psig_name (*__imp_Perl_psig_name)
+#define Perl_psig_ptr (*__imp_Perl_psig_ptr)
+#define Perl_regbol (*__imp_Perl_regbol)
+#define Perl_regcode (*__imp_Perl_regcode)
+#define Perl_regendp (*__imp_Perl_regendp)
+#define Perl_regeol (*__imp_Perl_regeol)
+#define Perl_reginput (*__imp_Perl_reginput)
+#define Perl_reglastparen (*__imp_Perl_reglastparen)
+#define Perl_regnaughty (*__imp_Perl_regnaughty)
+#define Perl_regnpar (*__imp_Perl_regnpar)
+#define Perl_regparse (*__imp_Perl_regparse)
+#define Perl_regprecomp (*__imp_Perl_regprecomp)
+#define Perl_regprev (*__imp_Perl_regprev)
+#define Perl_regsawback (*__imp_Perl_regsawback)
+#define Perl_regsize (*__imp_Perl_regsize)
+#define Perl_regstartp (*__imp_Perl_regstartp)
+#define Perl_regtill (*__imp_Perl_regtill)
+#define Perl_regxend (*__imp_Perl_regxend)
+#define Perl_retstack (*__imp_Perl_retstack)
+#define Perl_retstack_ix (*__imp_Perl_retstack_ix)
+#define Perl_retstack_max (*__imp_Perl_retstack_max)
+#define Perl_rsfp (*__imp_Perl_rsfp)
+#define Perl_rsfp_filters (*__imp_Perl_rsfp_filters)
+#define Perl_savestack (*__imp_Perl_savestack)
+#define Perl_savestack_ix (*__imp_Perl_savestack_ix)
+#define Perl_savestack_max (*__imp_Perl_savestack_max)
+#define Perl_scopestack (*__imp_Perl_scopestack)
+#define Perl_scopestack_ix (*__imp_Perl_scopestack_ix)
+#define Perl_scopestack_max (*__imp_Perl_scopestack_max)
+#define Perl_scrgv (*__imp_Perl_scrgv)
+#define Perl_sh_path (*__imp_Perl_sh_path)
+#define Perl_sig_name (*__imp_Perl_sig_name)
+#define Perl_sig_num (*__imp_Perl_sig_num)
+#define Perl_siggv (*__imp_Perl_siggv)
+#define Perl_stack_base (*__imp_Perl_stack_base)
+#define Perl_stack_max (*__imp_Perl_stack_max)
+#define Perl_stack_sp (*__imp_Perl_stack_sp)
+#define Perl_statbuf (*__imp_Perl_statbuf)
+#define Perl_sub_generation (*__imp_Perl_sub_generation)
+#define Perl_subline (*__imp_Perl_subline)
+#define Perl_subname (*__imp_Perl_subname)
+#define Perl_sv_no (*__imp_Perl_sv_no)
+#define Perl_sv_undef (*__imp_Perl_sv_undef)
+#define Perl_sv_yes (*__imp_Perl_sv_yes)
+#define Perl_tainting (*__imp_Perl_tainting)
+#define Perl_thisexpr (*__imp_Perl_thisexpr)
+#define Perl_timesbuf (*__imp_Perl_timesbuf)
+#define Perl_tokenbuf (*__imp_Perl_tokenbuf)
+#define Perl_uid (*__imp_Perl_uid)
+#define Perl_vert (*__imp_Perl_vert)
+#define Perl_vtbl_amagic (*__imp_Perl_vtbl_amagic)
+#define Perl_vtbl_amagicelem (*__imp_Perl_vtbl_amagicelem)
+#define Perl_vtbl_arylen (*__imp_Perl_vtbl_arylen)
+#define Perl_vtbl_bm (*__imp_Perl_vtbl_bm)
+#define Perl_vtbl_collxfrm (*__imp_Perl_vtbl_collxfrm)
+#define Perl_vtbl_dbline (*__imp_Perl_vtbl_dbline)
+#define Perl_vtbl_env (*__imp_Perl_vtbl_env)
+#define Perl_vtbl_envelem (*__imp_Perl_vtbl_envelem)
+#define Perl_vtbl_fm (*__imp_Perl_vtbl_fm)
+#define Perl_vtbl_glob (*__imp_Perl_vtbl_glob)
+#define Perl_vtbl_isa (*__imp_Perl_vtbl_isa)
+#define Perl_vtbl_isaelem (*__imp_Perl_vtbl_isaelem)
+#define Perl_vtbl_itervar (*__imp_Perl_vtbl_itervar)
+#define Perl_vtbl_mglob (*__imp_Perl_vtbl_mglob)
+#define Perl_vtbl_nkeys (*__imp_Perl_vtbl_nkeys)
+#define Perl_vtbl_pack (*__imp_Perl_vtbl_pack)
+#define Perl_vtbl_packelem (*__imp_Perl_vtbl_packelem)
+#define Perl_vtbl_pos (*__imp_Perl_vtbl_pos)
+#define Perl_vtbl_sig (*__imp_Perl_vtbl_sig)
+#define Perl_vtbl_sigelem (*__imp_Perl_vtbl_sigelem)
+#define Perl_vtbl_substr (*__imp_Perl_vtbl_substr)
+#define Perl_vtbl_sv (*__imp_Perl_vtbl_sv)
+#define Perl_vtbl_taint (*__imp_Perl_vtbl_taint)
+#define Perl_vtbl_uvar (*__imp_Perl_vtbl_uvar)
+#define Perl_vtbl_vec (*__imp_Perl_vtbl_vec)
+#define Perl_xiv_arenaroot (*__imp_Perl_xiv_arenaroot)
+#define Perl_xiv_root (*__imp_Perl_xiv_root)
+#define Perl_xnv_root (*__imp_Perl_xnv_root)
+#define Perl_xpv_root (*__imp_Perl_xpv_root)
+#define Perl_xrv_root (*__imp_Perl_xrv_root)
+#define ampergv (*__imp_ampergv)
+#define argvgv (*__imp_argvgv)
+#define argvoutgv (*__imp_argvoutgv)
+#define basetime (*__imp_basetime)
+#define beginav (*__imp_beginav)
+#define bodytarget (*__imp_bodytarget)
+#define cddir (*__imp_cddir)
+#define chopset (*__imp_chopset)
+#define comppad_name_floor (*__imp_comppad_name_floor)
+#define copline (*__imp_copline)
+#define curpm (*__imp_curpm)
+#define curstack (*__imp_curstack)
+#define curstash (*__imp_curstash)
+#define curstname (*__imp_curstname)
+#define cxstack (*__imp_cxstack)
+#define cxstack_ix (*__imp_cxstack_ix)
+#define cxstack_max (*__imp_cxstack_max)
+#define dbargs (*__imp_dbargs)
+#define debdelim (*__imp_debdelim)
+#define debname (*__imp_debname)
+#define debstash (*__imp_debstash)
+#define debug (*__imp_debug)
+#define defgv (*__imp_defgv)
+#define defoutgv (*__imp_defoutgv)
+#define defstash (*__imp_defstash)
+#define delaymagic (*__imp_delaymagic)
+#define diehook (*__imp_diehook)
+#define dirty (*__imp_dirty)
+#define dlevel (*__imp_dlevel)
+#define dlmax (*__imp_dlmax)
+#define do_undump (*__imp_do_undump)
+#define doextract (*__imp_doextract)
+#define doswitches (*__imp_doswitches)
+#define dowarn (*__imp_dowarn)
+#define dumplvl (*__imp_dumplvl)
+#define e_fp (*__imp_e_fp)
+#define e_tmpname (*__imp_e_tmpname)
+#define endav (*__imp_endav)
+#define errgv (*__imp_errgv)
+#define eval_root (*__imp_eval_root)
+#define eval_start (*__imp_eval_start)
+#define fdpid (*__imp_fdpid)
+#define filemode (*__imp_filemode)
+#define firstgv (*__imp_firstgv)
+#define forkprocess (*__imp_forkprocess)
+#define formfeed (*__imp_formfeed)
+#define formtarget (*__imp_formtarget)
+#define gensym (*__imp_gensym)
+#define in_eval (*__imp_in_eval)
+#define incgv (*__imp_incgv)
+#define inplace (*__imp_inplace)
+#define last_in_gv (*__imp_last_in_gv)
+#define lastfd (*__imp_lastfd)
+#define lastscream (*__imp_lastscream)
+#define lastsize (*__imp_lastsize)
+#define lastspbase (*__imp_lastspbase)
+#define laststatval (*__imp_laststatval)
+#define laststype (*__imp_laststype)
+#define leftgv (*__imp_leftgv)
+#define lineary (*__imp_lineary)
+#define localizing (*__imp_localizing)
+#define localpatches (*__imp_localpatches)
+#define main_cv (*__imp_main_cv)
+#define main_root (*__imp_main_root)
+#define main_start (*__imp_main_start)
+#define mainstack (*__imp_mainstack)
+#define maxscream (*__imp_maxscream)
+#define maxsysfd (*__imp_maxsysfd)
+#define minus_F (*__imp_minus_F)
+#define minus_a (*__imp_minus_a)
+#define minus_c (*__imp_minus_c)
+#define minus_l (*__imp_minus_l)
+#define minus_n (*__imp_minus_n)
+#define minus_p (*__imp_minus_p)
+#define multiline (*__imp_multiline)
+#define mystack_base (*__imp_mystack_base)
+#define mystack_max (*__imp_mystack_max)
+#define mystack_sp (*__imp_mystack_sp)
+#define mystrk (*__imp_mystrk)
+#define nice_chunk (*__imp_nice_chunk)
+#define nice_chunk_size (*__imp_nice_chunk_size)
+#define nrs (*__imp_nrs)
+#define ofmt (*__imp_ofmt)
+#define ofs (*__imp_ofs)
+#define ofslen (*__imp_ofslen)
+#define oldlastpm (*__imp_oldlastpm)
+#define oldname (*__imp_oldname)
+#define op_mask (*__imp_op_mask)
+#define origargc (*__imp_origargc)
+#define origargv (*__imp_origargv)
+#define origfilename (*__imp_origfilename)
+#define ors (*__imp_ors)
+#define orslen (*__imp_orslen)
+#define pad_reset_pending (*__imp_pad_reset_pending)
+#define padix_floor (*__imp_padix_floor)
+#define parsehook (*__imp_parsehook)
+#define patchlevel (*__imp_patchlevel)
+#define perl_destruct_level (*__imp_perl_destruct_level)
+#define perldb (*__imp_perldb)
+#define preambleav (*__imp_preambleav)
+#define preambled (*__imp_preambled)
+#define preprocess (*__imp_preprocess)
+#define regflags (*__imp_regflags)
+#define restartop (*__imp_restartop)
+#define rightgv (*__imp_rightgv)
+#define rs (*__imp_rs)
+#define runlevel (*__imp_runlevel)
+#define sawampersand (*__imp_sawampersand)
+#define sawstudy (*__imp_sawstudy)
+#define sawvec (*__imp_sawvec)
+#define screamfirst (*__imp_screamfirst)
+#define screamnext (*__imp_screamnext)
+#define secondgv (*__imp_secondgv)
+#define signalstack (*__imp_signalstack)
+#define sortcop (*__imp_sortcop)
+#define sortstack (*__imp_sortstack)
+#define sortstash (*__imp_sortstash)
+#define splitstr (*__imp_splitstr)
+#define statcache (*__imp_statcache)
+#define statgv (*__imp_statgv)
+#define statname (*__imp_statname)
+#define statusvalue (*__imp_statusvalue)
+#define stdingv (*__imp_stdingv)
+#define strchop (*__imp_strchop)
+#define strtab (*__imp_strtab)
+#define sv_arenaroot (*__imp_sv_arenaroot)
+#define sv_count (*__imp_sv_count)
+#define sv_objcount (*__imp_sv_objcount)
+#define sv_root (*__imp_sv_root)
+#define tainted (*__imp_tainted)
+#define tmps_floor (*__imp_tmps_floor)
+#define tmps_ix (*__imp_tmps_ix)
+#define tmps_max (*__imp_tmps_max)
+#define tmps_stack (*__imp_tmps_stack)
+#define top_env (*__imp_top_env)
+#define toptarget (*__imp_toptarget)
+#define unsafe (*__imp_unsafe)
+#define warnhook (*__imp_warnhook)
diff --git a/gnu/usr.bin/perl/cygwin32/gcc2 b/gnu/usr.bin/perl/cygwin32/gcc2
new file mode 100644
index 00000000000..3da705cdbf4
--- /dev/null
+++ b/gnu/usr.bin/perl/cygwin32/gcc2
@@ -0,0 +1,12 @@
+#!/bin/sh
+#
+# gcc wrapper for building dynamic lib version of perl
+# if -buildperl found on command line, then all args passed to
+# perlgcc, else pass all args to gcc.
+# jc 3/24/97
+#
+
+case "$*" in
+*-buildperl*) miniperl perlgcc "$@" ;;
+*) gcc "$@" ;;
+esac
diff --git a/gnu/usr.bin/perl/cygwin32/ld2 b/gnu/usr.bin/perl/cygwin32/ld2
new file mode 100644
index 00000000000..9aec8798fed
--- /dev/null
+++ b/gnu/usr.bin/perl/cygwin32/ld2
@@ -0,0 +1,9 @@
+#!/bin/sh
+#
+# ld wrapper for building dynamic lib version of perl;
+# passes all args to ld.
+#
+
+PERLPATH=/perl5.004
+
+$PERLPATH/perl $PERLPATH/perlld "$@"
diff --git a/gnu/usr.bin/perl/cygwin32/perlgcc b/gnu/usr.bin/perl/cygwin32/perlgcc
new file mode 100644
index 00000000000..97d7d1a8a53
--- /dev/null
+++ b/gnu/usr.bin/perl/cygwin32/perlgcc
@@ -0,0 +1,77 @@
+#
+
+# Perl script be a wrapper around the gnu gcc. the exportable perl.exe
+# is built, special processing is done.
+# This script is caled by the gcc2 shell script when the flag
+# -buildperl is passed to gcc2
+
+print "perlgcc: building exportable perl...\n";
+
+# get all libs:
+my @libobs;
+my @obs;
+my @libFlags;
+my $libstring;
+foreach (@ARGV){
+ if( /\.[a]$/){
+ push @libobs,$_;
+ }
+ elsif(/^\-l/){
+ push @libFlags,$_;
+ }
+ if( /\.[o]$/){
+ push @obs,$_;
+ }
+}
+$libstring = join(" ",@libobs);
+$obsString = join(" ",@obs);
+$libflagString = join(" ",@libFlags);
+
+# make exports file
+my $command = "echo EXPORTS > perl.def";
+print "$command\n";
+system($command);
+
+$command ="nm $libstring | grep '^........ [TCD] _'| grep -v _impure_ptr | sed 's/[^_]*_//' >> perl.def";
+print "$command\n";
+system($command);
+
+# Build the perl.a lib to link to:
+$command ="dlltool --as=as --dllname perl.exe --def perl.def --output-lib perl.a";
+print "$command\n";
+system($command);
+
+# change name of export lib to libperlexp so that is can be understood by ld2/perlld
+$command ="mv perl.a libperlexp.a";
+print "$command\n";
+system($command);
+
+# get the full path name of a few libs:
+my $crt0 = `gcc -print-file-name=crt0.o`;
+chomp $crt0;
+my $libdir = `gcc -print-file-name=libcygwin.a`;
+chomp $libdir;
+$libdir =~ s/libcygwin\.a//g;
+
+# Link exe:
+$command = "ld --base-file perl.base -o perl.exe $crt0 $obsString $libstring -L$libdir $libflagString";
+print "$command\n";
+system($command);
+
+$command = "dlltool --as=as --dllname perl.exe --def perl.def --base-file perl.base --output-exp perl.exp";
+print "$command\n";
+system($command);
+
+$command = "ld --base-file perl.base perl.exp -o perl.exe $crt0 $obsString $libstring -L$libdir $libflagString";
+print "$command\n";
+system($command);
+
+$command = "dlltool --as=as --dllname perl.exe --def perl.def --base-file perl.base --output-exp perl.exp";
+print "$command\n";
+system($command);
+
+$command = "ld perl.exp -o perl.exe $crt0 $obsString $libstring -L$libdir $libflagString";
+print "$command\n";
+system($command);
+
+print "perlgcc: Completed\n";
diff --git a/gnu/usr.bin/perl/cygwin32/perlld b/gnu/usr.bin/perl/cygwin32/perlld
new file mode 100644
index 00000000000..1622f2ffaf2
--- /dev/null
+++ b/gnu/usr.bin/perl/cygwin32/perlld
@@ -0,0 +1,192 @@
+#
+# Perl script be a wrapper around the gnu ld. When a dll is specified to
+# to be built, special processing is done, else the standard ld is called.
+#
+# Modified 3/14/97 to include the impure_ptr setup routine in init.cc
+# Modified to make dll in current directory then copy to another dir if
+# a path name specified on the command name with the -o parm.
+#
+
+my $args = join(" ",@ARGV); # get args
+my $arg;
+
+my @objs;
+my @flags;
+my $libname;
+my $init = "init";
+my $fixup = "fixup";
+
+my $path;
+
+
+sub writefixup;
+sub writeInit;
+
+if( $args=~/\-o (.+?)\.dll/i){
+ $libname = $1;
+ # print "libname = <$libname>\n";
+ # Check for path:
+ if( $libname =~ /($\.+?\/)(\w+$)/){
+ $path = $1;
+ $libname = $2;
+ # print "<$path> <$libname>\n";
+ }
+
+ foreach $arg(@ARGV){
+ if( $arg=~/\.[oa]$/){
+ push @objs,$arg;
+ next;
+ }
+ if( $arg =~/\-o/ or $arg =~ /.+?\.dll/i ){
+ next;
+ }
+ push @flags,$arg;
+ }
+
+ writefixup();
+ writeInit();
+ $command = "gcc -c $fixup.c\n";
+ print $command;
+ system($command);
+ $command = "gcc -c $init.cc\n";
+ print $command;
+ system($command);
+
+ $command = "echo EXPORTS > $libname.def\n";
+ print $command;
+ system($command);
+ $command = "nm ".join(" ",@objs)." $init.o $fixup.o | grep '^........ [TCD] _' | sed 's/[^_]*_//' >> $libname.def\n";
+ print $command;
+ system($command);
+
+ $command = "ld --base-file $libname.base --dll -o $libname.dll ".join(" ",@objs)." $init.o $fixup.o ";
+ $command .= join(" ",@flags)." -e _dll_entry\@12 \n";
+ print $command;
+ system($command);
+
+ $command = "dlltool --as=as --dllname $libname.dll --def $libname.def --base-file $libname.base --output-exp $libname.exp\n";
+ print $command;
+ system($command);
+
+ $command = "ld --base-file $libname.base $libname.exp --dll -o $libname.dll ".join(" ",@objs)." $init.o $fixup.o ";
+ $command .= join(" ",@flags)." -e _dll_entry\@12 \n";
+ print $command;
+ system($command);
+
+ $command = "dlltool --as=as --dllname $libname.dll --def $libname.def --base-file $libname.base --output-exp $libname.exp\n";
+ print $command;
+ system($command);
+
+ $command = "ld $libname.exp --dll -o $libname.dll ".join(" ",@objs)." $init.o $fixup.o ";
+ $command .= join(" ",@flags)." -e _dll_entry\@12 \n";
+ print $command;
+ system($command);
+
+ print "Build the import lib\n";
+ $command = "dlltool --as=as --dllname $libname.dll --def $libname.def --output-lib $libname.a\n";
+ print $command;
+ system($command);
+
+ # if there was originally a path, copy the dll and a to that location:
+ if($path && $path ne "./" && $path."\n" ne "`pwd`"){
+ $command = "mv $libname.dll $path".$libname.".dll\n";
+ print $command;
+ system($command);
+ $command = "mv $libname.a $path".$libname.".a\n";
+ print $command;
+ system($command);
+
+ }
+
+}
+else{ # no special processing, just call ld
+ $command = "ld $args\n";
+ print $command;
+ system($command);
+}
+
+#---------------------------------------------------------------------------
+sub writeInit{
+
+open(OUTFILE,">$init.cc") or die("Can't open $init.cc\n");
+
+print OUTFILE <<'EOF';
+/* init.cc for WIN32.
+
+ Copyright 1996 Cygnus Solutions
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
+
+// Added impure_ptr initialization routine. This is needed for any DLL that needs
+// to output to the main (calling) executable's stdout, stderr, etc. This routine
+// needs to be called from the executable using the DLL before any other DLL
+// routines are called. jc 3/14/97
+
+#include <windows.h>
+
+extern "C"
+{
+ int WINAPI dll_entry (HANDLE h, DWORD reason, void *ptr);
+ void impure_setup(struct _reent *_impure_ptrMain);
+};
+
+struct _reent *_impure_ptr; // this will be the Dlls local copy of impure ptr
+
+int WINAPI dll_entry (HANDLE ,
+ DWORD reason,
+ void *)
+{
+ switch (reason)
+ {
+ case DLL_PROCESS_ATTACH:
+ break;
+ case DLL_PROCESS_DETACH:
+ break;
+ case DLL_THREAD_ATTACH:
+ break;
+ case DLL_THREAD_DETACH:
+ break;
+ }
+ return 1;
+}
+
+
+//********************************************
+// Function to set our local (in this dll) copy of impure_ptr to the
+// main's (calling executable's) impure_ptr
+void impure_setup(struct _reent *_impure_ptrMain){
+
+ _impure_ptr = _impure_ptrMain;
+
+}
+EOF
+
+close OUTFILE;
+
+}
+
+#---------------------------------------------------------------------------
+sub writefixup{
+
+open(OUTFILE,">$fixup.c") or die("Can't open $fixup.c\n");
+
+print OUTFILE <<'EOF';
+/* This is needed to terminate the list of inport stuff */
+/* Copied from winsup/dcrt0.cc in the cygwin32 source distribution. */
+ asm(".section .idata$3\n" ".long 0,0,0,0, 0,0,0,0");
+
+EOF
+close OUTFILE;
+}
diff --git a/gnu/usr.bin/perl/deb.c b/gnu/usr.bin/perl/deb.c
index f518b19ad24..8058d1a3b39 100644
--- a/gnu/usr.bin/perl/deb.c
+++ b/gnu/usr.bin/perl/deb.c
@@ -1,6 +1,6 @@
/* deb.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -30,24 +30,24 @@ deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)
register I32 i;
GV* gv = curcop->cop_filegv;
- fprintf(stderr,"(%s:%ld)\t",
+ PerlIO_printf(Perl_debug_log, "(%s:%ld)\t",
SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
(long)curcop->cop_line);
for (i=0; i<dlevel; i++)
- fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
- fprintf(stderr,pat,a1,a2,a3,a4,a5,a6,a7,a8);
+ PerlIO_printf(Perl_debug_log, "%c%c ",debname[i],debdelim[i]);
+ PerlIO_printf(Perl_debug_log, pat,a1,a2,a3,a4,a5,a6,a7,a8);
}
#else /* !defined(I_STDARG) && !defined(I_VARARGS) */
# ifdef I_STDARG
void
-deb(char *pat, ...)
+deb(const char *pat, ...)
# else
/*VARARGS1*/
void
deb(pat, va_alist)
- char *pat;
+ const char *pat;
va_dcl
# endif
{
@@ -55,18 +55,18 @@ deb(pat, va_alist)
register I32 i;
GV* gv = curcop->cop_filegv;
- fprintf(stderr,"(%s:%ld)\t",
+ PerlIO_printf(Perl_debug_log, "(%s:%ld)\t",
SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
(long)curcop->cop_line);
for (i=0; i<dlevel; i++)
- fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
+ PerlIO_printf(Perl_debug_log, "%c%c ",debname[i],debdelim[i]);
# ifdef I_STDARG
va_start(args, pat);
# else
va_start(args);
# endif
- (void) vfprintf(stderr,pat,args);
+ (void) PerlIO_vprintf(Perl_debug_log,pat,args);
va_end( args );
}
#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
@@ -82,13 +82,13 @@ deb_growlevel()
I32
debstackptrs()
{
- fprintf(stderr, "%8lx %8lx %8ld %8ld %8ld\n",
- (unsigned long)stack, (unsigned long)stack_base,
+ PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
+ (unsigned long)curstack, (unsigned long)stack_base,
(long)*markstack_ptr, (long)(stack_sp-stack_base),
(long)(stack_max-stack_base));
- fprintf(stderr, "%8lx %8lx %8ld %8ld %8ld\n",
- (unsigned long)mainstack, (unsigned long)AvARRAY(stack),
- (long)mainstack, (long)AvFILL(stack), (long)AvMAX(stack));
+ PerlIO_printf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
+ (unsigned long)mainstack, (unsigned long)AvARRAY(curstack),
+ (long)mainstack, (long)AvFILL(curstack), (long)AvMAX(curstack));
return 0;
}
@@ -106,25 +106,25 @@ debstack()
if (*markscan >= i)
break;
- fprintf(stderr, i ? " => ... " : " => ");
+ PerlIO_printf(Perl_debug_log, i ? " => ... " : " => ");
if (stack_base[0] != &sv_undef || stack_sp < stack_base)
- fprintf(stderr, " [STACK UNDERFLOW!!!]\n");
+ PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
do {
++i;
if (markscan <= markstack_ptr && *markscan < i) {
do {
++markscan;
- putc('*', stderr);
+ PerlIO_putc(Perl_debug_log, '*');
}
while (markscan <= markstack_ptr && *markscan < i);
- fprintf(stderr, " ");
+ PerlIO_printf(Perl_debug_log, " ");
}
if (i > top)
break;
- fprintf(stderr, "%-4s ", SvPEEK(stack_base[i]));
+ PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
}
while (1);
- fprintf(stderr, "\n");
+ PerlIO_printf(Perl_debug_log, "\n");
return 0;
}
#else
diff --git a/gnu/usr.bin/perl/doio.c b/gnu/usr.bin/perl/doio.c
index f28da95521d..00e2e758859 100644
--- a/gnu/usr.bin/perl/doio.c
+++ b/gnu/usr.bin/perl/doio.c
@@ -1,6 +1,6 @@
/* doio.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -34,7 +34,11 @@
#endif
#ifdef I_UTIME
-#include <utime.h>
+# ifdef _MSC_VER
+# include <sys/utime.h>
+# else
+# include <utime.h>
+# endif
#endif
#ifdef I_FCNTL
#include <fcntl.h>
@@ -43,6 +47,15 @@
#include <sys/file.h>
#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>
@@ -53,6 +66,15 @@
# 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,name,len,as_raw,rawmode,rawperm,supplied_fp)
GV *gv;
@@ -60,21 +82,21 @@ register char *name;
I32 len;
int as_raw;
int rawmode, rawperm;
-FILE *supplied_fp;
+PerlIO *supplied_fp;
{
register IO *io = GvIOn(gv);
- FILE *saveifp = Nullfp;
- FILE *saveofp = Nullfp;
+ PerlIO *saveifp = Nullfp;
+ PerlIO *saveofp = Nullfp;
char savetype = ' ';
int writing = 0;
- FILE *fp;
+ PerlIO *fp;
int fd;
int result;
forkprocess = 1; /* assume true if no fork */
if (IoIFP(io)) {
- fd = fileno(IoIFP(io));
+ fd = PerlIO_fileno(IoIFP(io));
if (IoTYPE(io) == '-')
result = 0;
else if (fd <= maxsysfd) {
@@ -87,16 +109,16 @@ FILE *supplied_fp;
result = my_pclose(IoIFP(io));
else if (IoIFP(io) != IoOFP(io)) {
if (IoOFP(io)) {
- result = fclose(IoOFP(io));
- fclose(IoIFP(io)); /* clear stdio, fd already closed */
+ result = PerlIO_close(IoOFP(io));
+ PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
}
else
- result = fclose(IoIFP(io));
+ result = PerlIO_close(IoIFP(io));
}
else
- result = fclose(IoIFP(io));
+ result = PerlIO_close(IoIFP(io));
if (result == EOF && fd > maxsysfd)
- fprintf(stderr,"Warning: unable to close filehandle %s properly.\n",
+ PerlIO_printf(PerlIO_stderr(), "Warning: unable to close filehandle %s properly.\n",
GvENAME(gv));
IoOFP(io) = IoIFP(io) = Nullfp;
}
@@ -109,9 +131,16 @@ FILE *supplied_fp;
if (fd == -1)
fp = NULL;
else {
- fp = fdopen(fd, ((result == 0) ? "r"
- : (result == 1) ? "w"
- : "r+"));
+ char *fpmode;
+ if (result == 0)
+ fpmode = "r";
+#ifdef O_APPEND
+ else if (rawmode & O_APPEND)
+ fpmode = (result == 1) ? "a" : "a+";
+#endif
+ else
+ fpmode = (result == 1) ? "w" : "r+";
+ fp = PerlIO_fdopen(fd, fpmode);
if (!fp)
close(fd);
}
@@ -183,7 +212,7 @@ FILE *supplied_fp;
goto say_false;
}
if (IoIFP(thatio)) {
- fd = fileno(IoIFP(thatio));
+ fd = PerlIO_fileno(IoIFP(thatio));
if (IoTYPE(thatio) == 's')
IoTYPE(io) = 's';
}
@@ -192,20 +221,21 @@ FILE *supplied_fp;
}
if (dodup)
fd = dup(fd);
- if (!(fp = fdopen(fd,mode)))
+ if (!(fp = PerlIO_fdopen(fd,mode))) {
if (dodup)
close(fd);
+ }
}
}
else {
/*SUPPRESS 530*/
for (; isSPACE(*name); name++) ;
if (strEQ(name,"-")) {
- fp = stdout;
+ fp = PerlIO_stdout();
IoTYPE(io) = '-';
}
else {
- fp = fopen(name,mode);
+ fp = PerlIO_open(name,mode);
}
}
}
@@ -216,11 +246,11 @@ FILE *supplied_fp;
if (*name == '&')
goto duplicity;
if (strEQ(name,"-")) {
- fp = stdin;
+ fp = PerlIO_stdin();
IoTYPE(io) = '-';
}
else
- fp = fopen(name,mode);
+ fp = PerlIO_open(name,mode);
}
else if (name[len-1] == '|') {
name[--len] = '\0';
@@ -239,11 +269,11 @@ FILE *supplied_fp;
/*SUPPRESS 530*/
for (; isSPACE(*name); name++) ;
if (strEQ(name,"-")) {
- fp = stdin;
+ fp = PerlIO_stdin();
IoTYPE(io) = '-';
}
else
- fp = fopen(name,"r");
+ fp = PerlIO_open(name,"r");
}
}
if (!fp) {
@@ -253,8 +283,8 @@ FILE *supplied_fp;
}
if (IoTYPE(io) &&
IoTYPE(io) != '|' && IoTYPE(io) != '-') {
- if (Fstat(fileno(fp),&statbuf) < 0) {
- (void)fclose(fp);
+ if (Fstat(PerlIO_fileno(fp),&statbuf) < 0) {
+ (void)PerlIO_close(fp);
goto say_false;
}
if (S_ISSOCK(statbuf.st_mode))
@@ -267,52 +297,53 @@ FILE *supplied_fp;
!statbuf.st_mode
#endif
) {
- int buflen = sizeof tokenbuf;
- if (getsockname(fileno(fp), (struct sockaddr *)tokenbuf, &buflen) >= 0
- || errno != ENOTSOCK)
+ Sock_size_t buflen = sizeof tokenbuf;
+ if (getsockname(PerlIO_fileno(fp), (struct sockaddr *)tokenbuf,
+ &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 = fileno(saveifp);
+ fd = PerlIO_fileno(saveifp);
if (saveofp) {
- Fflush(saveofp); /* emulate fclose() */
+ PerlIO_flush(saveofp); /* emulate PerlIO_close() */
if (saveofp != saveifp) { /* was a socket? */
- fclose(saveofp);
+ PerlIO_close(saveofp);
if (fd > 2)
Safefree(saveofp);
}
}
- if (fd != fileno(fp)) {
+ if (fd != PerlIO_fileno(fp)) {
int pid;
SV *sv;
- dup2(fileno(fp), fd);
- sv = *av_fetch(fdpid,fileno(fp),TRUE);
+ dup2(PerlIO_fileno(fp), fd);
+ sv = *av_fetch(fdpid,PerlIO_fileno(fp),TRUE);
(void)SvUPGRADE(sv, SVt_IV);
pid = SvIVX(sv);
SvIVX(sv) = 0;
sv = *av_fetch(fdpid,fd,TRUE);
(void)SvUPGRADE(sv, SVt_IV);
SvIVX(sv) = pid;
- fclose(fp);
+ PerlIO_close(fp);
}
fp = saveifp;
- clearerr(fp);
+ PerlIO_clearerr(fp);
}
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fd = fileno(fp);
+ fd = PerlIO_fileno(fp);
fcntl(fd,F_SETFD,fd > maxsysfd);
#endif
IoIFP(io) = fp;
if (writing) {
if (IoTYPE(io) == 's'
|| (IoTYPE(io) == '>' && S_ISCHR(statbuf.st_mode)) ) {
- if (!(IoOFP(io) = fdopen(fileno(fp),"w"))) {
- fclose(fp);
+ if (!(IoOFP(io) = PerlIO_fdopen(PerlIO_fileno(fp),"w"))) {
+ PerlIO_close(fp);
IoIFP(io) = Nullfp;
goto say_false;
}
@@ -329,7 +360,7 @@ say_false:
return FALSE;
}
-FILE *
+PerlIO *
nextargv(gv)
register GV *gv;
{
@@ -344,7 +375,7 @@ register GV *gv;
if (!argvoutgv)
argvoutgv = gv_fetchpv("ARGVOUT",TRUE,SVt_PVIO);
if (filemode & (S_ISUID|S_ISGID)) {
- Fflush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */
+ PerlIO_flush(IoIFP(GvIOn(argvoutgv))); /* chmod must follow last write */
#ifdef HAS_FCHMOD
(void)fchmod(lastfd,filemode);
#else
@@ -408,7 +439,7 @@ register GV *gv;
(void)unlink(SvPVX(sv));
(void)rename(oldname,SvPVX(sv));
do_open(gv,SvPVX(sv),SvCUR(sv),FALSE,0,0,Nullfp);
-#endif /* MSDOS */
+#endif /* DOSISH */
#else
(void)UNLINK(SvPVX(sv));
if (link(oldname,SvPVX(sv)) < 0) {
@@ -421,13 +452,15 @@ register GV *gv;
#endif
}
else {
-#ifndef DOSISH
+#if !defined(DOSISH) && !defined(AMIGAOS)
+# ifndef VMS /* Don't delete; use automatic file versioning */
if (UNLINK(oldname) < 0) {
warn("Can't rename %s to %s: %s, skipping file",
oldname, SvPVX(sv), Strerror(errno) );
do_close(gv,FALSE);
continue;
}
+# endif
#else
croak("Can't do inplace edit without backup");
#endif
@@ -443,12 +476,15 @@ register GV *gv;
continue;
}
setdefout(argvoutgv);
- lastfd = fileno(IoIFP(GvIOp(argvoutgv)));
+ lastfd = PerlIO_fileno(IoIFP(GvIOp(argvoutgv)));
(void)Fstat(lastfd,&statbuf);
#ifdef HAS_FCHMOD
(void)fchmod(lastfd,filemode);
#else
+# if !(defined(WIN32) && defined(__BORLANDC__))
+ /* Borland runtime creates a readonly file! */
(void)chmod(oldname,filemode);
+# endif
#endif
if (fileuid != statbuf.st_uid || filegid != statbuf.st_gid) {
#ifdef HAS_FCHOWN
@@ -463,7 +499,7 @@ register GV *gv;
return IoIFP(GvIOp(gv));
}
else
- fprintf(stderr,"Can't open %s: %s\n",SvPV(sv, na), Strerror(errno));
+ PerlIO_printf(PerlIO_stderr(), "Can't open %s: %s\n",SvPV(sv, na), Strerror(errno));
}
if (inplace) {
(void)do_close(argvoutgv,FALSE);
@@ -498,15 +534,15 @@ GV *wgv;
if (pipe(fd) < 0)
goto badexit;
- IoIFP(rstio) = fdopen(fd[0], "r");
- IoOFP(wstio) = fdopen(fd[1], "w");
+ 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)) fclose(IoIFP(rstio));
+ if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
else close(fd[0]);
- if (IoOFP(wstio)) fclose(IoOFP(wstio));
+ if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
else close(fd[1]);
goto badexit;
}
@@ -520,13 +556,14 @@ badexit:
}
#endif
+/* explicit renamed to avoid C++ conflict -- kja */
bool
#ifndef CAN_PROTOTYPE
-do_close(gv,explicit)
+do_close(gv,not_implicit)
GV *gv;
-bool explicit;
+bool not_implicit;
#else
-do_close(GV *gv, bool explicit)
+do_close(GV *gv, bool not_implicit)
#endif /* CAN_PROTOTYPE */
{
bool retval;
@@ -540,12 +577,12 @@ do_close(GV *gv, bool explicit)
}
io = GvIO(gv);
if (!io) { /* never opened */
- if (dowarn && explicit)
+ if (dowarn && not_implicit)
warn("Close on unopened file <%s>",GvENAME(gv));
return FALSE;
}
retval = io_close(io);
- if (explicit) {
+ if (not_implicit) {
IoLINES(io) = 0;
IoPAGE(io) = 0;
IoLINES_LEFT(io) = IoPAGE_LEN(io);
@@ -564,18 +601,18 @@ IO* io;
if (IoIFP(io)) {
if (IoTYPE(io) == '|') {
status = my_pclose(IoIFP(io));
- retval = (status == 0);
- statusvalue = FIXSTATUS(status);
+ 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 = (fclose(IoOFP(io)) != EOF);
- fclose(IoIFP(io)); /* clear stdio, fd already closed */
+ retval = (PerlIO_close(IoOFP(io)) != EOF);
+ PerlIO_close(IoIFP(io)); /* clear stdio, fd already closed */
}
else
- retval = (fclose(IoIFP(io)) != EOF);
+ retval = (PerlIO_close(IoIFP(io)) != EOF);
}
IoOFP(io) = IoIFP(io) = Nullfp;
}
@@ -597,20 +634,20 @@ GV *gv;
while (IoIFP(io)) {
-#ifdef USE_STDIO_PTR /* (the code works without this) */
- if (FILE_cnt(IoIFP(io)) > 0) /* cheat a little, since */
- return FALSE; /* this is the most usual case */
-#endif
+ 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 = getc(IoIFP(io));
+ ch = PerlIO_getc(IoIFP(io));
if (ch != EOF) {
- (void)ungetc(ch, IoIFP(io));
+ (void)PerlIO_ungetc(IoIFP(io),ch);
return FALSE;
}
-#if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE)
- if (FILE_cnt(IoIFP(io)) < -1)
- FILE_cnt(IoIFP(io)) = -1;
-#endif
+ 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 (op->op_flags & OPf_SPECIAL) { /* not necessarily a real EOF yet? */
if (!nextargv(argvgv)) /* get another fp handy */
return TRUE;
@@ -626,22 +663,15 @@ do_tell(gv)
GV *gv;
{
register IO *io;
+ register PerlIO *fp;
- if (!gv)
- goto phooey;
-
- io = GvIO(gv);
- if (!io || !IoIFP(io))
- goto phooey;
-
+ if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
#ifdef ULTRIX_STDIO_BOTCH
- if (feof(IoIFP(io)))
- (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */
+ if (PerlIO_eof(fp))
+ (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
#endif
-
- return ftell(IoIFP(io));
-
-phooey:
+ return PerlIO_tell(fp);
+ }
if (dowarn)
warn("tell() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
@@ -655,37 +685,46 @@ long pos;
int whence;
{
register IO *io;
+ register PerlIO *fp;
- if (!gv)
- goto nuts;
-
- io = GvIO(gv);
- if (!io || !IoIFP(io))
- goto nuts;
-
+ if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) {
#ifdef ULTRIX_STDIO_BOTCH
- if (feof(IoIFP(io)))
- (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */
+ if (PerlIO_eof(fp))
+ (void)PerlIO_seek(fp, 0L, 2); /* ultrix 1.2 workaround */
#endif
-
- return fseek(IoIFP(io), pos, whence) >= 0;
-
-nuts:
+ return PerlIO_seek(fp, pos, whence) >= 0;
+ }
if (dowarn)
warn("seek() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return FALSE;
}
+long
+do_sysseek(gv, pos, whence)
+GV *gv;
+long pos;
+int whence;
+{
+ register IO *io;
+ register PerlIO *fp;
+
+ if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
+ return lseek(PerlIO_fileno(fp), pos, whence);
+ if (dowarn)
+ warn("sysseek() on unopened file");
+ SETERRNO(EBADF,RMS$_IFI);
+ return -1L;
+}
+
#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
/* code courtesy of William Kucharski */
#define HAS_CHSIZE
-I32 chsize(fd, length)
+I32 my_chsize(fd, length)
I32 fd; /* file descriptor */
Off_t length; /* length to set file to */
{
- extern long lseek();
struct flock fl;
struct stat filebuf;
@@ -729,60 +768,10 @@ Off_t length; /* length to set file to */
}
#endif /* F_FREESP */
-I32
-looks_like_number(sv)
-SV *sv;
-{
- register char *s;
- register char *send;
-
- if (!SvPOK(sv)) {
- STRLEN len;
- if (!SvPOKp(sv))
- return TRUE;
- s = SvPV(sv, len);
- send = s + len;
- }
- else {
- s = SvPVX(sv);
- send = s + SvCUR(sv);
- }
- while (isSPACE(*s))
- s++;
- if (s >= send)
- return FALSE;
- if (*s == '+' || *s == '-')
- s++;
- while (isDIGIT(*s))
- s++;
- if (s == send)
- return TRUE;
- if (*s == '.')
- s++;
- else if (s == SvPVX(sv))
- return FALSE;
- while (isDIGIT(*s))
- s++;
- if (s == send)
- return TRUE;
- if (*s == 'e' || *s == 'E') {
- s++;
- if (*s == '+' || *s == '-')
- s++;
- while (isDIGIT(*s))
- s++;
- }
- while (isSPACE(*s))
- s++;
- if (s >= send)
- return TRUE;
- return FALSE;
-}
-
bool
do_print(sv,fp)
register SV *sv;
-FILE *fp;
+PerlIO *fp;
{
register char *tmps;
STRLEN len;
@@ -794,13 +783,13 @@ FILE *fp;
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvIOK(sv) && SvIVX(sv) != 0) {
- fprintf(fp, ofmt, (double)SvIVX(sv));
- return !ferror(fp);
+ PerlIO_printf(fp, ofmt, (double)SvIVX(sv));
+ return !PerlIO_error(fp);
}
if ( (SvNOK(sv) && SvNVX(sv) != 0.0)
|| (looks_like_number(sv) && sv_2nv(sv) != 0.0) ) {
- fprintf(fp, ofmt, SvNVX(sv));
- return !ferror(fp);
+ PerlIO_printf(fp, ofmt, SvNVX(sv));
+ return !PerlIO_error(fp);
}
}
switch (SvTYPE(sv)) {
@@ -812,17 +801,17 @@ FILE *fp;
if (SvIOK(sv)) {
if (SvGMAGICAL(sv))
mg_get(sv);
- fprintf(fp, "%ld", (long)SvIVX(sv));
- return !ferror(fp);
+ PerlIO_printf(fp, "%ld", (long)SvIVX(sv));
+ return !PerlIO_error(fp);
}
/* FALL THROUGH */
default:
tmps = SvPV(sv, len);
break;
}
- if (len && (fwrite1(tmps,1,len,fp) == 0 || ferror(fp)))
+ if (len && (PerlIO_write(fp,tmps,len) == 0 || PerlIO_error(fp)))
return FALSE;
- return TRUE;
+ return !PerlIO_error(fp);
}
I32
@@ -842,7 +831,7 @@ dARGS
statgv = tmpgv;
sv_setpv(statname,"");
laststype = OP_STAT;
- return (laststatval = Fstat(fileno(IoIFP(io)), &statcache));
+ return (laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache));
}
else {
if (tmpgv == defgv)
@@ -953,6 +942,8 @@ do_execfree()
}
}
+#if !defined(OS2) && !defined(WIN32)
+
bool
do_exec(cmd)
char *cmd;
@@ -1012,7 +1003,7 @@ char *cmd;
break;
}
doshell:
- execl("/bin/sh","sh","-c",cmd,(char*)0);
+ execl(sh_path, "sh", "-c", cmd, (char*)0);
return FALSE;
}
}
@@ -1042,6 +1033,8 @@ char *cmd;
return FALSE;
}
+#endif /* OS2 || WIN32 */
+
I32
apply(type,mark,sp)
I32 type;
@@ -1056,9 +1049,10 @@ register SV **sp;
if (tainting) {
while (++mark <= sp) {
- MAGIC *mg;
- if (SvMAGICAL(*mark) && (mg = mg_find(*mark, 't')) && mg->mg_len & 1)
- tainted = TRUE;
+ if (SvTAINTED(*mark)) {
+ TAINT;
+ break;
+ }
}
mark = oldmark;
}
@@ -1091,6 +1085,8 @@ register SV **sp;
#ifdef HAS_KILL
case OP_KILL:
TAINT_PROPER("kill");
+ if (mark == sp)
+ break;
s = SvPVx(*++mark, na);
tot = sp - mark;
if (isUPPER(*s)) {
@@ -1188,8 +1184,13 @@ register SV **sp;
#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
tot = sp - mark;
while (++mark <= sp) {
if (utime(SvPVx(*mark, na),&utbuf))
@@ -1236,7 +1237,7 @@ register struct stat *statbufp;
*/
return (bit & statbufp->st_mode) ? TRUE : FALSE;
-#else /* ! MSDOS */
+#else /* ! DOSISH */
if ((effective ? euid : uid) == 0) { /* root is special */
if (bit == S_IXUSR) {
if (statbufp->st_mode & 0111 || S_ISDIR(statbufp->st_mode))
@@ -1257,7 +1258,7 @@ register struct stat *statbufp;
else if (statbufp->st_mode & bit >> 6)
return TRUE; /* ok as "other" */
return FALSE;
-#endif /* ! MSDOS */
+#endif /* ! DOSISH */
}
#endif /* ! VMS */
@@ -1332,6 +1333,9 @@ SV **sp;
char *a;
I32 id, n, cmd, infosize, getinfo;
I32 ret = -1;
+#ifdef __linux__ /* XXX Need metaconfig test */
+ union semun unsemds;
+#endif
id = SvIVx(*++mark);
n = (optype == OP_SEMCTL) ? SvIVx(*++mark) : 0;
@@ -1361,7 +1365,21 @@ SV **sp;
else if (cmd == GETALL || cmd == SETALL)
{
struct semid_ds semds;
+#ifdef __linux__ /* XXX Need metaconfig test */
+/* linux (and Solaris2?) uses :
+ int semctl (int semid, int semnum, int cmd, union semun arg)
+ union semun {
+ int val;
+ struct semid_ds *buf;
+ ushort *array;
+ };
+*/
+ union semun semun;
+ semun.buf = &semds;
+ if (semctl(id, 0, IPC_STAT, semun) == -1)
+#else
if (semctl(id, 0, IPC_STAT, &semds) == -1)
+#endif
return -1;
getinfo = (cmd == GETALL);
infosize = semds.sem_nsems * sizeof(short);
@@ -1388,13 +1406,13 @@ SV **sp;
{
a = SvPV(astr, len);
if (len != infosize)
- croak("Bad arg length for %s, is %d, should be %d",
- op_desc[optype], len, infosize);
+ croak("Bad arg length for %s, is %lu, should be %ld",
+ op_desc[optype], (unsigned long)len, (long)infosize);
}
}
else
{
- I32 i = SvIV(astr);
+ IV i = SvIV(astr);
a = (char *)i; /* ouch */
}
SETERRNO(0,0);
@@ -1407,7 +1425,12 @@ SV **sp;
#endif
#ifdef HAS_SEM
case OP_SEMCTL:
+#ifdef __linux__ /* XXX Need metaconfig test */
+ unsemds.buf = (struct semid_ds *)a;
+ ret = semctl(id, n, cmd, unsemds);
+#else
ret = semctl(id, n, cmd, (struct semid_ds *)a);
+#endif
break;
#endif
#ifdef HAS_SHM
diff --git a/gnu/usr.bin/perl/doop.c b/gnu/usr.bin/perl/doop.c
index c906db70d11..571a9aa70db 100644
--- a/gnu/usr.bin/perl/doop.c
+++ b/gnu/usr.bin/perl/doop.c
@@ -1,6 +1,6 @@
/* doop.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -18,14 +18,6 @@
#include <signal.h>
#endif
-#ifdef BUGGY_MSC
- #pragma function(memcmp)
-#endif /* BUGGY_MSC */
-
-#ifdef BUGGY_MSC
- #pragma intrinsic(memcmp)
-#endif /* BUGGY_MSC */
-
I32
do_trans(sv,arg)
SV *sv;
@@ -150,196 +142,18 @@ register SV **sp;
void
do_sprintf(sv,len,sarg)
-register SV *sv;
-register I32 len;
-register SV **sarg;
+SV *sv;
+I32 len;
+SV **sarg;
{
- register char *s;
- register char *t;
- register char *f;
- bool dolong;
-#ifdef HAS_QUAD
- bool doquad;
-#endif /* HAS_QUAD */
- char ch;
- register char *send;
- register SV *arg;
- char *xs;
- I32 xlen;
- I32 pre;
- I32 post;
- double value;
- STRLEN arglen;
-
- sv_setpv(sv,"");
- len--; /* don't count pattern string */
- t = s = SvPV(*sarg, arglen); /* XXX Don't know t is writeable */
- send = s + arglen;
- sarg++;
- for ( ; ; len--) {
-
- /*SUPPRESS 560*/
- if (len <= 0 || !(arg = *sarg++))
- arg = &sv_no;
-
- /*SUPPRESS 530*/
- for ( ; t < send && *t != '%'; t++) ;
- if (t >= send)
- break; /* end of run_format string, ignore extra args */
- f = t;
- *buf = '\0';
- xs = buf;
-#ifdef HAS_QUAD
- doquad =
-#endif /* HAS_QUAD */
- dolong = FALSE;
- pre = post = 0;
- for (t++; t < send; t++) {
- switch (*t) {
- default:
- ch = *(++t);
- *t = '\0';
- (void)sprintf(xs,f);
- len++, sarg--;
- xlen = strlen(xs);
- break;
- case 'n': case '*':
- croak("Use of %c in printf format not supported", *t);
-
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- case '.': case '#': case '-': case '+': case ' ':
- continue;
- case 'l':
-#ifdef HAS_QUAD
- if (dolong) {
- dolong = FALSE;
- doquad = TRUE;
- } else
-#endif
- dolong = TRUE;
- continue;
- case 'c':
- ch = *(++t);
- *t = '\0';
- xlen = SvIV(arg);
- if (strEQ(f,"%c")) { /* some printfs fail on null chars */
- *xs = xlen;
- xs[1] = '\0';
- xlen = 1;
- }
- else {
- (void)sprintf(xs,f,xlen);
- xlen = strlen(xs);
- }
- break;
- case 'D':
- dolong = TRUE;
- /* FALL THROUGH */
- case 'd':
- ch = *(++t);
- *t = '\0';
-#ifdef HAS_QUAD
- if (doquad)
- (void)sprintf(buf,s,(Quad_t)SvNV(arg));
- else
-#endif
- if (dolong)
- (void)sprintf(xs,f,(long)SvNV(arg));
- else
- (void)sprintf(xs,f,SvIV(arg));
- xlen = strlen(xs);
- break;
- case 'X': case 'O':
- dolong = TRUE;
- /* FALL THROUGH */
- case 'x': case 'o': case 'u':
- ch = *(++t);
- *t = '\0';
- value = SvNV(arg);
-#ifdef HAS_QUAD
- if (doquad)
- (void)sprintf(buf,s,(unsigned Quad_t)value);
- else
-#endif
- if (dolong)
- (void)sprintf(xs,f,U_L(value));
- else
- (void)sprintf(xs,f,U_I(value));
- xlen = strlen(xs);
- break;
- case 'E': case 'e': case 'f': case 'G': case 'g':
- ch = *(++t);
- *t = '\0';
- (void)sprintf(xs,f,SvNV(arg));
- xlen = strlen(xs);
- break;
- case 's':
- ch = *(++t);
- *t = '\0';
- xs = SvPV(arg, arglen);
- xlen = (I32)arglen;
- if (strEQ(f,"%s")) { /* some printfs fail on >128 chars */
- break; /* so handle simple cases */
- }
- else if (f[1] == '-') {
- char *mp = strchr(f, '.');
- I32 min = atoi(f+2);
-
- if (mp) {
- I32 max = atoi(mp+1);
-
- if (xlen > max)
- xlen = max;
- }
- if (xlen < min)
- post = min - xlen;
- break;
- }
- else if (isDIGIT(f[1])) {
- char *mp = strchr(f, '.');
- I32 min = atoi(f+1);
-
- if (mp) {
- I32 max = atoi(mp+1);
-
- if (xlen > max)
- xlen = max;
- }
- if (xlen < min)
- pre = min - xlen;
- break;
- }
- strcpy(tokenbuf+64,f); /* sprintf($s,...$s...) */
- *t = ch;
- (void)sprintf(buf,tokenbuf+64,xs);
- xs = buf;
- xlen = strlen(xs);
- break;
- }
- /* end of switch, copy results */
- *t = ch;
- if (xs == buf && xlen >= sizeof(buf)) { /* Ooops! */
- fputs("panic: sprintf overflow - memory corrupted!\n",stderr);
- my_exit(1);
- }
- SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
- sv_catpvn(sv, s, f - s);
- if (pre) {
- repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, pre);
- SvCUR(sv) += pre;
- }
- sv_catpvn(sv, xs, xlen);
- if (post) {
- repeatcpy(SvPVX(sv) + SvCUR(sv), " ", 1, post);
- SvCUR(sv) += post;
- }
- s = t;
- break; /* break from for loop */
- }
- }
- sv_catpvn(sv, s, t - s);
+ 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
@@ -494,11 +308,11 @@ register SV *sv;
++count;
}
else {
- if (len < rslen)
+ if (len < rslen - 1)
goto nope;
len -= rslen - 1;
s -= rslen - 1;
- if (bcmp(s, rsptr, rslen))
+ if (memNE(s, rsptr, rslen))
goto nope;
count += rslen;
}
@@ -527,17 +341,32 @@ SV *right;
register char *dc;
STRLEN leftlen;
STRLEN rightlen;
- register char *lc = SvPV(left, leftlen);
- register char *rc = SvPV(right, rightlen);
+ register char *lc;
+ register char *rc;
register I32 len;
I32 lensave;
+ char *lsave;
+ char *rsave;
- dc = SvPV_force(sv,na);
+ 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 (SvCUR(sv) < len) {
- dc = SvGROW(sv,len + 1);
- (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1);
+ if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
+ dc = SvPV_force(sv, 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);
@@ -588,9 +417,6 @@ SV *right;
}
#endif
{
- char *lsave = lc;
- char *rsave = rc;
-
switch (optype) {
case OP_BIT_AND:
while (len--)
@@ -614,6 +440,7 @@ SV *right;
break;
}
}
+ SvTAINT(sv);
}
OP *
@@ -622,24 +449,45 @@ dARGS
{
dSP;
HV *hv = (HV*)POPs;
- I32 i;
register HE *entry;
- char *tmps;
SV *tmpstr;
+ I32 gimme = GIMME_V;
I32 dokeys = (op->op_type == OP_KEYS);
I32 dovalues = (op->op_type == OP_VALUES);
if (op->op_type == OP_RV2HV || op->op_type == OP_PADHV)
dokeys = dovalues = TRUE;
- if (!hv)
+ if (!hv) {
+ if (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;
+ }
(void)hv_iterinit(hv); /* always reset iterator regardless */
- if (GIMME != G_ARRAY) {
+ if (gimme == G_VOID)
+ RETURN;
+
+ if (gimme == G_SCALAR) {
+ I32 i;
dTARGET;
+ if (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';
+ LvTARG(TARG) = (SV*)hv;
+ PUSHs(TARG);
+ RETURN;
+ }
+
if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P'))
i = HvKEYS(hv);
else {
@@ -659,23 +507,18 @@ dARGS
PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
while (entry = hv_iternext(hv)) {
SPAGAIN;
- if (dokeys) {
- tmps = hv_iterkey(entry,&i); /* won't clobber stack_sp */
- if (!i)
- tmps = "";
- XPUSHs(sv_2mortal(newSVpv(tmps,i)));
- }
+ if (dokeys)
+ XPUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
if (dovalues) {
- tmpstr = NEWSV(45,0);
+ tmpstr = sv_newmortal();
PUTBACK;
sv_setsv(tmpstr,hv_iterval(hv,entry));
+ DEBUG_H(sv_setpvf(tmpstr, "%lu%%%d=%lu",
+ (unsigned long)HeHASH(entry),
+ HvMAX(hv)+1,
+ (unsigned long)(HeHASH(entry) & HvMAX(hv))));
SPAGAIN;
- DEBUG_H( {
- sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
- HvMAX(hv)+1,entry->hent_hash & HvMAX(hv));
- sv_setpv(tmpstr,buf);
- } )
- XPUSHs(sv_2mortal(tmpstr));
+ XPUSHs(tmpstr);
}
PUTBACK;
}
diff --git a/gnu/usr.bin/perl/dosish.h b/gnu/usr.bin/perl/dosish.h
index e40e358b75a..1b251ef3104 100644
--- a/gnu/usr.bin/perl/dosish.h
+++ b/gnu/usr.bin/perl/dosish.h
@@ -1,11 +1,84 @@
#define ABORT() abort();
-#define BIT_BUCKET "\dev\nul"
-#define PERL_SYS_INIT(c,v)
+#ifndef SH_PATH
+#define SH_PATH "/bin/sh"
+#endif
+
+#ifdef DJGPP
+# define BIT_BUCKET "nul"
+# define OP_BINARY O_BINARY
+void Perl_DJGPP_init();
+# define PERL_SYS_INIT(argcp, argvp) STMT_START { \
+ Perl_DJGPP_init(); } STMT_END
+#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()
-#define dXSUB_SYS int dummy
+#define dXSUB_SYS
#define TMPPATH "plXXXXXX"
+#ifdef WIN32
+#define HAS_UTIME
+#define HAS_KILL
+#endif
+
+/*
+ * 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
+
+/* 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
@@ -14,8 +87,19 @@
*/
#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))
-#define my_getenv(var) getenv(var)
+#ifndef WIN32
+# define Stat(fname,bufptr) stat((fname),(bufptr))
+#else
+# define Stat(fname,bufptr) win32_stat((fname),(bufptr))
+# define my_getenv(var) getenv(var)
+/*
+ * the following are standard library calls (stdio in particular)
+ * that is being redirected to the perl DLL. This is needed for
+ * Dynaloading any modules that called stdio functions
+ */
+# include <win32iop.h>
+#endif /* WIN32 */
diff --git a/gnu/usr.bin/perl/dump.c b/gnu/usr.bin/perl/dump.c
index 19300e1fa86..9bd51acc008 100644
--- a/gnu/usr.bin/perl/dump.c
+++ b/gnu/usr.bin/perl/dump.c
@@ -1,6 +1,6 @@
/* dump.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -22,16 +22,16 @@ dump_all()
}
#else /* Rest of file is for DEBUGGING */
+#ifdef I_STDARG
+static void dump(char *pat, ...);
+#else
static void dump();
+#endif
void
dump_all()
{
-#ifdef HAS_SETLINEBUF
- setlinebuf(stderr);
-#else
- setvbuf(stderr, Nullch, _IOLBF, 0);
-#endif
+ PerlIO_setlinebuf(Perl_debug_log);
if (main_root)
dump_op(main_root);
dump_packsubs(defstash);
@@ -47,14 +47,14 @@ HV* stash;
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
- for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
- GV *gv = (GV*)entry->hent_val;
+ for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
+ GV *gv = (GV*)HeVAL(entry);
HV *hv;
- if (GvCV(gv))
+ if (GvCVu(gv))
dump_sub(gv);
if (GvFORM(gv))
dump_form(gv);
- if (entry->hent_key[entry->hent_klen-1] == ':' &&
+ if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
(hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
dump_packsubs(hv); /* nested package */
}
@@ -67,7 +67,7 @@ GV* gv;
{
SV *sv = sv_newmortal();
- gv_fullname(sv,gv);
+ gv_fullname3(sv, gv, Nullch);
dump("\nSUB %s = ", SvPVX(sv));
if (CvXSUB(GvCV(gv)))
dump("(xsub 0x%x %d)\n",
@@ -85,7 +85,7 @@ GV* gv;
{
SV *sv = sv_newmortal();
- gv_fullname(sv,gv);
+ gv_fullname3(sv, gv, Nullch);
dump("\nFORMAT %s = ", SvPVX(sv));
if (CvROOT(GvFORM(gv)))
dump_op(CvROOT(GvFORM(gv)));
@@ -103,22 +103,20 @@ void
dump_op(op)
register OP *op;
{
- SV *tmpsv;
-
dump("{\n");
if (op->op_seq)
- fprintf(stderr, "%-4d", op->op_seq);
+ PerlIO_printf(Perl_debug_log, "%-4d", op->op_seq);
else
- fprintf(stderr, " ");
+ PerlIO_printf(Perl_debug_log, " ");
dump("TYPE = %s ===> ", op_name[op->op_type]);
if (op->op_next) {
if (op->op_seq)
- fprintf(stderr, "%d\n", op->op_next->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", op->op_next->op_seq);
else
- fprintf(stderr, "(%d)\n", op->op_next->op_seq);
+ PerlIO_printf(Perl_debug_log, "(%d)\n", op->op_next->op_seq);
}
else
- fprintf(stderr, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
dumplvl++;
if (op->op_targ) {
if (op->op_type == OP_NULL)
@@ -130,52 +128,57 @@ register OP *op;
dump("ADDR = 0x%lx => 0x%lx\n",op, op->op_next);
#endif
if (op->op_flags) {
- *buf = '\0';
- if (op->op_flags & OPf_KNOW) {
- if (op->op_flags & OPf_LIST)
- (void)strcat(buf,"LIST,");
- else
- (void)strcat(buf,"SCALAR,");
+ SV *tmpsv = newSVpv("", 0);
+ switch (op->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;
}
- else
- (void)strcat(buf,"UNKNOWN,");
if (op->op_flags & OPf_KIDS)
- (void)strcat(buf,"KIDS,");
+ sv_catpv(tmpsv, ",KIDS");
if (op->op_flags & OPf_PARENS)
- (void)strcat(buf,"PARENS,");
+ sv_catpv(tmpsv, ",PARENS");
if (op->op_flags & OPf_STACKED)
- (void)strcat(buf,"STACKED,");
+ sv_catpv(tmpsv, ",STACKED");
if (op->op_flags & OPf_REF)
- (void)strcat(buf,"REF,");
+ sv_catpv(tmpsv, ",REF");
if (op->op_flags & OPf_MOD)
- (void)strcat(buf,"MOD,");
+ sv_catpv(tmpsv, ",MOD");
if (op->op_flags & OPf_SPECIAL)
- (void)strcat(buf,"SPECIAL,");
- if (*buf)
- buf[strlen(buf)-1] = '\0';
- dump("FLAGS = (%s)\n",buf);
+ sv_catpv(tmpsv, ",SPECIAL");
+ dump("FLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
+ SvREFCNT_dec(tmpsv);
}
if (op->op_private) {
- *buf = '\0';
+ SV *tmpsv = newSVpv("", 0);
if (op->op_type == OP_AASSIGN) {
if (op->op_private & OPpASSIGN_COMMON)
- (void)strcat(buf,"COMMON,");
+ sv_catpv(tmpsv, ",COMMON");
}
else if (op->op_type == OP_SASSIGN) {
if (op->op_private & OPpASSIGN_BACKWARDS)
- (void)strcat(buf,"BACKWARDS,");
+ sv_catpv(tmpsv, ",BACKWARDS");
}
else if (op->op_type == OP_TRANS) {
if (op->op_private & OPpTRANS_SQUASH)
- (void)strcat(buf,"SQUASH,");
+ sv_catpv(tmpsv, ",SQUASH");
if (op->op_private & OPpTRANS_DELETE)
- (void)strcat(buf,"DELETE,");
+ sv_catpv(tmpsv, ",DELETE");
if (op->op_private & OPpTRANS_COMPLEMENT)
- (void)strcat(buf,"COMPLEMENT,");
+ sv_catpv(tmpsv, ",COMPLEMENT");
}
else if (op->op_type == OP_REPEAT) {
if (op->op_private & OPpREPEAT_DOLIST)
- (void)strcat(buf,"DOLIST,");
+ sv_catpv(tmpsv, ",DOLIST");
}
else if (op->op_type == OP_ENTERSUB ||
op->op_type == OP_RV2SV ||
@@ -185,45 +188,59 @@ register OP *op;
op->op_type == OP_AELEM ||
op->op_type == OP_HELEM )
{
- if (op->op_private & OPpENTERSUB_AMPER)
- (void)strcat(buf,"AMPER,");
- if (op->op_private & OPpENTERSUB_DB)
- (void)strcat(buf,"DB,");
- if (op->op_private & OPpDEREF_AV)
- (void)strcat(buf,"AV,");
- if (op->op_private & OPpDEREF_HV)
- (void)strcat(buf,"HV,");
- if (op->op_private & HINT_STRICT_REFS)
- (void)strcat(buf,"STRICT_REFS,");
+ if (op->op_type == OP_ENTERSUB) {
+ if (op->op_private & OPpENTERSUB_AMPER)
+ sv_catpv(tmpsv, ",AMPER");
+ if (op->op_private & OPpENTERSUB_DB)
+ sv_catpv(tmpsv, ",DB");
+ }
+ switch (op->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 (op->op_type == OP_AELEM || op->op_type == OP_HELEM) {
+ if (op->op_private & OPpLVAL_DEFER)
+ sv_catpv(tmpsv, ",LVAL_DEFER");
+ }
+ else {
+ if (op->op_private & HINT_STRICT_REFS)
+ sv_catpv(tmpsv, ",STRICT_REFS");
+ }
}
else if (op->op_type == OP_CONST) {
if (op->op_private & OPpCONST_BARE)
- (void)strcat(buf,"BARE,");
+ sv_catpv(tmpsv, ",BARE");
}
else if (op->op_type == OP_FLIP) {
if (op->op_private & OPpFLIP_LINENUM)
- (void)strcat(buf,"LINENUM,");
+ sv_catpv(tmpsv, ",LINENUM");
}
else if (op->op_type == OP_FLOP) {
if (op->op_private & OPpFLIP_LINENUM)
- (void)strcat(buf,"LINENUM,");
+ sv_catpv(tmpsv, ",LINENUM");
}
if (op->op_flags & OPf_MOD && op->op_private & OPpLVAL_INTRO)
- (void)strcat(buf,"INTRO,");
- if (*buf) {
- buf[strlen(buf)-1] = '\0';
- dump("PRIVATE = (%s)\n",buf);
- }
+ sv_catpv(tmpsv, ",INTRO");
+ if (SvCUR(tmpsv))
+ dump("PRIVATE = (%s)\n", SvPVX(tmpsv) + 1);
+ SvREFCNT_dec(tmpsv);
}
switch (op->op_type) {
case OP_GVSV:
case OP_GV:
if (cGVOP->op_gv) {
+ SV *tmpsv = NEWSV(0,0);
ENTER;
- tmpsv = NEWSV(0,0);
SAVEFREESV(tmpsv);
- gv_fullname(tmpsv,cGVOP->op_gv);
+ gv_fullname3(tmpsv, cGVOP->op_gv, Nullch);
dump("GV = %s\n", SvPV(tmpsv, na));
LEAVE;
}
@@ -243,31 +260,31 @@ register OP *op;
case OP_ENTERLOOP:
dump("REDO ===> ");
if (cLOOP->op_redoop)
- fprintf(stderr, "%d\n", cLOOP->op_redoop->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq);
else
- fprintf(stderr, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
dump("NEXT ===> ");
if (cLOOP->op_nextop)
- fprintf(stderr, "%d\n", cLOOP->op_nextop->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq);
else
- fprintf(stderr, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
dump("LAST ===> ");
if (cLOOP->op_lastop)
- fprintf(stderr, "%d\n", cLOOP->op_lastop->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq);
else
- fprintf(stderr, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
break;
case OP_COND_EXPR:
dump("TRUE ===> ");
if (cCONDOP->op_true)
- fprintf(stderr, "%d\n", cCONDOP->op_true->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_true->op_seq);
else
- fprintf(stderr, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
dump("FALSE ===> ");
if (cCONDOP->op_false)
- fprintf(stderr, "%d\n", cCONDOP->op_false->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq);
else
- fprintf(stderr, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
break;
case OP_MAPWHILE:
case OP_GREPWHILE:
@@ -275,9 +292,9 @@ register OP *op;
case OP_AND:
dump("OTHER ===> ");
if (cLOGOP->op_other)
- fprintf(stderr, "%d\n", cLOGOP->op_other->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq);
else
- fprintf(stderr, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
break;
case OP_PUSHRE:
case OP_MATCH:
@@ -303,16 +320,16 @@ register GV *gv;
SV *sv;
if (!gv) {
- fprintf(stderr,"{}\n");
+ PerlIO_printf(Perl_debug_log, "{}\n");
return;
}
sv = sv_newmortal();
dumplvl++;
- fprintf(stderr,"{\n");
- gv_fullname(sv,gv);
+ PerlIO_printf(Perl_debug_log, "{\n");
+ gv_fullname3(sv, gv, Nullch);
dump("GV_NAME = %s", SvPVX(sv));
if (gv != GvEGV(gv)) {
- gv_efullname(sv,GvEGV(gv));
+ gv_efullname3(sv, GvEGV(gv), Nullch);
dump("-> %s", SvPVX(sv));
}
dump("\n");
@@ -337,7 +354,11 @@ register PMOP *pm;
else
ch = '/';
if (pm->op_pmregexp)
- dump("PMf_PRE %c%s%c\n",ch,pm->op_pmregexp->precomp,ch);
+ 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);
@@ -346,38 +367,37 @@ register PMOP *pm;
dump("PMf_SHORT = %s\n",SvPEEK(pm->op_pmshort));
}
if (pm->op_pmflags) {
- *buf = '\0';
+ SV *tmpsv = newSVpv("", 0);
if (pm->op_pmflags & PMf_USED)
- (void)strcat(buf,"USED,");
+ sv_catpv(tmpsv, ",USED");
if (pm->op_pmflags & PMf_ONCE)
- (void)strcat(buf,"ONCE,");
+ sv_catpv(tmpsv, ",ONCE");
if (pm->op_pmflags & PMf_SCANFIRST)
- (void)strcat(buf,"SCANFIRST,");
+ sv_catpv(tmpsv, ",SCANFIRST");
if (pm->op_pmflags & PMf_ALL)
- (void)strcat(buf,"ALL,");
+ sv_catpv(tmpsv, ",ALL");
if (pm->op_pmflags & PMf_SKIPWHITE)
- (void)strcat(buf,"SKIPWHITE,");
- if (pm->op_pmflags & PMf_FOLD)
- (void)strcat(buf,"FOLD,");
+ sv_catpv(tmpsv, ",SKIPWHITE");
if (pm->op_pmflags & PMf_CONST)
- (void)strcat(buf,"CONST,");
+ sv_catpv(tmpsv, ",CONST");
if (pm->op_pmflags & PMf_KEEP)
- (void)strcat(buf,"KEEP,");
+ sv_catpv(tmpsv, ",KEEP");
if (pm->op_pmflags & PMf_GLOBAL)
- (void)strcat(buf,"GLOBAL,");
- if (pm->op_pmflags & PMf_RUNTIME)
- (void)strcat(buf,"RUNTIME,");
+ sv_catpv(tmpsv, ",GLOBAL");
+ if (pm->op_pmflags & PMf_CONTINUE)
+ sv_catpv(tmpsv, ",CONTINUE");
if (pm->op_pmflags & PMf_EVAL)
- (void)strcat(buf,"EVAL,");
- if (*buf)
- buf[strlen(buf)-1] = '\0';
- dump("PMFLAGS = (%s)\n",buf);
+ sv_catpv(tmpsv, ",EVAL");
+ dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
+ SvREFCNT_dec(tmpsv);
}
dumplvl--;
dump("}\n");
}
+
+#if !defined(I_STDARG) && !defined(I_VARARGS)
/* VARARGS1 */
static void dump(arg1,arg2,arg3,arg4,arg5)
char *arg1;
@@ -386,7 +406,36 @@ long arg2, arg3, arg4, arg5;
I32 i;
for (i = dumplvl*4; i; i--)
- (void)putc(' ',stderr);
- fprintf(stderr,arg1, arg2, arg3, arg4, arg5);
+ (void)PerlIO_putc(Perl_debug_log,' ');
+ PerlIO_printf(Perl_debug_log, arg1, arg2, arg3, arg4, arg5);
}
+
+#else
+
+#ifdef I_STDARG
+static void
+dump(char *pat,...)
+#else
+/*VARARGS0*/
+static void
+dump(pat,va_alist)
+ char *pat;
+ va_dcl
+#endif
+{
+ I32 i;
+ va_list args;
+
+#ifdef I_STDARG
+ va_start(args, pat);
+#else
+ va_start(args);
+#endif
+ for (i = dumplvl*4; i; i--)
+ (void)PerlIO_putc(Perl_debug_log,' ');
+ PerlIO_vprintf(Perl_debug_log,pat,args);
+ va_end(args);
+}
+#endif
+
#endif
diff --git a/gnu/usr.bin/perl/eg/ADB b/gnu/usr.bin/perl/eg/ADB
index ee214f3d893..bbf07509ccf 100644
--- a/gnu/usr.bin/perl/eg/ADB
+++ b/gnu/usr.bin/perl/eg/ADB
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: ADB,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:52 $
+# $RCSfile: ADB,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:35 $
# This script is only useful when used in your crash directory.
diff --git a/gnu/usr.bin/perl/eg/README b/gnu/usr.bin/perl/eg/README
index 87cfc334f14..15eb6551a37 100644
--- a/gnu/usr.bin/perl/eg/README
+++ b/gnu/usr.bin/perl/eg/README
@@ -13,7 +13,7 @@ of a system to check on and report various kinds of anomalies.
If you machine doesn't support #!, the first thing you'll want to do is
replace the #! with a couple of lines that look like this:
- eval "exec /usr/bin/perl -S $0 $*"
+ eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
being sure to include any flags that were on the #! line. A supplied script
diff --git a/gnu/usr.bin/perl/eg/cgi/RunMeFirst b/gnu/usr.bin/perl/eg/cgi/RunMeFirst
new file mode 100644
index 00000000000..c96d79eb628
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/RunMeFirst
@@ -0,0 +1,29 @@
+#!/usr/local/bin/perl
+
+# Make a world-writeable directory for saving state.
+$ww = 'WORLD_WRITABLE';
+unless (-w $ww) {
+ $u = umask 0;
+ mkdir $ww, 0777;
+ umask $u;
+}
+
+# Decode the sample image.
+for $bin (qw(wilogo.gif)) {
+ unless (open UU, "$bin.uu") { warn "Can't open $bin.uu: $!\n"; next }
+ unless (open BIN, "> $bin") { warn "Can't create $bin: $!\n"; next }
+ $_ = <UU>;
+ while (<UU>) {
+ chomp;
+ last if /^end/;
+ print BIN unpack "u", $_;
+ }
+ close BIN;
+ close UU;
+}
+
+# Create symlinks from *.txt to *.cgi for documentation purposes.
+foreach (<*.cgi>) {
+ ($target = $_) =~ s/cgi$/txt/;
+ symlink $_, $target unless -e $target;
+}
diff --git a/gnu/usr.bin/perl/eg/cgi/clickable_image.cgi b/gnu/usr.bin/perl/eg/cgi/clickable_image.cgi
new file mode 100644
index 00000000000..81daf09690f
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/clickable_image.cgi
@@ -0,0 +1,26 @@
+#!/usr/local/bin/perl
+
+use CGI;
+$query = new CGI;
+print $query->header;
+print $query->start_html("A Clickable Image");
+print <<END;
+<H1>A Clickable Image</H1>
+</A>
+END
+print "Sorry, this isn't very exciting!\n";
+
+print $query->startform;
+print $query->image_button('picture',"./wilogo.gif");
+print "Give me a: ",$query->popup_menu('letter',['A','B','C','D','E','W']),"\n"; #
+print "<P>Magnification: ",$query->radio_group('magnification',['1X','2X','4X','20X']),"\n";
+print "<HR>\n";
+
+if ($query->param) {
+ print "<P>Magnification, <EM>",$query->param('magnification'),"</EM>\n";
+ print "<P>Selected Letter, <EM>",$query->param('letter'),"</EM>\n";
+ ($x,$y) = ($query->param('picture.x'),$query->param('picture.y'));
+ print "<P>Selected Position <EM>($x,$y)</EM>\n";
+}
+
+print $query->end_html;
diff --git a/gnu/usr.bin/perl/eg/cgi/cookie.cgi b/gnu/usr.bin/perl/eg/cgi/cookie.cgi
new file mode 100644
index 00000000000..98adda196ed
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/cookie.cgi
@@ -0,0 +1,88 @@
+#!/usr/local/bin/perl
+
+use CGI qw(:standard);
+
+@ANIMALS=sort qw/lion tiger bear pig porcupine ferret zebra gnu ostrich
+ emu moa goat weasel yak chicken sheep hyena dodo lounge-lizard
+ squirrel rat mouse hedgehog racoon baboon kangaroo hippopotamus
+ giraffe/;
+
+# Recover the previous animals from the magic cookie.
+# The cookie has been formatted as an associative array
+# mapping animal name to the number of animals.
+%zoo = cookie('animals');
+
+# Recover the new animal(s) from the parameter 'new_animal'
+@new = param('new_animals');
+
+# If the action is 'add', then add new animals to the zoo. Otherwise
+# delete them.
+foreach (@new) {
+ if (param('action') eq 'Add') {
+ $zoo{$_}++;
+ } elsif (param('action') eq 'Delete') {
+ $zoo{$_}-- if $zoo{$_};
+ delete $zoo{$_} unless $zoo{$_};
+ }
+}
+
+# Add new animals to old, and put them in a cookie
+$the_cookie = cookie(-name=>'animals',
+ -value=>\%zoo,
+ -expires=>'+1h');
+
+# Print the header, incorporating the cookie and the expiration date...
+print header(-cookie=>$the_cookie);
+
+# Now we're ready to create our HTML page.
+print start_html('Animal crackers');
+
+print <<EOF;
+<h1>Animal Crackers</h1>
+Choose the animals you want to add to the zoo, and click "add".
+Come back to this page any time within the next hour and the list of
+animals in the zoo will be resurrected. You can even quit Netscape
+completely!
+<p>
+Try adding the same animal several times to the list. Does this
+remind you vaguely of a shopping cart?
+<p>
+<em>This script only works with Netscape browsers</em>
+<p>
+<center>
+<table border>
+<tr><th>Add/Delete<th>Current Contents
+EOF
+ ;
+
+print "<tr><td>",start_form;
+print scrolling_list(-name=>'new_animals',
+ -values=>[@ANIMALS],
+ -multiple=>1,
+ -override=>1,
+ -size=>10),"<br>";
+print submit(-name=>'action',-value=>'Delete'),
+ submit(-name=>'action',-value=>'Add');
+print end_form;
+
+print "<td>";
+if (%zoo) { # make a table
+ print "<ul>\n";
+ foreach (sort keys %zoo) {
+ print "<li>$zoo{$_} $_\n";
+ }
+ print "</ul>\n";
+} else {
+ print "<strong>The zoo is empty.</strong>\n";
+}
+print "</table></center>";
+
+print <<EOF;
+<hr>
+<ADDRESS>Lincoln D. Stein</ADDRESS><BR>
+<A HREF="./">More Examples</A>
+EOF
+ ;
+print end_html;
+
+
diff --git a/gnu/usr.bin/perl/eg/cgi/crash.cgi b/gnu/usr.bin/perl/eg/cgi/crash.cgi
new file mode 100644
index 00000000000..64f03c7b3db
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/crash.cgi
@@ -0,0 +1,6 @@
+#!/usr/local/bin/perl
+
+use CGI::Carp qw(fatalsToBrowser);
+
+# This line invokes a fatal error message at compile time.
+foo bar baz;
diff --git a/gnu/usr.bin/perl/eg/cgi/customize.cgi b/gnu/usr.bin/perl/eg/cgi/customize.cgi
new file mode 100644
index 00000000000..c1c81875144
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/customize.cgi
@@ -0,0 +1,92 @@
+#!/usr/local/bin/perl
+
+use CGI qw(:standard :html3);
+
+# Some constants to use in our form.
+@colors=qw/aqua black blue fuschia gray green lime maroon navy olive
+ purple red silver teal white yellow/;
+@sizes=("<default>",1..7);
+
+# recover the "preferences" cookie.
+%preferences = cookie('preferences');
+
+# If the user wants to change the background color or her
+# name, they will appear among our CGI parameters.
+foreach ('text','background','name','size') {
+ $preferences{$_} = param($_) || $preferences{$_};
+}
+
+# Set some defaults
+$preferences{'background'} = $preferences{'background'} || 'silver';
+$preferences{'text'} = $preferences{'text'} || 'black';
+
+# Refresh the cookie so that it doesn't expire. This also
+# makes any changes the user made permanent.
+$the_cookie = cookie(-name=>'preferences',
+ -value=>\%preferences,
+ -expires=>'+30d');
+print header(-cookie=>$the_cookie);
+
+# Adjust the title to incorporate the user's name, if provided.
+$title = $preferences{'name'} ?
+ "Welcome back, $preferences{name}!" : "Customizable Page";
+
+# Create the HTML page. We use several of Netscape's
+# extended tags to control the background color and the
+# font size. It's safe to use Netscape features here because
+# cookies don't work anywhere else anyway.
+print start_html(-title=>$title,
+ -bgcolor=>$preferences{'background'},
+ -text=>$preferences{'text'}
+ );
+
+print basefont({SIZE=>$preferences{size}}) if $preferences{'size'} > 0;
+
+print h1($title),<<END;
+You can change the appearance of this page by submitting
+the fill-out form below. If you return to this page any time
+within 30 days, your preferences will be restored.
+END
+ ;
+
+# Create the form
+print hr(),
+ start_form,
+
+ "Your first name: ",
+ textfield(-name=>'name',
+ -default=>$preferences{'name'},
+ -size=>30),br,
+
+ table(
+ TR(
+ td("Preferred"),
+ td("Page color:"),
+ td(popup_menu(-name=>'background',
+ -values=>\@colors,
+ -default=>$preferences{'background'})
+ ),
+ ),
+ TR(
+ td(''),
+ td("Text color:"),
+ td(popup_menu(-name=>'text',
+ -values=>\@colors,
+ -default=>$preferences{'text'})
+ )
+ ),
+ TR(
+ td(''),
+ td("Font size:"),
+ td(popup_menu(-name=>'size',
+ -values=>\@sizes,
+ -default=>$preferences{'size'})
+ )
+ )
+ ),
+
+ submit(-label=>'Set preferences'),
+ hr;
+
+print a({HREF=>"/"},'Go to the home page');
+print end_html;
diff --git a/gnu/usr.bin/perl/eg/cgi/diff_upload.cgi b/gnu/usr.bin/perl/eg/cgi/diff_upload.cgi
new file mode 100644
index 00000000000..913f9ca1791
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/diff_upload.cgi
@@ -0,0 +1,68 @@
+#!/usr/local/bin/perl
+
+$DIFF = "/usr/bin/diff";
+$PERL = "/usr/bin/perl";
+
+use CGI qw(:standard);
+use CGI::Carp;
+
+print header;
+print start_html("File Diff Example");
+print "<strong>Version </strong>$CGI::VERSION<p>";
+
+print <<EOF;
+<H1>File Diff Example</H1>
+Enter two files. When you press "submit" their diff will be
+produced.
+EOF
+ ;
+
+# Start a multipart form.
+print start_multipart_form;
+print "File #1:",filefield(-name=>'file1',-size=>45),"<BR>\n";
+print "File #2:",filefield(-name=>'file2',-size=>45),"<BR>\n";
+print "Diff type: ",radio_group(-name=>'type',
+ -value=>['context','normal']),"<br>\n";
+print reset,submit(-name=>'submit',-value=>'Do Diff');
+print endform;
+
+# Process the form if there is a file name entered
+$file1 = param('file1');
+$file2 = param('file2');
+
+$|=1; # for buffering
+if ($file1 && $file2) {
+ $realfile1 = tmpFileName($file1);
+ $realfile2 = tmpFileName($file2);
+ print "<HR>\n";
+ print "<H2>$file1 vs $file2</H2>\n";
+
+ print "<PRE>\n";
+ $options = "-c" if param('type') eq 'context';
+ system "$DIFF $options $realfile1 $realfile2 | $PERL -pe 's/>/&gt;/g; s/</&lt;/g;'";
+ close $file1;
+ close $file2;
+ print "</PRE>\n";
+}
+
+print <<EOF;
+<HR>
+<A HREF="../cgi_docs.html">CGI documentation</A>
+<HR>
+<ADDRESS>
+<A HREF="/~lstein">Lincoln D. Stein</A>
+</ADDRESS><BR>
+Last modified 17 July 1996
+EOF
+ ;
+print end_html;
+
+sub sanitize {
+ my $name = shift;
+ my($safe) = $name=~/([a-zA-Z0-9._~#,]+)/;
+ unless ($safe) {
+ print "<strong>$name is not a valid Unix filename -- sorry</strong>";
+ exit 0;
+ }
+ return $safe;
+}
diff --git a/gnu/usr.bin/perl/eg/cgi/file_upload.cgi b/gnu/usr.bin/perl/eg/cgi/file_upload.cgi
new file mode 100644
index 00000000000..1f9eaec3321
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/file_upload.cgi
@@ -0,0 +1,63 @@
+#!/usr/local/bin/perl
+
+use CGI qw(:standard);
+use CGI::Carp;
+
+print header();
+print start_html("File Upload Example");
+print strong("Version "),$CGI::VERSION,p;
+
+print h1("File Upload Example"),
+ 'This example demonstrates how to prompt the remote user to
+ select a remote file for uploading. ',
+ strong("This feature only works with Netscape 2.0 browsers."),
+ p,
+ 'Select the ',cite('browser'),' button to choose a text file
+ to upload. When you press the submit button, this script
+ will count the number of lines, words, and characters in
+ the file.';
+
+@types = ('count lines','count words','count characters');
+
+# Start a multipart form.
+print start_multipart_form(),
+ "Enter the file to process:",
+ filefield('filename','',45),
+ br,
+ checkbox_group('count',\@types,\@types),
+ p,
+ reset,submit('submit','Process File'),
+ endform;
+
+# Process the form if there is a file name entered
+if ($file = param('filename')) {
+ $tmpfile=tmpFileName($file);
+ print hr(),
+ h2($file),
+ h3($tmpfile);
+ my($lines,$words,$characters,@words) = (0,0,0,0);
+ while (<$file>) {
+ $lines++;
+ $words += @words=split(/\s+/);
+ $characters += length($_);
+ }
+ close $file;
+ grep($stats{$_}++,param('count'));
+ if (%stats) {
+ print strong("Lines: "),$lines,br if $stats{'count lines'};
+ print strong("Words: "),$words,br if $stats{'count words'};
+ print strong("Characters: "),$characters,br if $stats{'count characters'};
+ } else {
+ print strong("No statistics selected.");
+ }
+}
+
+print hr(),
+ a({href=>"../cgi_docs.html"},"CGI documentation"),
+ hr,
+ address(
+ a({href=>'/~lstein'},"Lincoln D. Stein")),
+ br,
+ 'Last modified July 17, 1996',
+ end_html;
+
diff --git a/gnu/usr.bin/perl/eg/cgi/frameset.cgi b/gnu/usr.bin/perl/eg/cgi/frameset.cgi
new file mode 100644
index 00000000000..fc86e92e9ac
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/frameset.cgi
@@ -0,0 +1,81 @@
+#!/usr/local/bin/perl
+
+use CGI;
+$query = new CGI;
+print $query->header;
+$TITLE="Frameset Example";
+
+# We use the path information to distinguish between calls
+# to the script to:
+# (1) create the frameset
+# (2) create the query form
+# (3) create the query response
+
+$path_info = $query->path_info;
+
+# If no path information is provided, then we create
+# a side-by-side frame set
+if (!$path_info) {
+ &print_frameset;
+ exit 0;
+}
+
+# If we get here, then we either create the query form
+# or we create the response.
+&print_html_header;
+&print_query if $path_info=~/query/;
+&print_response if $path_info=~/response/;
+&print_end;
+
+
+# Create the frameset
+sub print_frameset {
+ $script_name = $query->script_name;
+ print <<EOF;
+<html><head><title>$TITLE</title></head>
+<frameset cols="50,50">
+<frame src="$script_name/query" name="query">
+<frame src="$script_name/response" name="response">
+</frameset>
+EOF
+ ;
+ exit 0;
+}
+
+sub print_html_header {
+ print $query->start_html($TITLE);
+}
+
+sub print_end {
+ print qq{<P><hr><A HREF="../index.html" TARGET="_top">More Examples</A>};
+ print $query->end_html;
+}
+
+sub print_query {
+ $script_name = $query->script_name;
+ print "<H1>Frameset Query</H1>\n";
+ print $query->startform(-action=>"$script_name/response",-TARGET=>"response");
+ print "What's your name? ",$query->textfield('name');
+ print "<P>What's the combination?<P>",
+ $query->checkbox_group(-name=>'words',
+ -values=>['eenie','meenie','minie','moe']);
+
+ print "<P>What's your favorite color? ",
+ $query->popup_menu(-name=>'color',
+ -values=>['red','green','blue','chartreuse']),
+ "<P>";
+ print $query->submit;
+ print $query->endform;
+}
+
+sub print_response {
+ print "<H1>Frameset Result</H1>\n";
+ unless ($query->param) {
+ print "<b>No query submitted yet.</b>";
+ return;
+ }
+ print "Your name is <EM>",$query->param(name),"</EM>\n";
+ print "<P>The keywords are: <EM>",join(", ",$query->param(words)),"</EM>\n";
+ print "<P>Your favorite color is <EM>",$query->param(color),"</EM>\n";
+}
+
diff --git a/gnu/usr.bin/perl/eg/cgi/index.html b/gnu/usr.bin/perl/eg/cgi/index.html
new file mode 100644
index 00000000000..9eafd5f1086
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/index.html
@@ -0,0 +1,111 @@
+<HTML> <HEAD>
+<TITLE>More Examples of Scripts Created with CGI.pm</TITLE>
+</HEAD>
+
+<BODY>
+<H1>More Examples of Scripts Created with CGI.pm</H1>
+
+<H2> Basic Non Sequitur Questionnaire</H2>
+<UL>
+ <LI> <A HREF="tryit.cgi">Try the script</A>
+ <LI> <A HREF="tryit.txt">Look at its source code</A>
+</UL>
+
+<H2> Advanced Non Sequitur Questionnaire</H2>
+<UL>
+ <LI> <A HREF="monty.cgi">Try the script</A>
+ <LI> <A HREF="monty.txt">Look at its source code</A>
+</UL>
+
+<H2> Save and restore the state of a form to a file</H2>
+<UL>
+ <LI> <A HREF="save_state.cgi">Try the script</A>
+ <LI> <A HREF="save_state.txt">Look at its source code</A>
+</UL>
+
+<H2> Read the coordinates from a clickable image map</H2>
+<UL>
+ <LI> <A HREF="clickable_image.cgi">Try the script</A>
+ <LI> <A HREF="clickable_image.txt">Look at its source code</A>
+</UL>
+
+<H2> Multiple independent forms on the same page</H2>
+<UL>
+ <LI> <A HREF="multiple_forms.cgi">Try the script</A>
+ <LI> <A HREF="multiple_forms.txt">Look at its source code</A>
+</UL>
+
+<H2> How to maintain state on a page with internal links</H2>
+<UL>
+ <LI> <A HREF="internal_links.cgi">Try the script</A>
+ <LI> <A HREF="internal_links.txt">Look at its source code</A>
+</UL>
+
+<h2>Echo fatal script errors to the browser</h2>
+<ul>
+ <li><a href="crash.cgi">Try the script</a>
+ <li><a href="crash.txt">Look at its source code</a>
+</ul>
+
+<EM>The Following Scripts only Work with Netscape 2.0 & Internet Explorer only!</EM>
+
+<H2> Prompt for a file to upload and process it</H2>
+<UL>
+ <LI> <A HREF="file_upload.cgi">Try the script</A>
+ <LI> <A HREF="file_upload.txt">Look at its source code</A>
+</UL>
+
+<h2> A Continuously-Updated Page using Server Push</h2>
+<ul>
+ <li><a href="nph-clock.cgi">Try the script</a>
+ <li><a href="nph-clock.txt">Look at its source code</a>
+</ul>
+
+<h2>Compute the "diff" between two uploaded files</h2>
+<ul>
+ <li><a href="diff_upload.cgi">Try the script</a>
+ <li><a href="diff_upload.txt">Look at its source code</a>
+</ul>
+
+<h2>Maintain state over a long period with a cookie</h2>
+<ul>
+ <li><a href="cookie.cgi">Try the script</a>
+ <li><a href="cookie.txt">Look at its source code</a>
+</ul>
+
+<h2>Permanently customize the appearance of a page</h2>
+<ul>
+ <li><a href="customize.cgi">Try the script</a>
+ <li><a href="customize.txt">Look at its source code</a>
+</ul>
+
+<h2> Popup the response in a new window</h2>
+<ul>
+ <li><a href="popup.cgi">Try the script</a>
+ <li><a href="popup.txt">Look at its source code</a>
+</ul>
+
+<h2> Side-by-side form and response using frames</h2>
+<ul>
+ <li><a href="frameset.cgi">Try the script</a>
+ <li><a href="frameset.txt">Look at its source code</a>
+</ul>
+
+<h2>Verify the Contents of a fill-out form with JavaScript</h2>
+<ul>
+ <li><a href="javascript.cgi">Try the script</a>
+ <li><a href="javascript.txt">Look at its source code</a>
+</ul>
+
+<HR>
+<MENU>
+ <LI> <A HREF="../cgi_docs.html">CGI.pm documentation</A>
+ <LI> <A HREF="../CGI.pm.tar.gz">Download the CGI.pm distribution</A>
+</MENU>
+<HR>
+<ADDRESS>Lincoln D. Stein, lstein@genome.wi.mit.edu<br>
+<a href="/">Whitehead Institute/MIT Center for Genome Research</a></ADDRESS>
+<!-- hhmts start -->
+Last modified: Mon Dec 2 06:23:25 EST 1996
+<!-- hhmts end -->
+</BODY> </HTML>
diff --git a/gnu/usr.bin/perl/eg/cgi/internal_links.cgi b/gnu/usr.bin/perl/eg/cgi/internal_links.cgi
new file mode 100644
index 00000000000..4806966842d
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/internal_links.cgi
@@ -0,0 +1,33 @@
+#!/usr/local/bin/perl
+
+use CGI;
+$query = new CGI;
+
+# We generate a regular HTML file containing a very long list
+# and a popup menu that does nothing except to show that we
+# don't lose the state information.
+print $query->header;
+print $query->start_html("Internal Links Example");
+print "<H1>Internal Links Example</H1>\n";
+print "Click <cite>Submit Query</cite> to create a state. Then scroll down and",
+ " click on any of the <cite>Jump to top</cite> links. This is not very exciting.";
+
+print "<A NAME=\"start\"></A>\n"; # an anchor point at the top
+
+# pick a default starting value;
+$query->param('amenu','FOO1') unless $query->param('amenu');
+
+print $query->startform;
+print $query->popup_menu('amenu',[('FOO1'..'FOO9')]);
+print $query->submit,$query->endform;
+
+# We create a long boring list for the purposes of illustration.
+$myself = $query->self_url;
+print "<OL>\n";
+for (1..100) {
+ print qq{<LI>List item #$_ <A HREF="$myself#start">Jump to top</A>\n};
+}
+print "</OL>\n";
+
+print $query->end_html;
+
diff --git a/gnu/usr.bin/perl/eg/cgi/javascript.cgi b/gnu/usr.bin/perl/eg/cgi/javascript.cgi
new file mode 100644
index 00000000000..91c2b9e6482
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/javascript.cgi
@@ -0,0 +1,105 @@
+#!/usr/local/bin/perl
+
+# This script illustrates how to use JavaScript to validate fill-out
+# forms.
+use CGI qw(:standard);
+
+# Here's the javascript code that we include in the document.
+$JSCRIPT=<<EOF;
+ // validate that the user is the right age. Return
+ // false to prevent the form from being submitted.
+ function validateForm() {
+ var today = new Date();
+ var birthday = validateDate(document.form1.birthdate);
+ if (birthday == 0) {
+ document.form1.birthdate.focus()
+ document.form1.birthdate.select();
+ return false;
+ }
+ var milliseconds = today.getTime()-birthday;
+ var years = milliseconds/(1000 * 60 * 60 * 24 * 365.25);
+ if ((years > 20) || (years < 5)) {
+ alert("You must be between the ages of 5 and 20 to submit this form");
+ document.form1.birthdate.focus();
+ document.form1.birthdate.select();
+ return false;
+ }
+ // Since we've calculated the age in years already,
+ // we might as well send it up to our CGI script.
+ document.form1.age.value=Math.floor(years);
+ return true;
+ }
+
+ // make sure that the contents of the supplied
+ // field contain a valid date.
+ function validateDate(element) {
+ var date = Date.parse(element.value);
+ if (0 == date) {
+ alert("Please enter date in format MMM DD, YY");
+ element.focus();
+ element.select();
+ }
+ return date;
+ }
+
+ // Compliments, compliments
+ function doPraise(element) {
+ if (element.checked) {
+ self.status=element.value + " is an excellent choice!";
+ return true;
+ } else {
+ return false;
+ }
+ }
+
+ function checkColor(element) {
+ var color = element.options[element.selectedIndex].text;
+ if (color == "blonde") {
+ if (confirm("Is it true that blondes have more fun?"))
+ alert("Darn. That leaves me out.");
+ } else
+ alert(color + " is a fine choice!");
+ }
+EOF
+ ;
+
+# here's where the execution begins
+print header;
+print start_html(-title=>'Personal Profile',-script=>$JSCRIPT);
+
+print h1("Big Brother Wants to Know All About You"),
+ strong("Note: "),"This page uses JavaScript and requires ",
+ "Netscape 2.0 or higher to do anything special.";
+
+&print_prompt();
+print hr;
+&print_response() if param;
+print end_html;
+
+sub print_prompt {
+ print start_form(-name=>'form1',
+ -onSubmit=>"return validateForm()"),"\n";
+ print "Birthdate (e.g. Jan 3, 1972): ",
+ textfield(-name=>'birthdate',
+ -onBlur=>"validateDate(this)"),"<p>\n";
+ print "Sex: ",radio_group(-name=>'gender',
+ -value=>[qw/male female/],
+ -onClick=>"doPraise(this)"),"<p>\n";
+ print "Hair color: ",popup_menu(-name=>'color',
+ -value=>[qw/brunette blonde red gray/],
+ -default=>'red',
+ -onChange=>"checkColor(this)"),"<p>\n";
+ print hidden(-name=>'age',-value=>0);
+ print submit();
+ print end_form;
+}
+
+sub print_response {
+ import_names('Q');
+ print h2("Your profile"),
+ "You claim to be a ",b($Q::age)," year old ",b($Q::color,$Q::gender),".",
+ "You should be ashamed of yourself for lying so ",
+ "blatantly to big brother!",
+ hr;
+}
+
diff --git a/gnu/usr.bin/perl/eg/cgi/monty.cgi b/gnu/usr.bin/perl/eg/cgi/monty.cgi
new file mode 100644
index 00000000000..b7c0f6a8f60
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/monty.cgi
@@ -0,0 +1,83 @@
+#!/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->start_multipart_form;
+ 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
+ ;
+}
diff --git a/gnu/usr.bin/perl/eg/cgi/multiple_forms.cgi b/gnu/usr.bin/perl/eg/cgi/multiple_forms.cgi
new file mode 100644
index 00000000000..b38bf93e96c
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/multiple_forms.cgi
@@ -0,0 +1,54 @@
+#!/usr/local/bin/perl
+
+use CGI;
+
+$query = new CGI;
+print $query->header;
+print $query->start_html('Multiple Forms');
+print "<H1>Multiple Forms</H1>\n";
+
+# Print the first form
+print $query->startform;
+$name = $query->remote_user || 'anonymous@' . $query->remote_host;
+
+print "What's your name? ",$query->textfield('name',$name,50);
+print "<P>What's the combination?<P>",
+ $query->checkbox_group('words',['eenie','meenie','minie','moe']);
+print "<P>What's your favorite color? ",
+ $query->popup_menu('color',['red','green','blue','chartreuse']),
+ "<P>";
+print $query->submit('form_1','Send Form 1');
+print $query->endform;
+
+# Print the second form
+print "<HR>\n";
+print $query->startform;
+print "Some radio buttons: ",$query->radio_group('radio buttons',
+ [qw{one two three four five}],'three'),"\n";
+print "<P>What's the password? ",$query->password_field('pass','secret');
+print $query->defaults,$query->submit('form_2','Send Form 2'),"\n";
+print $query->endform;
+
+print "<HR>\n";
+
+$query->import_names('Q');
+if ($Q::form_1) {
+ print "<H2>Form 1 Submitted</H2>\n";
+ print "Your name is <EM>$Q::name</EM>\n";
+ print "<P>The combination is: <EM>{",join(",",@Q::words),"}</EM>\n";
+ print "<P>Your favorite color is <EM>$Q::color</EM>\n";
+} elsif ($Q::form_2) {
+ print <<EOF;
+<H2>Form 2 Submitted</H2>
+<P>The value of the radio buttons is <EM>$Q::radio_buttons</EM>
+<P>The secret password is <EM>$Q::pass</EM>
+EOF
+ ;
+}
+print qq{<P><A HREF="./">Other examples</A>};
+print qq{<P><A HREF="../cgi_docs.html">Go to the documentation</A>};
+
+print $query->end_html;
+
+
+
diff --git a/gnu/usr.bin/perl/eg/cgi/nph-clock.cgi b/gnu/usr.bin/perl/eg/cgi/nph-clock.cgi
new file mode 100644
index 00000000000..55a2fbe545c
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/nph-clock.cgi
@@ -0,0 +1,18 @@
+#!/usr/local/bin/perl -w
+
+use CGI::Push qw(:standard :html3);
+
+do_push(-next_page=>\&draw_time,-delay=>1);
+
+sub draw_time {
+ my $time = `/bin/date`;
+ return start_html('Tick Tock'),
+ div({-align=>CENTER},
+ h1('Virtual Clock'),
+ h2($time)
+ ),
+ hr,
+ a({-href=>'index.html'},'More examples'),
+ end_html();
+}
+
diff --git a/gnu/usr.bin/perl/eg/cgi/popup.cgi b/gnu/usr.bin/perl/eg/cgi/popup.cgi
new file mode 100644
index 00000000000..88cea1da9c4
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/popup.cgi
@@ -0,0 +1,32 @@
+#!/usr/local/bin/perl
+
+use CGI;
+$query = new CGI;
+print $query->header;
+print $query->start_html('Popup Window');
+
+
+if (!$query->param) {
+ print "<H1>Ask your Question</H1>\n";
+ print $query->startform(-target=>'_new');
+ print "What's your name? ",$query->textfield('name');
+ print "<P>What's the combination?<P>",
+ $query->checkbox_group(-name=>'words',
+ -values=>['eenie','meenie','minie','moe'],
+ -defaults=>['eenie','moe']);
+
+ print "<P>What's your favorite color? ",
+ $query->popup_menu(-name=>'color',
+ -values=>['red','green','blue','chartreuse']),
+ "<P>";
+ print $query->submit;
+ print $query->endform;
+
+} else {
+ print "<H1>And the Answer is...</H1>\n";
+ print "Your name is <EM>",$query->param(name),"</EM>\n";
+ print "<P>The keywords are: <EM>",join(", ",$query->param(words)),"</EM>\n";
+ print "<P>Your favorite color is <EM>",$query->param(color),"</EM>\n";
+}
+print qq{<P><A HREF="cgi_docs.html">Go to the documentation</A>};
+print $query->end_html;
diff --git a/gnu/usr.bin/perl/eg/cgi/save_state.cgi b/gnu/usr.bin/perl/eg/cgi/save_state.cgi
new file mode 100644
index 00000000000..be79051bd64
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/save_state.cgi
@@ -0,0 +1,67 @@
+#!/usr/local/bin/perl
+
+use CGI;
+$query = new CGI;
+
+print $query->header;
+print $query->start_html("Save and Restore Example");
+print "<H1>Save and Restore Example</H1>\n";
+
+# Here's where we take action on the previous request
+&save_parameters($query) if $query->param('action') eq 'SAVE';
+$query = &restore_parameters($query) if $query->param('action') eq 'RESTORE';
+
+# Here's where we create the form
+print $query->startform;
+print "Popup 1: ",$query->popup_menu('popup1',[qw{red green purple magenta orange chartreuse brown}]),"\n";
+print "Popup 2: ",$query->popup_menu('popup2',[qw{lion tiger bear zebra potto wildebeest frog emu gazelle}]),"\n";
+print "<P>";
+$default_name = $query->remote_addr . '.sav';
+print "Save/restore state from file: ",$query->textfield('savefile',$default_name),"\n";
+print "<P>";
+print $query->submit('action','SAVE'),$query->submit('action','RESTORE');
+print "<P>",$query->defaults;
+print $query->endform;
+
+# Here we print out a bit at the end
+print $query->end_html;
+
+sub save_parameters {
+ local($query) = @_;
+ local($filename) = &clean_name($query->param('savefile'));
+ if (open(FILE,">$filename")) {
+ $query->save(FILE);
+ close FILE;
+ print "<STRONG>State has been saved to file $filename</STRONG>\n";
+ print "<P>If you remember this name you can restore the state later.\n";
+ } else {
+ print "<STRONG>Error:</STRONG> couldn't write to file $filename: $!\n";
+ }
+}
+
+sub restore_parameters {
+ local($query) = @_;
+ local($filename) = &clean_name($query->param('savefile'));
+ if (open(FILE,$filename)) {
+ $query = new CGI(FILE); # Throw out the old query, replace it with a new one
+ close FILE;
+ print "<STRONG>State has been restored from file $filename</STRONG>\n";
+ } else {
+ print "<STRONG>Error:</STRONG> couldn't restore file $filename: $!\n";
+ }
+ return $query;
+}
+
+
+# Very important subroutine -- get rid of all the naughty
+# metacharacters from the file name. If there are, we
+# complain bitterly and die.
+sub clean_name {
+ local($name) = @_;
+ unless ($name=~/^[\w\._\-]+$/) {
+ print "<STRONG>$name has naughty characters. Only ";
+ print "alphanumerics are allowed. You can't use absolute names.</STRONG>";
+ die "Attempt to use naughty characters";
+ }
+ return "WORLD_WRITABLE/$name";
+}
diff --git a/gnu/usr.bin/perl/eg/cgi/tryit.cgi b/gnu/usr.bin/perl/eg/cgi/tryit.cgi
new file mode 100644
index 00000000000..83c620c3e43
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/tryit.cgi
@@ -0,0 +1,37 @@
+#!/usr/local/bin/perl
+
+use CGI ':standard';
+
+print header;
+print 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;
+}
+print a({href=>'../cgi_docs.html'},'Go to the documentation');
+print end_html;
+
+
diff --git a/gnu/usr.bin/perl/eg/cgi/wilogo.gif.uu b/gnu/usr.bin/perl/eg/cgi/wilogo.gif.uu
new file mode 100644
index 00000000000..a183bc02d5b
--- /dev/null
+++ b/gnu/usr.bin/perl/eg/cgi/wilogo.gif.uu
@@ -0,0 +1,14 @@
+begin 644 wilogo.gif
+M1TE&.#=A7@!$`(```'X2F?___RP`````7@!$```"_D2.J<#MKF)ZU,A3,[OO
+M(IUY']A%9"6AW$F)+#2]Y:BNLF6_\;WMH<?#I72^VP+D"@*)F&"O25KRDM&B
+M[%C-7;4_J)*6'4ZE&O`W8"1OQ5UGPWRBIKDPM!MW9J]-[;LUKL;$5W.'YQ3(
+M(O<&-^>F*(A55\BX%UEI^;<VB0BH1RFX2=<IELE4^*0'N?-I>OJ8N%(*Z^4G
+M.OJJ>8HZ.(>;JRMD><E[!KQHB^3;:APL6Z8\RKPK/)O:*-WLW&7]*\UYR]J)
+M?<P=1MR-_6VN76,WGAV^32W^3CZ_SCY3;W__C-R^CU^\%M#T!9PVL(ZZ&>X"
+M%A1XSM]!A?T8/C0T$1XMJG\B&G+,"-&C/(VS0(842;`)M'S>_OE8F#"=2S#*
+M8LHLAS'D1Y,42UGY9O,F-T:X@@JEE@D1RW>/D@8R.DZ-+*E0CQ:9JJ5JU!SQ
+MR&BU2D.;E*4'ER0TNY%G2A/Y.G[=VG%81+5K_UG$21<A6;=YP9'5B++O7:@7
+M\]J5]]?DX7:)%<]5%=B/55>-GQW55;$8L\RW6J8-9>QM7<^A/SMZK!ESY$,+
+(KPA.EJ```#L`
+`
+end
diff --git a/gnu/usr.bin/perl/eg/changes b/gnu/usr.bin/perl/eg/changes
index 6a8868fbe4d..6396e2c3932 100644
--- a/gnu/usr.bin/perl/eg/changes
+++ b/gnu/usr.bin/perl/eg/changes
@@ -1,6 +1,6 @@
#!/usr/bin/perl -P
-# $RCSfile: changes,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:52 $
+# $RCSfile: changes,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:37 $
($dir, $days) = @ARGV;
$dir = '/' if $dir eq '';
diff --git a/gnu/usr.bin/perl/eg/dus b/gnu/usr.bin/perl/eg/dus
index 5f18a2fb990..463290fe569 100644
--- a/gnu/usr.bin/perl/eg/dus
+++ b/gnu/usr.bin/perl/eg/dus
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: dus,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:53 $
+# $RCSfile: dus,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:37 $
# This script does a du -s on any directories in the current directory that
# are not mount points for another filesystem.
diff --git a/gnu/usr.bin/perl/eg/findcp b/gnu/usr.bin/perl/eg/findcp
index 345a0064456..b7831c5cee5 100644
--- a/gnu/usr.bin/perl/eg/findcp
+++ b/gnu/usr.bin/perl/eg/findcp
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: findcp,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:53 $
+# $RCSfile: findcp,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:38 $
# This is a wrapper around the find command that pretends find has a switch
# of the form -cp host:destination. It presumes your find implements -ls.
diff --git a/gnu/usr.bin/perl/eg/findtar b/gnu/usr.bin/perl/eg/findtar
index 9a5185a8e25..48e3b22aece 100644
--- a/gnu/usr.bin/perl/eg/findtar
+++ b/gnu/usr.bin/perl/eg/findtar
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: findtar,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:53 $
+# $RCSfile: findtar,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:39 $
# findtar takes find-style arguments and spits out a tarfile on stdout.
# It won't work unless your find supports -ls and your tar the I flag.
diff --git a/gnu/usr.bin/perl/eg/g/gcp b/gnu/usr.bin/perl/eg/g/gcp
index 9c4c72ed7d3..32dfe8eeccb 100644
--- a/gnu/usr.bin/perl/eg/g/gcp
+++ b/gnu/usr.bin/perl/eg/g/gcp
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: gcp,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:55 $
+# $RCSfile: gcp,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:45 $
# Here is a script to do global rcps. See man page.
diff --git a/gnu/usr.bin/perl/eg/g/gcp.man b/gnu/usr.bin/perl/eg/g/gcp.man
index 28b6de80ac7..391141f78b1 100644
--- a/gnu/usr.bin/perl/eg/g/gcp.man
+++ b/gnu/usr.bin/perl/eg/g/gcp.man
@@ -1,4 +1,4 @@
-.\" $RCSfile: gcp.man,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:55 $
+.\" $RCSfile: gcp.man,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:47 $
.TH GCP 1C "13 May 1988"
.SH NAME
gcp \- global file copy
diff --git a/gnu/usr.bin/perl/eg/g/ged b/gnu/usr.bin/perl/eg/g/ged
index e85ae1c0007..103790ea2e5 100644
--- a/gnu/usr.bin/perl/eg/g/ged
+++ b/gnu/usr.bin/perl/eg/g/ged
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: ged,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:55 $
+# $RCSfile: ged,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:47 $
# Does inplace edits on a set of files on a set of machines.
#
diff --git a/gnu/usr.bin/perl/eg/g/gsh b/gnu/usr.bin/perl/eg/g/gsh
index e07a4ce6169..251568a028d 100644
--- a/gnu/usr.bin/perl/eg/g/gsh
+++ b/gnu/usr.bin/perl/eg/g/gsh
@@ -1,6 +1,6 @@
#! /usr/bin/perl
-# $RCSfile: gsh,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:55 $
+# $RCSfile: gsh,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:48 $
# Do rsh globally--see man page
diff --git a/gnu/usr.bin/perl/eg/g/gsh.man b/gnu/usr.bin/perl/eg/g/gsh.man
index f80c17f2510..abcdbc67b20 100644
--- a/gnu/usr.bin/perl/eg/g/gsh.man
+++ b/gnu/usr.bin/perl/eg/g/gsh.man
@@ -1,4 +1,4 @@
-.\" $RCSfile: gsh.man,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:55 $
+.\" $RCSfile: gsh.man,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:49 $
.TH GSH 8 "13 May 1988"
.SH NAME
gsh \- global shell
diff --git a/gnu/usr.bin/perl/eg/muck.man b/gnu/usr.bin/perl/eg/muck.man
index 38f2b9388c2..05c52853e53 100644
--- a/gnu/usr.bin/perl/eg/muck.man
+++ b/gnu/usr.bin/perl/eg/muck.man
@@ -1,4 +1,4 @@
-.\" $RCSfile: muck.man,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:53 $
+.\" $RCSfile: muck.man,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:39 $
.TH MUCK 1 "10 Jan 1989"
.SH NAME
muck \- make usage checker
diff --git a/gnu/usr.bin/perl/eg/myrup b/gnu/usr.bin/perl/eg/myrup
index 3aa24901b72..61ca8b072ce 100644
--- a/gnu/usr.bin/perl/eg/myrup
+++ b/gnu/usr.bin/perl/eg/myrup
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: myrup,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:53 $
+# $RCSfile: myrup,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:40 $
# This was a customization of ruptime requested by someone here who wanted
# to be able to find the least loaded machine easily. It uses the
diff --git a/gnu/usr.bin/perl/eg/nih b/gnu/usr.bin/perl/eg/nih
index e145c05906c..50bf016954d 100644
--- a/gnu/usr.bin/perl/eg/nih
+++ b/gnu/usr.bin/perl/eg/nih
@@ -1,10 +1,11 @@
-eval "exec /usr/bin/perl -Spi.bak $0 $*"
+eval 'exec /usr/bin/perl -Spi.bak $0 ${1+"$@"}'
if $running_under_some_shell;
-# $RCSfile: nih,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:53 $
+# $RCSfile: nih,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:41 $
# This script makes #! scripts directly executable on machines that don't
# support #!. It edits in place any scripts mentioned on the command line.
-s|^#!(.*)|#!$1\neval "exec $1 -S \$0 \$*"\n\tif \$running_under_some_shell;|
+s[^#!(.*)]
+ [#!$1\neval 'exec $1 -S \$0 \${1+"\$@"}'\n\tif \$running_under_some_shell;]
if $. == 1;
diff --git a/gnu/usr.bin/perl/eg/relink b/gnu/usr.bin/perl/eg/relink
index cb48fb886fd..c0d6de3afdd 100644
--- a/gnu/usr.bin/perl/eg/relink
+++ b/gnu/usr.bin/perl/eg/relink
@@ -2,12 +2,11 @@
'di';
'ig00';
#
-# $RCSfile: relink,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:53 $
+# $RCSfile: relink,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:41 $
#
# $Log: relink,v $
-# Revision 1.1.1.1 1996/08/19 10:11:53 downsj
-# Import of Perl 5.003 into the tree. Makefile.bsd-wrapper and
-# config.sh.OpenBSD are the only local changes.
+# Revision 1.2 1997/11/30 07:49:41 millert
+# perl 5.004_04
#
($op = shift) || die "Usage: relink perlexpr [filenames]\n";
diff --git a/gnu/usr.bin/perl/eg/rename b/gnu/usr.bin/perl/eg/rename
index aa1a65bf960..f041b08d870 100644
--- a/gnu/usr.bin/perl/eg/rename
+++ b/gnu/usr.bin/perl/eg/rename
@@ -2,12 +2,11 @@
'di';
'ig00';
#
-# $RCSfile: rename,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:54 $
+# $RCSfile: rename,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:42 $
#
# $Log: rename,v $
-# Revision 1.1.1.1 1996/08/19 10:11:54 downsj
-# Import of Perl 5.003 into the tree. Makefile.bsd-wrapper and
-# config.sh.OpenBSD are the only local changes.
+# Revision 1.2 1997/11/30 07:49:42 millert
+# perl 5.004_04
#
($op = shift) || die "Usage: rename perlexpr [filenames]\n";
diff --git a/gnu/usr.bin/perl/eg/rmfrom b/gnu/usr.bin/perl/eg/rmfrom
index 502e96251b1..bfd5b835f0f 100644
--- a/gnu/usr.bin/perl/eg/rmfrom
+++ b/gnu/usr.bin/perl/eg/rmfrom
@@ -1,6 +1,6 @@
#!/usr/bin/perl -n
-# $RCSfile: rmfrom,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:54 $
+# $RCSfile: rmfrom,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:42 $
# A handy (but dangerous) script to put after a find ... -print.
diff --git a/gnu/usr.bin/perl/eg/scan/scan_df b/gnu/usr.bin/perl/eg/scan/scan_df
index 0e77db85936..906277d6eac 100644
--- a/gnu/usr.bin/perl/eg/scan/scan_df
+++ b/gnu/usr.bin/perl/eg/scan/scan_df
@@ -1,6 +1,6 @@
#!/usr/bin/perl -P
-# $RCSfile: scan_df,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:56 $
+# $RCSfile: scan_df,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:50 $
# This report points out filesystems that are in danger of overflowing.
diff --git a/gnu/usr.bin/perl/eg/scan/scan_last b/gnu/usr.bin/perl/eg/scan/scan_last
index 43c319ae042..77d40da71d7 100644
--- a/gnu/usr.bin/perl/eg/scan/scan_last
+++ b/gnu/usr.bin/perl/eg/scan/scan_last
@@ -1,6 +1,6 @@
#!/usr/bin/perl -P
-# $RCSfile: scan_last,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:56 $
+# $RCSfile: scan_last,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:51 $
# This reports who was logged on at weird hours
diff --git a/gnu/usr.bin/perl/eg/scan/scan_messages b/gnu/usr.bin/perl/eg/scan/scan_messages
index 14147e83b07..12f75adc8d5 100644
--- a/gnu/usr.bin/perl/eg/scan/scan_messages
+++ b/gnu/usr.bin/perl/eg/scan/scan_messages
@@ -1,6 +1,6 @@
#!/usr/bin/perl -P
-# $RCSfile: scan_messages,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:56 $
+# $RCSfile: scan_messages,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:51 $
# This prints out extraordinary console messages. You'll need to customize.
diff --git a/gnu/usr.bin/perl/eg/scan/scan_passwd b/gnu/usr.bin/perl/eg/scan/scan_passwd
index d4a90445eb5..545d0cb6d89 100644
--- a/gnu/usr.bin/perl/eg/scan/scan_passwd
+++ b/gnu/usr.bin/perl/eg/scan/scan_passwd
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: scan_passwd,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:56 $
+# $RCSfile: scan_passwd,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:52 $
# This scans passwd file for security holes.
diff --git a/gnu/usr.bin/perl/eg/scan/scan_ps b/gnu/usr.bin/perl/eg/scan/scan_ps
index 6d2fa2e4d0e..0c1f6f1ef63 100644
--- a/gnu/usr.bin/perl/eg/scan/scan_ps
+++ b/gnu/usr.bin/perl/eg/scan/scan_ps
@@ -1,6 +1,6 @@
#!/usr/bin/perl -P
-# $RCSfile: scan_ps,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:56 $
+# $RCSfile: scan_ps,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:52 $
# This looks for looping processes.
diff --git a/gnu/usr.bin/perl/eg/scan/scan_sudo b/gnu/usr.bin/perl/eg/scan/scan_sudo
index 8f86e9b3637..9c23731b50c 100644
--- a/gnu/usr.bin/perl/eg/scan/scan_sudo
+++ b/gnu/usr.bin/perl/eg/scan/scan_sudo
@@ -1,6 +1,6 @@
#!/usr/bin/perl -P
-# $RCSfile: scan_sudo,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:57 $
+# $RCSfile: scan_sudo,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:53 $
# Analyze the sudo log.
diff --git a/gnu/usr.bin/perl/eg/scan/scan_suid b/gnu/usr.bin/perl/eg/scan/scan_suid
index 51f886f52f0..8f31bed736f 100644
--- a/gnu/usr.bin/perl/eg/scan/scan_suid
+++ b/gnu/usr.bin/perl/eg/scan/scan_suid
@@ -1,6 +1,6 @@
#!/usr/bin/perl -P
-# $RCSfile: scan_suid,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:57 $
+# $RCSfile: scan_suid,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:54 $
# Look for new setuid root files.
diff --git a/gnu/usr.bin/perl/eg/scan/scanner b/gnu/usr.bin/perl/eg/scan/scanner
index dbc8057791d..25db7904dcd 100644
--- a/gnu/usr.bin/perl/eg/scan/scanner
+++ b/gnu/usr.bin/perl/eg/scan/scanner
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: scanner,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:57 $
+# $RCSfile: scanner,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:55 $
# This runs all the scan_* routines on all the machines in /etc/ghosts.
# We run this every morning at about 6 am:
diff --git a/gnu/usr.bin/perl/eg/shmkill b/gnu/usr.bin/perl/eg/shmkill
index a82622ca691..958f9fca995 100644
--- a/gnu/usr.bin/perl/eg/shmkill
+++ b/gnu/usr.bin/perl/eg/shmkill
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: shmkill,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:54 $
+# $RCSfile: shmkill,v $$Revision: 1.2 $$Date: 1997/11/30 07:49:43 $
# A script to call from crontab periodically when people are leaving shared
# memory sitting around unattached.
diff --git a/gnu/usr.bin/perl/eg/sysvipc/ipcmsg b/gnu/usr.bin/perl/eg/sysvipc/ipcmsg
index 317e027ea75..646d8b6aed6 100644
--- a/gnu/usr.bin/perl/eg/sysvipc/ipcmsg
+++ b/gnu/usr.bin/perl/eg/sysvipc/ipcmsg
@@ -1,6 +1,6 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
- if 0;
+ if $running_under_some_shell;
require 'sys/ipc.ph';
require 'sys/msg.ph';
diff --git a/gnu/usr.bin/perl/eg/sysvipc/ipcsem b/gnu/usr.bin/perl/eg/sysvipc/ipcsem
index d72a2dd77c9..e0dc551bc5f 100644
--- a/gnu/usr.bin/perl/eg/sysvipc/ipcsem
+++ b/gnu/usr.bin/perl/eg/sysvipc/ipcsem
@@ -1,6 +1,6 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
- if 0;
+ if $running_under_some_shell;
require 'sys/ipc.ph';
require 'sys/msg.ph';
@@ -18,7 +18,7 @@ print "semaphore id: $id\n";
if ($signal) {
while (<STDIN>) {
print "Signalling\n";
- unless (semop($id, 0, pack("sss", 0, 1, 0))) {
+ unless (semop($id, pack("sss", 0, 1, 0))) {
die "Can't signal semaphore: $!\n";
}
}
@@ -26,7 +26,7 @@ if ($signal) {
else {
$SIG{'INT'} = $SIG{'QUIT'} = "leave";
for (;;) {
- unless (semop($id, 0, pack("sss", 0, -1, 0))) {
+ unless (semop($id, pack("sss", 0, -1, 0))) {
die "Can't wait for semaphore: $!\n";
}
print "Unblocked\n";
diff --git a/gnu/usr.bin/perl/eg/sysvipc/ipcshm b/gnu/usr.bin/perl/eg/sysvipc/ipcshm
index d40e46b9450..ecc1ba4366c 100644
--- a/gnu/usr.bin/perl/eg/sysvipc/ipcshm
+++ b/gnu/usr.bin/perl/eg/sysvipc/ipcshm
@@ -1,6 +1,6 @@
#!/usr/bin/perl
eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
- if 0;
+ if $running_under_some_shell;
require 'sys/ipc.ph';
require 'sys/shm.ph';
diff --git a/gnu/usr.bin/perl/eg/van/empty b/gnu/usr.bin/perl/eg/van/empty
index 05415209ecc..37a8063979c 100644
--- a/gnu/usr.bin/perl/eg/van/empty
+++ b/gnu/usr.bin/perl/eg/van/empty
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: empty,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:58 $
+# $RCSfile: empty,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:59 $
# This script empties a trashcan.
diff --git a/gnu/usr.bin/perl/eg/van/unvanish b/gnu/usr.bin/perl/eg/van/unvanish
index f87c79432e3..fe277c16683 100644
--- a/gnu/usr.bin/perl/eg/van/unvanish
+++ b/gnu/usr.bin/perl/eg/van/unvanish
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: unvanish,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:58 $
+# $RCSfile: unvanish,v $$Revision: 1.2 $$Date: 1997/11/30 07:54:59 $
sub it {
if ($olddir ne '.') {
diff --git a/gnu/usr.bin/perl/eg/van/vanexp b/gnu/usr.bin/perl/eg/van/vanexp
index 6d6a5466d9f..b5bb5095477 100644
--- a/gnu/usr.bin/perl/eg/van/vanexp
+++ b/gnu/usr.bin/perl/eg/van/vanexp
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: vanexp,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:58 $
+# $RCSfile: vanexp,v $$Revision: 1.2 $$Date: 1997/11/30 07:55:00 $
# This is for running from a find at night to expire old .deleteds
diff --git a/gnu/usr.bin/perl/eg/van/vanish b/gnu/usr.bin/perl/eg/van/vanish
index cf764ca0d1e..2f391d6c07e 100644
--- a/gnu/usr.bin/perl/eg/van/vanish
+++ b/gnu/usr.bin/perl/eg/van/vanish
@@ -1,6 +1,6 @@
#!/usr/bin/perl
-# $RCSfile: vanish,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:11:58 $
+# $RCSfile: vanish,v $$Revision: 1.2 $$Date: 1997/11/30 07:55:00 $
sub it {
if ($olddir ne '.') {
diff --git a/gnu/usr.bin/perl/eg/wrapsuid b/gnu/usr.bin/perl/eg/wrapsuid
index 22eee552865..5ee7f6e614f 100644
--- a/gnu/usr.bin/perl/eg/wrapsuid
+++ b/gnu/usr.bin/perl/eg/wrapsuid
@@ -2,12 +2,11 @@
'di';
'ig00';
#
-# $Header: /home/cvs/src/gnu/usr.bin/perl/eg/Attic/wrapsuid,v 1.1.1.1 1996/08/19 10:11:54 downsj Exp $
+# $Header: /home/cvs/src/gnu/usr.bin/perl/eg/Attic/wrapsuid,v 1.2 1997/11/30 07:49:44 millert Exp $
#
# $Log: wrapsuid,v $
-# Revision 1.1.1.1 1996/08/19 10:11:54 downsj
-# Import of Perl 5.003 into the tree. Makefile.bsd-wrapper and
-# config.sh.OpenBSD are the only local changes.
+# Revision 1.2 1997/11/30 07:49:44 millert
+# perl 5.004_04
#
# Revision 1.1 90/08/11 13:51:29 lwall
# Initial revision
diff --git a/gnu/usr.bin/perl/emacs/cperl-mode.el b/gnu/usr.bin/perl/emacs/cperl-mode.el
index 5917d22e840..b00d77a1156 100644
--- a/gnu/usr.bin/perl/emacs/cperl-mode.el
+++ b/gnu/usr.bin/perl/emacs/cperl-mode.el
@@ -6,9 +6,12 @@
;;; Date: 14 Aug 91 15:20:01 GMT
;; Perl code editing commands for Emacs
-;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
+;; Copyright (C) 1985-1996 Bob Olson, Ilya Zakharevich
-;; This file is not (yet) part of GNU Emacs.
+;; This file is not (yet) part of GNU Emacs. It may be distributed
+;; either under the same terms as GNU Emacs, or under the same terms
+;; as Perl. You should have received a copy of Perl Artistic license
+;; along with the Perl distribution.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
@@ -21,13 +24,15 @@
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu
;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de
-;; $Id: cperl-mode.el,v 1.20 1996/02/09 03:40:01 ilya Exp ilya $
+;; $Id: cperl-mode.el,v 1.39 1997/10/14 08:28:00 ilya Exp ilya $
;;; To use this mode put the following into your .emacs file:
@@ -41,16 +46,20 @@
;;; in your .emacs file. (Emacs rulers do not consider it politically
;;; correct to make whistles enabled by default.)
+;;; DO NOT FORGET to read micro-docs. (available from `Perl' menu). <<<<<<
+;;; or as help on variables `cperl-tips', `cperl-problems', <<<<<<
+;;; `cperl-non-problems', `cperl-praise'. <<<<<<
+
;;; Additional useful commands to put into your .emacs file:
;; (setq auto-mode-alist
-;; (append '(("\\.[pP][Llm]$" . perl-mode)) auto-mode-alist ))
+;; (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist ))
;; (setq interpreter-mode-alist (append interpreter-mode-alist
;; '(("miniperl" . perl-mode))))
-;;; The mode information (on C-h m) provides customization help.
+;;; The mode information (on C-h m) provides some customization help.
;;; If you use font-lock feature of this mode, it is advisable to use
-;;; eather lazy-lock-mode or fast-lock-mode (available on ELisp
+;;; either lazy-lock-mode or fast-lock-mode (available on ELisp
;;; archive in files lazy-lock.el and fast-lock.el). I prefer lazy-lock.
;;; Faces used now: three faces for first-class and second-class keywords
@@ -60,12 +69,12 @@
;;; not define them, so you need to define them manually. Maybe you have
;;; an obsolete font-lock from 19.28 or earlier. Upgrade.
-;;; If you have grayscale monitor, and do not have the variable
+;;; If you have a grayscale monitor, and do not have the variable
;;; font-lock-display-type bound to 'grayscale, insert
;;; (setq font-lock-display-type 'grayscale)
-;;; to your .emacs file.
+;;; into your .emacs file.
;;;; This mode supports font-lock, imenu and mode-compile. In the
;;;; hairy version font-lock is on, but you should activate imenu
@@ -245,6 +254,217 @@
;;; pod sections which are broken because of whitespace before =blah
;;; - just observe the fontification.
+;;;; After 1.20
+;;; Anonymous subs are indented with respect to the level of
+;;; indentation of `sub' now.
+;;; {} is recognized as hash after `bless' and `return'.
+;;; Anonymous subs are split by `cperl-linefeed' as well.
+;;; Electric parens embrace a region if present.
+;;; To make `cperl-auto-newline' useful,
+;;; `cperl-auto-newline-after-colon' is introduced.
+;;; `cperl-electric-parens' is now t or nul. The old meaning is moved to
+;;; `cperl-electric-parens-string'.
+;;; `cperl-toggle-auto-newline' introduced, put on C-c C-a.
+;;; `cperl-toggle-abbrev' introduced, put on C-c C-k.
+;;; `cperl-toggle-electric' introduced, put on C-c C-e.
+;;; Beginning-of-defun-regexp was not anchored.
+
+;;;; After 1.21
+;;; Auto-newline grants `cperl-extra-newline-before-brace' if "{" is typed
+;;; after ")".
+;;; {} is recognized as expression after `tr' and friends.
+
+;;;; After 1.22
+;;; Entry Hierarchy added to imenu. Very primitive so far.
+;;; One needs newer `imenu-go'.el. A patch to `imenu' is needed as well.
+;;; Writes its own TAGS files.
+;;; Class viewer based on TAGS files. Does not trace @ISA so far.
+;;; 19.31: Problems with scan for PODs corrected.
+;;; First POD header correctly fontified.
+;;; I needed (setq imenu-use-keymap-menu t) to get good imenu in 19.31.
+;;; Apparently it makes a lot of hierarchy code obsolete...
+
+;;;; After 1.23
+;;; Tags filler now scans *.xs as well.
+;;; The info from *.xs scan is used by the hierarchy viewer.
+;;; Hierarchy viewer documented.
+;;; Bug in 19.31 imenu documented.
+
+;;;; After 1.24
+;;; New location for info-files mentioned,
+;;; Electric-; should work better.
+;;; Minor bugs with POD marking.
+
+;;;; After 1.25 (probably not...)
+;;; `cperl-info-page' introduced.
+;;; To make `uncomment-region' working, `comment-region' would
+;;; not insert extra space.
+;;; Here documents delimiters better recognized
+;;; (empty one, and non-alphanums in quotes handled). May be wrong with 1<<14?
+;;; `cperl-db' added, used in menu.
+;;; imenu scan removes text-properties, for better debugging
+;;; - but the bug is in 19.31 imenu.
+;;; formats highlighted by font-lock and prescan, embedded comments
+;;; are not treated.
+;;; POD/friends scan merged in one pass.
+;;; Syntax class is not used for analyzing the code, only char-syntax
+;;; may be checked against _ or'ed with w.
+;;; Syntax class of `:' changed to be _.
+;;; `cperl-find-bad-style' added.
+
+;;;; After 1.25
+;;; When search for here-documents, we ignore commented << in simplest cases.
+;;; `cperl-get-help' added, available on C-h v and from menu.
+;;; Auto-help added. Default with `cperl-hairy', switchable on/off
+;;; with startup variable `cperl-lazy-help-time' and from
+;;; menu. Requires `run-with-idle-timer'.
+;;; Highlighting of @abc{@efg} was wrong - interchanged two regexps.
+
+;;;; After 1.27
+;;; Indentation: At toplevel after a label - fixed.
+;;; 1.27 was put to archives in binary mode ===> DOSish :-(
+
+;;;; After 1.28
+;;; Thanks to Martin Buchholz <mrb@Eng.Sun.COM>: misprints in
+;;; comments and docstrings corrected, XEmacs support cleaned up.
+;;; The closing parenths would enclose the region into matching
+;;; parens under the same conditions as the opening ones.
+;;; Minor updates to `cperl-short-docs'.
+;;; Will not consider <<= as start of here-doc.
+
+;;;; After 1.29
+;;; Added an extra advice to look into Micro-docs. ;-).
+;;; Enclosing of region when you press a closing parenth is regulated by
+;;; `cperl-electric-parens-string'.
+;;; Minor updates to `cperl-short-docs'.
+;;; `initialize-new-tags-table' called only if present (Does this help
+;;; with generation of tags under XEmacs?).
+;;; When creating/updating tag files, new info is written at the old place,
+;;; or at the end (is this a wanted behaviour? I need this in perl build directory).
+
+;;;; After 1.30
+;;; All the keywords from keywords.pl included (maybe with dummy explanation).
+;;; No auto-help inside strings, comment, here-docs, formats, and pods.
+;;; Shrinkwrapping of info, regulated by `cperl-max-help-size',
+;;; `cperl-shrink-wrap-info-frame'.
+;;; Info on variables as well.
+;;; Recognision of HERE-DOCS improved yet more.
+;;; Autonewline works on `}' without warnings.
+;;; Autohelp works again on $_[0].
+
+;;;; After 1.31
+;;; perl-descr.el found its author - hi, Johan!
+;;; Some support for correct indent after here-docs and friends (may
+;;; be superseeded by eminent change to Emacs internals).
+;;; Should work with older Emaxen as well ( `-style stuff removed).
+
+;;;; After 1.32
+
+;;; Started to add support for `syntax-table' property (should work
+;;; with patched Emaxen), controlled by
+;;; `cperl-use-syntax-table-text-property'. Currently recognized:
+;;; All quote-like operators: m, s, y, tr, qq, qw, qx, q,
+;;; // in most frequent context:
+;;; after block or
+;;; ~ { ( = | & + - * ! , ;
+;;; or
+;;; while if unless until and or not xor split grep map
+;;; Here-documents, formats, PODs,
+;;; ${...}
+;;; 'abc$'
+;;; sub a ($); sub a ($) {}
+;;; (provide 'cperl-mode) was missing!
+;;; `cperl-after-expr-p' is now much smarter after `}'.
+;;; `cperl-praise' added to mini-docs.
+;;; Utilities try to support subs-with-prototypes.
+
+;;;; After 1.32.1
+;;; `cperl-after-expr-p' is now much smarter after "() {}" and "word {}":
+;;; if word is "else, map, grep".
+;;; Updated for new values of syntax-table constants.
+;;; Uses `help-char' (at last!) (disabled, does not work?!)
+;;; A couple of regexps where missing _ in character classes.
+;;; -s could be considered as start of regexp, 1../blah/ was not,
+;;; as was not /blah/ at start of file.
+
+;;;; After 1.32.2
+;;; "\C-hv" was wrongly "\C-hf"
+;;; C-hv was not working on `[index()]' because of [] in skip-chars-*.
+;;; `__PACKAGE__' supported.
+;;; Thanks for Greg Badros: `cperl-lazy-unstall' is more complete,
+;;; `cperl-get-help' is made compatible with `query-replace'.
+
+;;;; As of Apr 15, development version of 19.34 supports
+;;;; `syntax-table' text properties. Try setting
+;;;; `cperl-use-syntax-table-text-property'.
+
+;;;; After 1.32.3
+;;; We scan for s{}[] as well (in simplest situations).
+;;; We scan for $blah'foo as well.
+;;; The default is to use `syntax-table' text property if Emacs is good enough.
+;;; `cperl-lineup' is put on C-M-| (=C-M-S-\\).
+;;; Start of `cperl-beautify-regexp'.
+
+;;;; After 1.32.4
+;;; `cperl-tags-hier-init' did not work in text-mode.
+;;; `cperl-noscan-files-regexp' had a misprint.
+;;; Generation of Class Hierarchy was broken due to a bug in `x-popup-menu'
+;;; in 19.34.
+
+;;;; After 1.33:
+;;; my,local highlight vars after {} too.
+;;; TAGS could not be created before imenu was loaded.
+;;; `cperl-indent-left-aligned-comments' created.
+;;; Logic of `cperl-indent-exp' changed a little bit, should be more
+;;; robust w.r.t. multiline strings.
+;;; Recognition of blah'foo takes into account strings.
+;;; Added '.al' to the list of Perl extensions.
+;;; Class hierarchy is "mostly" sorted (need to rethink algorthm
+;;; of pruning one-root-branch subtrees to get yet better sorting.)
+;;; Regeneration of TAGS was busted.
+;;; Can use `syntax-table' property when generating TAGS
+;;; (governed by `cperl-use-syntax-table-text-property-for-tags').
+
+;;;; After 1.35:
+;;; Can process several =pod/=cut sections one after another.
+;;; Knows of `extproc' when under `emx', indents with `__END__' and `__DATA__'.
+;;; `cperl-under-as-char' implemented (XEmacs people like broken behaviour).
+;;; Beautifier for regexps fixed.
+;;; `cperl-beautify-level', `cperl-contract-level' coded
+;;;
+;;;; Emacs's 20.2 problems:
+;;; `imenu.el' has bugs, `imenu-add-to-menubar' does not work.
+;;; Couple of others problems with 20.2 were reported, my ability to check/fix
+;;; them is very reduced now.
+
+;;;; After 1.36:
+;;; 'C-M-|' in XEmacs fixed
+
+;;;; After 1.37:
+;;; &&s was not recognized as start of regular expression;
+;;; Will "preprocess" the contents of //e part of s///e too;
+;;; What to do with s# blah # foo #e ?
+;;; Should handle s;blah;foo;; better.
+;;; Now the only known problems with regular expression recognition:
+;;;;;;; s<foo>/bar/ - different delimiters (end ignored)
+;;;;;;; s/foo/\\bar/ - backslash at start of subst (made into one chunk)
+;;;;;;; s/foo// - empty subst (made into one chunk + '/')
+;;;;;;; s/foo/(bar)/ - start-group at start of subst (internal group will not match backwards)
+
+;;;; After 1.38:
+;;; We highlight closing / of s/blah/foo/e;
+;;; This handles s# blah # foo #e too;
+;;; s//blah/, s///, s/blah// works again, and s#blah## too, the algorithm
+;;; is much simpler now;
+;;; Next round of changes: s\\\ works, s<blah>/foo/,
+;;; comments between the first and the second part allowed
+;;; Another problem discovered:
+;;;;;;; s[foo] <blah>e - e part delimited by different <> (will not match)
+;;; `cperl-find-pods-heres' somehow maybe called when string-face is undefined
+;;; - put a stupid workaround for 20.1
+
+(defconst cperl-xemacs-p (string-match "XEmacs\\|Lucid" emacs-version))
+
(defvar cperl-extra-newline-before-brace nil
"*Non-nil means that if, elsif, while, until, else, for, foreach
and do constructs look like:
@@ -284,7 +504,14 @@ This is in addition to cperl-continued-statement-offset.")
(defvar cperl-auto-newline nil
"*Non-nil means automatically newline before and after braces,
-and after colons and semicolons, inserted in CPerl code.")
+and after colons and semicolons, inserted in CPerl code. The following
+\\[cperl-electric-backspace] will remove the inserted whitespace.
+Insertion after colons requires both this variable and
+`cperl-auto-newline-after-colon' set.")
+
+(defvar cperl-auto-newline-after-colon nil
+ "*Non-nil means automatically newline even after colons.
+Subject to `cperl-auto-newline' setting.")
(defvar cperl-tab-always-indent t
"*Non-nil means TAB in CPerl mode should always reindent the current line,
@@ -295,12 +522,24 @@ regardless of where in the line point is when the TAB command is used.")
Can be overwritten by `cperl-hairy' if nil.")
(defvar cperl-electric-lbrace-space nil
- "*Non-nil (and non-null) means { after $ in CPerl buffers should be preceeded by ` '.
+ "*Non-nil (and non-null) means { after $ in CPerl buffers should be preceded by ` '.
Can be overwritten by `cperl-hairy' if nil.")
-(defvar cperl-electric-parens ""
- "*List of parentheses that should be electric in CPerl, or null.
-Can be overwritten by `cperl-hairy' to \"({[<\" if not 'null.")
+(defvar cperl-electric-parens-string "({[]})<"
+ "*String of parentheses that should be electric in CPerl.
+Closing ones are electric only if the region is highlighted.")
+
+(defvar cperl-electric-parens nil
+ "*Non-nil (and non-null) means parentheses should be electric in CPerl.
+Can be overwritten by `cperl-hairy' if nil.")
+(defvar cperl-electric-parens-mark
+ (and window-system
+ (or (and (boundp 'transient-mark-mode) ; For Emacs
+ transient-mark-mode)
+ (and (boundp 'zmacs-regions) ; For XEmacs
+ zmacs-regions)))
+ "*Not-nil means that electric parens look for active mark.
+Default is yes if there is visual feedback on mark.")
(defvar cperl-electric-linefeed nil
"*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy.
@@ -326,6 +565,9 @@ Can be overwritten by `cperl-hairy' if nil.")
The opposite behaviour is always available if prefixed with C-c.
Can be overwritten by `cperl-hairy' if nil.")
+(defvar cperl-lazy-help-time nil
+ "*Not-nil (and non-null) means to show lazy help after given idle time.")
+
(defvar cperl-pod-face 'font-lock-comment-face
"*The result of evaluation of this expression is used for pod highlighting.")
@@ -343,6 +585,45 @@ Font for POD headers.")
"*Not-nil means look for pod and here-docs sections during startup.
You can always make lookup from menu or using \\[cperl-find-pods-heres].")
+(defvar cperl-imenu-addback nil
+ "*Not-nil means add backreferences to generated `imenu's.
+May require patched `imenu' and `imenu-go'.")
+
+(defvar cperl-max-help-size 66
+ "*Non-nil means shrink-wrapping of info-buffer allowed up to these percents.")
+
+(defvar cperl-shrink-wrap-info-frame t
+ "*Non-nil means shrink-wrapping of info-buffer-frame allowed.")
+
+(defvar cperl-info-page "perl"
+ "*Name of the info page containing perl docs.
+Older version of this page was called `perl5', newer `perl'.")
+
+(defvar cperl-use-syntax-table-text-property
+ (boundp 'parse-sexp-lookup-properties)
+ "*Non-nil means CPerl sets up and uses `syntax-table' text property.")
+
+(defvar cperl-use-syntax-table-text-property-for-tags
+ cperl-use-syntax-table-text-property
+ "*Non-nil means: set up and use `syntax-table' text property generating TAGS.")
+
+(defvar cperl-scan-files-regexp "\\.\\([pP][Llm]\\|xs\\)$"
+ "*Regexp to match files to scan when generating TAGS.")
+
+(defvar cperl-noscan-files-regexp "/\\(\\.\\.?\\|SCCS\\|RCS\\|blib\\)$"
+ "*Regexp to match files/dirs to skip when generating TAGS.")
+
+(defvar cperl-regexp-indent-step nil
+ "*indentation used when beautifying regexps.
+If `nil', the value of `cperl-indent-level' will be used.")
+
+(defvar cperl-indent-left-aligned-comments t
+ "*Non-nil means that the comment starting in leftmost column should indent.")
+
+(defvar cperl-under-as-char t
+ "*Non-nil means that the _ (underline) should be treated as word char.")
+
+
;;; Short extra-docs.
@@ -353,20 +634,32 @@ You can always make lookup from menu or using \\[cperl-find-pods-heres].")
and/or
ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
-Get support packages font-lock-extra.el, imenu-go.el from the same place.
-\(Look for other files there too... ;-) Get a patch for imenu.el in 19.29.
-Note that for 19.30 you should use choose-color.el *instead* of
-font-lock-extra.el (and you will not get smart highlighting in C :-().
+Get support packages choose-color.el (or font-lock-extra.el before
+19.30), imenu-go.el from the same place. \(Look for other files there
+too... ;-) Get a patch for imenu.el in 19.29. Note that for 19.30 and
+later you should use choose-color.el *instead* of font-lock-extra.el
+\(and you will not get smart highlighting in C :-().
Note that to enable Compile choices in the menu you need to install
mode-compile.el.
Get perl5-info from
+ $CPAN/doc/manual/info/perl-info.tar.gz
+older version was on
http://www.metronet.com:70/9/perlinfo/perl5/manual/perl5-info.tar.gz
-\(may be quite obsolete, but still useful).
-If you use imenu-go, run imenu on perl5-info buffer (you can do it from
-CPerl menu).
+If you use imenu-go, run imenu on perl5-info buffer (you can do it
+from CPerl menu). If many files are related, generate TAGS files from
+Tools/Tags submenu in CPerl menu.
+
+If some class structure is too complicated, use Tools/Hierarchy-view
+from CPerl menu, or hierarchic view of imenu. The second one uses the
+current buffer only, the first one requires generation of TAGS from
+CPerl/Tools/Tags menu beforehand.
+
+Run CPerl/Tools/Insert-spaces-if-needed to fix your lazy typing.
+
+Switch auto-help on/off with CPerl/Tools/Auto-help.
Before reporting (non-)problems look in the problem section on what I
know about them.")
@@ -374,43 +667,44 @@ know about them.")
(defvar cperl-problems 'please-ignore-this-line
"Emacs has a _very_ restricted syntax parsing engine.
-It may be corrected on the level of C ocde, please look in the
-`non-problems' section if you want to volonteer.
+It may be corrected on the level of C code, please look in the
+`non-problems' section if you want to volunteer.
CPerl mode tries to corrects some Emacs misunderstandings, however,
-for effeciency reasons the degree of correction is different for
+for efficiency reasons the degree of correction is different for
different operations. The partially corrected problems are: POD
sections, here-documents, regexps. The operations are: highlighting,
indentation, electric keywords, electric braces.
This may be confusing, since the regexp s#//#/#\; may be highlighted
-as a comment, but it will recognized as a regexp by the indentation
+as a comment, but it will be recognized as a regexp by the indentation
code. Or the opposite case, when a pod section is highlighted, but
-breaks the indentation of the following code.
+may break the indentation of the following code (though indentation
+should work if the balance of delimiters is not broken by POD).
The main trick (to make $ a \"backslash\") makes constructions like
-${aaa} look like unbalanced braces. The only trick I can think out is
+${aaa} look like unbalanced braces. The only trick I can think of is
to insert it as $ {aaa} (legal in perl5, not in perl4).
Similar problems arise in regexps, when /(\\s|$)/ should be rewritten
-as /($|\\s)/. Note that such a transpositinon is not always possible
+as /($|\\s)/. Note that such a transposition is not always possible
:-(. " )
(defvar cperl-non-problems 'please-ignore-this-line
-"As you know from `problems' section, Perl syntax too hard for CPerl.
+"As you know from `problems' section, Perl syntax is too hard for CPerl.
Most the time, if you write your own code, you may find an equivalent
\(and almost as readable) expression.
-Try to help it: add comments with embedded quotes to fix CPerl
+Try to help CPerl: add comments with embedded quotes to fix CPerl
misunderstandings about the end of quotation:
$a='500$'; # ';
You won't need it too often. The reason: $ \"quotes\" the following
character (this saves a life a lot of times in CPerl), thus due to
-Emacs parsing rules it does not consider tick after the dollar as a
-closing one, but as a usual character.
+Emacs parsing rules it does not consider tick (i.e., ' ) after a
+dollar as a closing one, but as a usual character.
Now the indentation code is pretty wise. The only drawback is that it
relies on Emacs parsing to find matching parentheses. And Emacs
@@ -420,6 +714,10 @@ will not break indentation, but
1 if ( s#//#/# );
will.
+By similar reasons
+ s\"abc\"def\";
+will confuse CPerl a lot.
+
If you still get wrong indentation in situation that you think the
code should be able to parse, try:
@@ -429,20 +727,90 @@ b) Supply the code to me (IZ).
Pods are treated _very_ rudimentally. Here-documents are not treated
at all (except highlighting and inhibiting indentation). (This may
change some time. RMS approved making syntax lookup recognize text
-attributes, but volonteers are needed to change Emacs C code.)
+attributes, but volunteers are needed to change Emacs C code.)
To speed up coloring the following compromises exist:
a) sub in $mypackage::sub may be highlighted.
b) -z in [a-z] may be highlighted.
c) if your regexp contains a keyword (like \"s\"), it may be highlighted.
+
+
+Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove
+`car' before `imenu-choose-buffer-index' in `imenu'.
+")
+
+(defvar cperl-praise 'please-ignore-this-line
+ "RMS asked me to list good things about CPerl. Here they go:
+
+0) It uses the newest `syntax-table' property ;-);
+
+1) It does 99% of Perl syntax correct (as opposed to 80-90% in Perl
+mode - but the latter number may have improved too in last years) even
+without `syntax-table' property; When using this property, it should
+handle 99.995% of lines correct - or somesuch.
+
+2) It is generally belived to be \"the most user-friendly Emacs
+package\" whatever it may mean (I doubt that the people who say similar
+things tried _all_ the rest of Emacs ;-), but this was not a lonely
+voice);
+
+3) Everything is customizable, one-by-one or in a big sweep;
+
+4) It has many easily-accessable \"tools\":
+ a) Can run program, check syntax, start debugger;
+ b) Can lineup vertically \"middles\" of rows, like `=' in
+ a = b;
+ cc = d;
+ c) Can insert spaces where this impoves readability (in one
+ interactive sweep over the buffer);
+ d) Has support for imenu, including:
+ 1) Separate unordered list of \"interesting places\";
+ 2) Separate TOC of POD sections;
+ 3) Separate list of packages;
+ 4) Hierarchical view of methods in (sub)packages;
+ 5) and functions (by the full name - with package);
+ e) Has an interface to INFO docs for Perl; The interface is
+ very flexible, including shrink-wrapping of
+ documentation buffer/frame;
+ f) Has a builtin list of one-line explanations for perl constructs.
+ g) Can show these explanations if you stay long enough at the
+ corresponding place (or on demand);
+ h) Has an enhanced fontification (using 3 or 4 additional faces
+ comparing to font-lock - basically, different
+ namespaces in Perl have different colors);
+ i) Can construct TAGS basing on its knowledge of Perl syntax,
+ the standard menu has 6 different way to generate
+ TAGS (if by directory, .xs files - with C-language
+ bindings - are included in the scan);
+ j) Can build a hierarchical view of classes (via imenu) basing
+ on generated TAGS file;
+ k) Has electric parentheses, electric newlines, uses Abbrev
+ for electric logical constructs
+ while () {}
+ with different styles of expansion (context sensitive
+ to be not so bothering). Electric parentheses behave
+ \"as they should\" in a presence of a visible region.
+ l) Changes msb.el \"on the fly\" to insert a group \"Perl files\";
+
+5) The indentation engine was very smart, but most of tricks may be
+not needed anymore with the support for `syntax-table' property. Has
+progress indicator for indentation (with `imenu' loaded).
+
+6) Indent-region improves inline-comments as well;
+
+7) Fill-paragraph correctly handles multi-line comments;
")
;;; Portability stuff:
-(defsubst cperl-xemacs-p ()
- (string-match "XEmacs\\|Lucid" emacs-version))
+(defmacro cperl-define-key (fsf-key definition &optional xemacs-key)
+ (` (define-key cperl-mode-map
+ (, (if xemacs-key
+ (` (if cperl-xemacs-p (, xemacs-key) (, fsf-key)))
+ fsf-key))
+ (, definition))))
(defvar del-back-ch (car (append (where-is-internal 'delete-backward-char)
(where-is-internal 'backward-delete-char-untabify)))
@@ -451,19 +819,22 @@ To speed up coloring the following compromises exist:
(and (vectorp del-back-ch) (= (length del-back-ch) 1)
(setq del-back-ch (aref del-back-ch 0)))
-(if (cperl-xemacs-p)
- ;; "Active regions" are on: use region only if active
- ;; "Active regions" are off: use region unconditionally
- (defun cperl-use-region-p ()
- (if zmacs-regions (mark) t))
+(if cperl-xemacs-p
+ (progn
+ ;; "Active regions" are on: use region only if active
+ ;; "Active regions" are off: use region unconditionally
+ (defun cperl-use-region-p ()
+ (if zmacs-regions (mark) t))
+ (defun cperl-mark-active () (mark)))
(defun cperl-use-region-p ()
- (if transient-mark-mode mark-active t)))
+ (if transient-mark-mode mark-active t))
+ (defun cperl-mark-active () mark-active))
(defsubst cperl-enable-font-lock ()
- (or (cperl-xemacs-p) window-system))
+ (or cperl-xemacs-p window-system))
(if (boundp 'unread-command-events)
- (if (cperl-xemacs-p)
+ (if cperl-xemacs-p
(defun cperl-putback-char (c) ; XEmacs >= 19.12
(setq unread-command-events (list (character-to-event c))))
(defun cperl-putback-char (c) ; Emacs 19
@@ -482,11 +853,18 @@ To speed up coloring the following compromises exist:
'lazy-lock)
"Text property which inhibits refontification.")
+(defsubst cperl-put-do-not-fontify (from to)
+ (put-text-property (max (point-min) (1- from))
+ to cperl-do-not-fontify t))
+
+(defvar cperl-mode-hook nil
+ "Hook run by `cperl-mode'.")
+
;;; Probably it is too late to set these guys already, but it can help later:
(setq auto-mode-alist
- (append '(("\\.[pP][Llm]$" . perl-mode)) auto-mode-alist ))
+ (append '(("\\.\\([pP][Llm]\\|al\\)$" . perl-mode)) auto-mode-alist ))
(and (boundp 'interpreter-mode-alist)
(setq interpreter-mode-alist (append interpreter-mode-alist
'(("miniperl" . perl-mode)))))
@@ -516,36 +894,45 @@ To speed up coloring the following compromises exist:
(if cperl-mode-map nil
(setq cperl-mode-map (make-sparse-keymap))
- (define-key cperl-mode-map "{" 'cperl-electric-lbrace)
- (define-key cperl-mode-map "[" 'cperl-electric-paren)
- (define-key cperl-mode-map "(" 'cperl-electric-paren)
- (define-key cperl-mode-map "<" 'cperl-electric-paren)
- (define-key cperl-mode-map "}" 'cperl-electric-brace)
- (define-key cperl-mode-map ";" 'cperl-electric-semi)
- (define-key cperl-mode-map ":" 'cperl-electric-terminator)
- (define-key cperl-mode-map "\C-j" 'newline-and-indent)
- (define-key cperl-mode-map "\C-c\C-j" 'cperl-linefeed)
- (define-key cperl-mode-map "\e\C-q" 'cperl-indent-exp) ; Usually not bound
- ;;(define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph)
- ;;(define-key cperl-mode-map "\e;" 'cperl-indent-for-comment)
- (define-key cperl-mode-map "\177" 'backward-delete-char-untabify)
- (define-key cperl-mode-map "\t" 'cperl-indent-command)
- (if (cperl-xemacs-p)
- ;; don't clobber the backspace binding:
- (define-key cperl-mode-map [(control h) f] 'cperl-info-on-command)
- (define-key cperl-mode-map "\C-hf" 'cperl-info-on-command))
- (if (cperl-xemacs-p)
- ;; don't clobber the backspace binding:
- (define-key cperl-mode-map [(control c) (control h) f]
- 'cperl-info-on-current-command)
- (define-key cperl-mode-map "\C-c\C-hf" 'cperl-info-on-current-command))
- (if (and (cperl-xemacs-p)
+ (cperl-define-key "{" 'cperl-electric-lbrace)
+ (cperl-define-key "[" 'cperl-electric-paren)
+ (cperl-define-key "(" 'cperl-electric-paren)
+ (cperl-define-key "<" 'cperl-electric-paren)
+ (cperl-define-key "}" 'cperl-electric-brace)
+ (cperl-define-key "]" 'cperl-electric-rparen)
+ (cperl-define-key ")" 'cperl-electric-rparen)
+ (cperl-define-key ";" 'cperl-electric-semi)
+ (cperl-define-key ":" 'cperl-electric-terminator)
+ (cperl-define-key "\C-j" 'newline-and-indent)
+ (cperl-define-key "\C-c\C-j" 'cperl-linefeed)
+ (cperl-define-key "\C-c\C-a" 'cperl-toggle-auto-newline)
+ (cperl-define-key "\C-c\C-k" 'cperl-toggle-abbrev)
+ (cperl-define-key "\C-c\C-e" 'cperl-toggle-electric)
+ (cperl-define-key "\e\C-q" 'cperl-indent-exp) ; Usually not bound
+ (cperl-define-key [?\C-\M-\|] 'cperl-lineup
+ [(control meta |)])
+ ;;(cperl-define-key "\M-q" 'cperl-fill-paragraph)
+ ;;(cperl-define-key "\e;" 'cperl-indent-for-comment)
+ (cperl-define-key "\177" 'cperl-electric-backspace)
+ (cperl-define-key "\t" 'cperl-indent-command)
+ ;; don't clobber the backspace binding:
+ (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command
+ [(control c) (control h) f])
+ (cperl-define-key "\C-hf"
+ ;;(concat (char-to-string help-char) "f") ; does not work
+ 'cperl-info-on-command
+ [(control h) f])
+ (cperl-define-key "\C-hv"
+ ;;(concat (char-to-string help-char) "v") ; does not work
+ 'cperl-get-help
+ [(control h) v])
+ (if (and cperl-xemacs-p
(<= emacs-minor-version 11) (<= emacs-major-version 19))
(progn
;; substitute-key-definition is usefulness-deenhanced...
- (define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph)
- (define-key cperl-mode-map "\e;" 'cperl-indent-for-comment)
- (define-key cperl-mode-map "\e\C-\\" 'cperl-indent-region))
+ (cperl-define-key "\M-q" 'cperl-fill-paragraph)
+ (cperl-define-key "\e;" 'cperl-indent-for-comment)
+ (cperl-define-key "\e\C-\\" 'cperl-indent-region))
(substitute-key-definition
'indent-sexp 'cperl-indent-exp
cperl-mode-map global-map)
@@ -559,6 +946,7 @@ To speed up coloring the following compromises exist:
'indent-for-comment 'cperl-indent-for-comment
cperl-mode-map global-map)))
+(defvar cperl-menu)
(condition-case nil
(progn
(require 'easymenu)
@@ -569,11 +957,18 @@ To speed up coloring the following compromises exist:
["Mark function" mark-defun t]
["Indent expression" cperl-indent-exp t]
["Fill paragraph/comment" cperl-fill-paragraph t]
+ "----"
["Line up a construction" cperl-lineup (cperl-use-region-p)]
+ ["Beautify a regexp" cperl-beautify-regexp
+ cperl-use-syntax-table-text-property]
+ ["Beautify a group in regexp" cperl-beautify-level
+ cperl-use-syntax-table-text-property]
+ ["Contract a group in regexp" cperl-contract-level
+ cperl-use-syntax-table-text-property]
"----"
["Indent region" cperl-indent-region (cperl-use-region-p)]
- ["Comment region" comment-region (cperl-use-region-p)]
- ["Uncomment region" uncomment-region (cperl-use-region-p)]
+ ["Comment region" cperl-comment-region (cperl-use-region-p)]
+ ["Uncomment region" cperl-uncomment-region (cperl-use-region-p)]
"----"
["Run" mode-compile (fboundp 'mode-compile)]
["Kill" mode-compile-kill (and (fboundp 'mode-compile-kill)
@@ -581,25 +976,48 @@ To speed up coloring the following compromises exist:
["Next error" next-error (get-buffer "*compilation*")]
["Check syntax" cperl-check-syntax (fboundp 'mode-compile)]
"----"
- ["Debugger" perldb t]
+ ["Debugger" cperl-db t]
"----"
("Tools"
["Imenu" imenu (fboundp 'imenu)]
+ ["Insert spaces if needed" cperl-find-bad-style t]
+ ["Class Hierarchy from TAGS" cperl-tags-hier-init t]
+ ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
["Imenu on info" cperl-imenu-on-info (featurep 'imenu)]
("Tags"
- ["Create tags for current file" cperl-etags t]
- ["Add tags for current file" (cperl-etags t) t]
- ["Create tags for Perl files in directory" (cperl-etags nil t) t]
- ["Add tags for Perl files in directory" (cperl-etags t t) t]
+;;; ["Create tags for current file" cperl-etags t]
+;;; ["Add tags for current file" (cperl-etags t) t]
+;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t]
+;;; ["Add tags for Perl files in directory" (cperl-etags t t) t]
+;;; ["Create tags for Perl files in (sub)directories"
+;;; (cperl-etags nil 'recursive) t]
+;;; ["Add tags for Perl files in (sub)directories"
+;;; (cperl-etags t 'recursive) t])
+;;;; cperl-write-tags (&optional file erase recurse dir inbuffer)
+ ["Create tags for current file" (cperl-write-tags nil t) t]
+ ["Add tags for current file" (cperl-write-tags) t]
+ ["Create tags for Perl files in directory"
+ (cperl-write-tags nil t nil t) t]
+ ["Add tags for Perl files in directory"
+ (cperl-write-tags nil nil nil t) t]
["Create tags for Perl files in (sub)directories"
- (cperl-etags nil 'recursive) t]
+ (cperl-write-tags nil t t t) t]
["Add tags for Perl files in (sub)directories"
- (cperl-etags t 'recursive) t])
- ["Recalculate PODs" cperl-find-pods-heres t]
+ (cperl-write-tags nil nil t t) t])
+ ["Recalculate \"hard\" constructions" cperl-find-pods-heres t]
["Define word at point" imenu-go-find-at-position
(fboundp 'imenu-go-find-at-position)]
["Help on function" cperl-info-on-command t]
- ["Help on function at point" cperl-info-on-current-command t])
+ ["Help on function at point" cperl-info-on-current-command t]
+ ["Help on symbol at point" cperl-get-help t]
+ ["Auto-help on" cperl-lazy-install (fboundp 'run-with-idle-timer)]
+ ["Auto-help off" cperl-lazy-unstall
+ (fboundp 'run-with-idle-timer)])
+ ("Toggle..."
+ ["Auto newline" cperl-toggle-auto-newline t]
+ ["Electric parens" cperl-toggle-electric t]
+ ["Electric keywords" cperl-toggle-abbrev t]
+ )
("Indent styles..."
["GNU" (cperl-set-style "GNU") t]
["C++" (cperl-set-style "C++") t]
@@ -609,7 +1027,8 @@ To speed up coloring the following compromises exist:
("Micro-docs"
["Tips" (describe-variable 'cperl-tips) t]
["Problems" (describe-variable 'cperl-problems) t]
- ["Non-problems" (describe-variable 'cperl-non-problems) t]))))
+ ["Non-problems" (describe-variable 'cperl-non-problems) t]
+ ["Praise" (describe-variable 'cperl-praise) t]))))
(error nil))
(autoload 'c-macro-expand "cmacexp"
@@ -620,6 +1039,9 @@ The expansion is entirely correct because it uses the C preprocessor."
(defvar cperl-mode-syntax-table nil
"Syntax table in use in Cperl-mode buffers.")
+(defvar cperl-string-syntax-table nil
+ "Syntax table in use in Cperl-mode string-like chunks.")
+
(if cperl-mode-syntax-table
()
(setq cperl-mode-syntax-table (make-syntax-table))
@@ -638,8 +1060,14 @@ The expansion is entirely correct because it uses the C preprocessor."
(modify-syntax-entry ?# "<" cperl-mode-syntax-table)
(modify-syntax-entry ?' "\"" cperl-mode-syntax-table)
(modify-syntax-entry ?` "\"" cperl-mode-syntax-table)
- (modify-syntax-entry ?_ "w" cperl-mode-syntax-table)
- (modify-syntax-entry ?| "." cperl-mode-syntax-table))
+ (if cperl-under-as-char
+ (modify-syntax-entry ?_ "w" cperl-mode-syntax-table))
+ (modify-syntax-entry ?: "_" cperl-mode-syntax-table)
+ (modify-syntax-entry ?| "." cperl-mode-syntax-table)
+ (setq cperl-string-syntax-table (copy-syntax-table cperl-mode-syntax-table))
+ (modify-syntax-entry ?$ "." cperl-string-syntax-table)
+ (modify-syntax-entry ?# "." cperl-string-syntax-table) ; (?# comment )
+)
@@ -655,6 +1083,9 @@ The expansion is entirely correct because it uses the C preprocessor."
;; provide an alias for working with emacs 19. the perl-mode that comes
;; with it is really bad, and this lets us seamlessly replace it.
(fset 'perl-mode 'cperl-mode)
+(defvar cperl-faces-init)
+;; Fix for msb.el
+(defvar cperl-msb-fixed nil)
(defun cperl-mode ()
"Major mode for editing Perl code.
Expression and list commands understand all C brackets.
@@ -669,8 +1100,11 @@ default.) You can always quote (with \\[quoted-insert]) the left
\"paren\" to avoid the expansion. The processing of < is special,
since most the time you mean \"less\". Cperl mode tries to guess
whether you want to type pair <>, and inserts is if it
-appropriate. You can set `cperl-electric-parens' to the string that
+appropriate. You can set `cperl-electric-parens-string' to the string that
contains the parenths from the above list you want to be electrical.
+Electricity of parenths is controlled by `cperl-electric-parens'.
+You may also set `cperl-electric-parens-mark' to have electric parens
+look for active mark and \"embrace\" a region if possible.'
CPerl mode provides expansion of the Perl control constructs:
if, else, elsif, unless, while, until, for, and foreach.
@@ -692,13 +1126,13 @@ between the braces. If CPerl decides that you want to insert
it will not do any expansion. See also help on variable
`cperl-extra-newline-before-brace'.
-\\[cperl-linefeed] is a convinience replacement for typing carriage
+\\[cperl-linefeed] is a convenience replacement for typing carriage
return. It places you in the next line with proper indentation, or if
you type it inside the inline block of control construct, like
foreach (@lines) {print; print}
and you are on a boundary of a statement inside braces, it will
transform the construct into a multiline and will place you into an
-apporpriately indented blank line. If you need a usual
+appropriately indented blank line. If you need a usual
`newline-and-indent' behaviour, it is on \\[newline-and-indent],
see documentation on `cperl-electric-linefeed'.
@@ -706,14 +1140,17 @@ see documentation on `cperl-electric-linefeed'.
Setting the variable `cperl-font-lock' to t switches on
font-lock-mode, `cperl-electric-lbrace-space' to t switches on
-electric space between $ and {, `cperl-electric-parens' is the string
-that contains parentheses that should be electric in CPerl, setting
-`cperl-electric-keywords' enables electric expansion of control
-structures in CPerl. `cperl-electric-linefeed' governs which one of
-two linefeed behavior is preferable. You can enable all these options
-simultaneously (recommended mode of use) by setting `cperl-hairy' to
-t. In this case you can switch separate options off by setting them
-to `null'.
+electric space between $ and {, `cperl-electric-parens-string' is the
+string that contains parentheses that should be electric in CPerl (see
+also `cperl-electric-parens-mark' and `cperl-electric-parens'),
+setting `cperl-electric-keywords' enables electric expansion of
+control structures in CPerl. `cperl-electric-linefeed' governs which
+one of two linefeed behavior is preferable. You can enable all these
+options simultaneously (recommended mode of use) by setting
+`cperl-hairy' to t. In this case you can switch separate options off
+by setting them to `null'. Note that one may undo the extra whitespace
+inserted by semis and braces in `auto-newline'-mode by consequent
+\\[cperl-electric-backspace].
If your site has perl5 documentation in info format, you can use commands
\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it.
@@ -721,6 +1158,19 @@ These keys run commands `cperl-info-on-current-command' and
`cperl-info-on-command', which one is which is controlled by variable
`cperl-info-on-command-no-prompt' (in turn affected by `cperl-hairy').
+Even if you have no info-format documentation, short one-liner-style
+help is available on \\[cperl-get-help].
+
+It is possible to show this help automatically after some idle
+time. This is regulated by variable `cperl-lazy-help-time'. Default
+with `cperl-hairy' is 5 secs idle time if the value of this variable
+is nil. It is also possible to switch this on/off from the
+menu. Requires `run-with-idle-timer'.
+
+Use \\[cperl-lineup] to vertically lineup some construction - put the
+beginning of the region at the start of construction, and make region
+span the needed amount of lines.
+
Variables `cperl-pod-here-scan', `cperl-pod-here-fontify',
`cperl-pod-face', `cperl-pod-head-face' control processing of pod and
here-docs sections. In a future version results of scan may be used
@@ -732,7 +1182,13 @@ Variables controlling indentation style:
regardless of where in the line point is when the TAB command is used.
`cperl-auto-newline'
Non-nil means automatically newline before and after braces,
- and after colons and semicolons, inserted in Perl code.
+ and after colons and semicolons, inserted in Perl code. The following
+ \\[cperl-electric-backspace] will remove the inserted whitespace.
+ Insertion after colons requires both this variable and
+ `cperl-auto-newline-after-colon' set.
+ `cperl-auto-newline-after-colon'
+ Non-nil means automatically newline even after colons.
+ Subject to `cperl-auto-newline' setting.
`cperl-indent-level'
Indentation of Perl statements within surrounding block.
The surrounding block's indentation is the indentation
@@ -779,15 +1235,10 @@ with no args."
(local-set-key "\C-C\C-J" 'newline-and-indent)))
(if (cperl-val 'cperl-info-on-command-no-prompt)
(progn
- (if (cperl-xemacs-p)
- ;; don't clobber the backspace binding:
- (local-set-key [(control h) f] 'cperl-info-on-current-command)
- (local-set-key "\C-hf" 'cperl-info-on-current-command))
- (if (cperl-xemacs-p)
- ;; don't clobber the backspace binding:
- (local-set-key [(control c) (control h) f]
- 'cperl-info-on-command)
- (local-set-key "\C-c\C-hf" 'cperl-info-on-command))))
+ ;; don't clobber the backspace binding:
+ (cperl-define-key "\C-hf" 'cperl-info-on-current-command [(control h) f])
+ (cperl-define-key "\C-c\C-hf" 'cperl-info-on-command
+ [(control c) (control h) f])))
(setq major-mode 'perl-mode)
(setq mode-name "CPerl")
(if (not cperl-mode-abbrev-table)
@@ -825,7 +1276,7 @@ with no args."
(make-local-variable 'comment-start-skip)
(setq comment-start-skip "#+ *")
(make-local-variable 'defun-prompt-regexp)
- (setq defun-prompt-regexp "[ \t]*sub\\s +\\([^ \t\n{;]+\\)\\s *")
+ (setq defun-prompt-regexp "^[ \t]*sub[ \t]+\\([^ \t\n{(;]+\\)[ \t]*")
(make-local-variable 'comment-indent-function)
(setq comment-indent-function 'cperl-comment-indent)
(make-local-variable 'parse-sexp-ignore-comments)
@@ -847,6 +1298,11 @@ with no args."
'((perl-font-lock-keywords
perl-font-lock-keywords-1
perl-font-lock-keywords-2))))
+ (if cperl-use-syntax-table-text-property
+ (progn
+ (make-variable-buffer-local 'parse-sexp-lookup-properties)
+ ;; Do not introduce variable if not needed, we check it!
+ (set 'parse-sexp-lookup-properties t)))
(or (fboundp 'cperl-old-auto-fill-mode)
(progn
(fset 'cperl-old-auto-fill-mode (symbol-function 'auto-fill-mode))
@@ -862,12 +1318,27 @@ with no args."
(and (boundp 'msb-menu-cond)
(not cperl-msb-fixed)
(cperl-msb-fix))
+ (if (featurep 'easymenu)
+ (easy-menu-add cperl-menu)) ; A NOP under FSF Emacs.
(run-hooks 'cperl-mode-hook)
;; After hooks since fontification will break this
(if cperl-pod-here-scan (cperl-find-pods-heres)))
-;; Fix for msb.el
-(defvar cperl-msb-fixed nil)
+;; Fix for perldb - make default reasonable
+(defun cperl-db ()
+ (interactive)
+ (require 'gud)
+ (perldb (read-from-minibuffer "Run perldb (like this): "
+ (if (consp gud-perldb-history)
+ (car gud-perldb-history)
+ (concat "perl " ;;(file-name-nondirectory
+ ;; I have problems
+ ;; in OS/2
+ ;; otherwise
+ (buffer-file-name)))
+ nil nil
+ '(gud-perldb-history . 1))))
+
(defun cperl-msb-fix ()
;; Adds perl files to msb menu, supposes that msb is already loaded
@@ -927,7 +1398,7 @@ with no args."
;;; (setq prevc (current-column)))))))
(defun cperl-indent-for-comment ()
- "Substite for `indent-for-comment' in CPerl."
+ "Substitute for `indent-for-comment' in CPerl."
(interactive)
(let (cperl-wrong-comment)
(indent-for-comment)
@@ -935,56 +1406,111 @@ with no args."
(progn (cperl-to-comment-or-eol)
(forward-char (length comment-start))))))
+(defun cperl-comment-region (b e arg)
+ "Comment or uncomment each line in the region in CPerl mode.
+See `comment-region'."
+ (interactive "r\np")
+ (let ((comment-start "#"))
+ (comment-region b e arg)))
+
+(defun cperl-uncomment-region (b e arg)
+ "Uncomment or comment each line in the region in CPerl mode.
+See `comment-region'."
+ (interactive "r\np")
+ (let ((comment-start "#"))
+ (comment-region b e (- arg))))
+
+(defvar cperl-brace-recursing nil)
+
(defun cperl-electric-brace (arg &optional only-before)
"Insert character and correct line's indentation.
If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the
-place (even in empty line), but not after."
+place (even in empty line), but not after. If after \")\" and the inserted
+char is \"{\", insert extra newline before only if
+`cperl-extra-newline-before-brace'."
(interactive "P")
- (let (insertpos)
- (if (and (not arg) ; No args, end (of empty line or auto)
- (eolp)
- (or (and (null only-before)
- (save-excursion
- (skip-chars-backward " \t")
- (bolp)))
- (if cperl-auto-newline
- (progn (cperl-indent-line) (newline) t) nil)))
+ (let (insertpos
+ (other-end (if (and cperl-electric-parens-mark
+ (cperl-mark-active)
+ (< (mark) (point)))
+ (mark)
+ nil)))
+ (if (and other-end
+ (not cperl-brace-recursing)
+ (cperl-val 'cperl-electric-parens)
+ (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point)))
+ ;; Need to insert a matching pair
(progn
- (if cperl-auto-newline
- (setq insertpos (point)))
- (insert last-command-char)
- (cperl-indent-line)
- (if (and cperl-auto-newline (null only-before))
- (progn
- (newline)
- (cperl-indent-line)))
(save-excursion
- (if insertpos (progn (goto-char insertpos)
- (search-forward (make-string
- 1 last-command-char))
- (setq insertpos (1- (point)))))
- (delete-char -1))))
- (if insertpos
- (save-excursion
- (goto-char insertpos)
- (self-insert-command (prefix-numeric-value arg)))
- (self-insert-command (prefix-numeric-value arg)))))
+ (setq insertpos (point-marker))
+ (goto-char other-end)
+ (setq last-command-char ?\{)
+ (cperl-electric-lbrace arg insertpos))
+ (forward-char 1))
+ (if (and (not arg) ; No args, end (of empty line or auto)
+ (eolp)
+ (or (and (null only-before)
+ (save-excursion
+ (skip-chars-backward " \t")
+ (bolp)))
+ (and (eq last-command-char ?\{) ; Do not insert newline
+ ;; if after ")" and `cperl-extra-newline-before-brace'
+ ;; is nil, do not insert extra newline.
+ (not cperl-extra-newline-before-brace)
+ (save-excursion
+ (skip-chars-backward " \t")
+ (eq (preceding-char) ?\))))
+ (if cperl-auto-newline
+ (progn (cperl-indent-line) (newline) t) nil)))
+ (progn
+ (insert last-command-char)
+ (cperl-indent-line)
+ (if cperl-auto-newline
+ (setq insertpos (1- (point))))
+ (if (and cperl-auto-newline (null only-before))
+ (progn
+ (newline)
+ (cperl-indent-line)))
+ (save-excursion
+ (if insertpos (progn (goto-char insertpos)
+ (search-forward (make-string
+ 1 last-command-char))
+ (setq insertpos (1- (point)))))
+ (delete-char -1))))
+ (if insertpos
+ (save-excursion
+ (goto-char insertpos)
+ (self-insert-command (prefix-numeric-value arg)))
+ (self-insert-command (prefix-numeric-value arg))))))
-(defun cperl-electric-lbrace (arg)
+(defun cperl-electric-lbrace (arg &optional end)
"Insert character, correct line's indentation, correct quoting by space."
(interactive "P")
- (let (pos after (cperl-auto-newline cperl-auto-newline))
+ (let (pos after
+ (cperl-brace-recursing t)
+ (cperl-auto-newline cperl-auto-newline)
+ (other-end (or end
+ (if (and cperl-electric-parens-mark
+ (cperl-mark-active)
+ (> (mark) (point)))
+ (save-excursion
+ (goto-char (mark))
+ (point-marker))
+ nil))))
(and (cperl-val 'cperl-electric-lbrace-space)
(eq (preceding-char) ?$)
(save-excursion
(skip-chars-backward "$")
(looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)"))
(insert ? ))
- (if (cperl-after-expr-p) nil (setq cperl-auto-newline nil))
+ (if (cperl-after-expr-p nil "{;)") nil (setq cperl-auto-newline nil))
(cperl-electric-brace arg)
- (and (eq last-command-char ?{)
+ (and (cperl-val 'cperl-electric-parens)
+ (eq last-command-char ?{)
(memq last-command-char
- (append (cperl-val 'cperl-electric-parens "" "([{<") nil))
+ (append cperl-electric-parens-string nil))
+ (or (if other-end (goto-char (marker-position other-end)))
+ t)
(setq last-command-char ?} pos (point))
(progn (cperl-electric-brace arg t)
(goto-char pos)))))
@@ -992,16 +1518,25 @@ place (even in empty line), but not after."
(defun cperl-electric-paren (arg)
"Insert a matching pair of parentheses."
(interactive "P")
- (let ((beg (save-excursion (beginning-of-line) (point))))
- (if (and (memq last-command-char
- (append (cperl-val 'cperl-electric-parens "" "([{<") nil))
+ (let ((beg (save-excursion (beginning-of-line) (point)))
+ (other-end (if (and cperl-electric-parens-mark
+ (cperl-mark-active)
+ (> (mark) (point)))
+ (save-excursion
+ (goto-char (mark))
+ (point-marker))
+ nil)))
+ (if (and (cperl-val 'cperl-electric-parens)
+ (memq last-command-char
+ (append cperl-electric-parens-string nil))
(>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))
;;(not (save-excursion (search-backward "#" beg t)))
(if (eq last-command-char ?<)
- (cperl-after-expr-p nil "{};(,:=")
+ (cperl-after-expr-p nil "{;(,:=")
1))
(progn
(insert last-command-char)
+ (if other-end (goto-char (marker-position other-end)))
(insert (cdr (assoc last-command-char '((?{ .?})
(?[ . ?])
(?( . ?))
@@ -1010,12 +1545,45 @@ place (even in empty line), but not after."
(insert last-command-char)
)))
+(defun cperl-electric-rparen (arg)
+ "Insert a matching pair of parentheses if marking is active.
+If not, or if we are not at the end of marking range, would self-insert."
+ (interactive "P")
+ (let ((beg (save-excursion (beginning-of-line) (point)))
+ (other-end (if (and cperl-electric-parens-mark
+ (cperl-val 'cperl-electric-parens)
+ (memq last-command-char
+ (append cperl-electric-parens-string nil))
+ (cperl-mark-active)
+ (< (mark) (point)))
+ (mark)
+ nil))
+ p)
+ (if (and other-end
+ (cperl-val 'cperl-electric-parens)
+ (memq last-command-char '( ?\) ?\] ?\} ?\> ))
+ (>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))
+ ;;(not (save-excursion (search-backward "#" beg t)))
+ )
+ (progn
+ (insert last-command-char)
+ (setq p (point))
+ (if other-end (goto-char other-end))
+ (insert (cdr (assoc last-command-char '((?\} . ?\{)
+ (?\] . ?\[)
+ (?\) . ?\()
+ (?\> . ?\<)))))
+ (goto-char (1+ p)))
+ (call-interactively 'self-insert-command)
+ )))
+
(defun cperl-electric-keyword ()
"Insert a construction appropriate after a keyword."
- (let ((beg (save-excursion (beginning-of-line) (point))))
+ (let ((beg (save-excursion (beginning-of-line) (point)))
+ (dollar (eq last-command-char ?$)))
(and (save-excursion
(backward-sexp 1)
- (cperl-after-expr-p nil "{};:"))
+ (cperl-after-expr-p nil "{;:"))
(save-excursion
(not
(re-search-backward
@@ -1024,6 +1592,7 @@ place (even in empty line), but not after."
(save-excursion (or (not (re-search-backward "^=" nil t))
(looking-at "=cut")))
(progn
+ (and dollar (insert " $"))
(cperl-indent-line)
;;(insert " () {\n}")
(cond
@@ -1039,7 +1608,9 @@ place (even in empty line), but not after."
)
(or (looking-at "[ \t]\\|$") (insert " "))
(cperl-indent-line)
- (search-backward ")")
+ (if dollar (progn (search-backward "$")
+ (forward-char 1))
+ (search-backward ")"))
(cperl-putback-char del-back-ch)))))
(defun cperl-electric-else ()
@@ -1047,7 +1618,7 @@ place (even in empty line), but not after."
(let ((beg (save-excursion (beginning-of-line) (point))))
(and (save-excursion
(backward-sexp 1)
- (cperl-after-expr-p nil "{};:"))
+ (cperl-after-expr-p nil "{;:"))
(save-excursion
(not
(re-search-backward
@@ -1081,33 +1652,25 @@ place (even in empty line), but not after."
(pos (point)) start)
(if (and ; Check if we need to split:
; i.e., on a boundary and inside "{...}"
- ;;(not (search-backward "\\(^\\|[^$\\\\]\\)#" beg t))
(save-excursion (cperl-to-comment-or-eol)
- (>= (point) pos))
+ (>= (point) pos)) ; Not in a comment
(or (save-excursion
(skip-chars-backward " \t" beg)
(forward-char -1)
- (looking-at "[;{]"))
- (looking-at "[ \t]*}")
- (re-search-forward "\\=[ \t]*;" end t))
+ (looking-at "[;{]")) ; After { or ; + spaces
+ (looking-at "[ \t]*}") ; Before }
+ (re-search-forward "\\=[ \t]*;" end t)) ; Before spaces + ;
(save-excursion
(and
- (eq (car (parse-partial-sexp pos end -1)) -1)
- (looking-at "[ \t]*\\($\\|#\\)")
- ;;(setq finish (point-marker))
+ (eq (car (parse-partial-sexp pos end -1)) -1)
+ ; Leave the level of parens
+ (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr
+ ; Are at end
(progn
(backward-sexp 1)
(setq start (point-marker))
- (<= start pos))
- ;;(looking-at "[^{}\n]*}[ \t]*$") ; Will fail if there are intervening {}'s
- ;;(search-backward "{" beg t)
- ;;(looking-at "{[^{}\n]*}[ \t]*$")
- )))
- ;;(or (looking-at "[ \t]*}") ; and on a boundary of statements
- ;; (save-excursion
- ;; (skip-chars-backward " \t")
- ;; (forward-char -1)
- ;; (looking-at "[{;]"))))
+ (<= start pos))))) ; Redundant? Are after the
+ ; start of parens group.
(progn
(skip-chars-backward " \t")
(or (memq (preceding-char) (append ";{" nil))
@@ -1115,8 +1678,6 @@ place (even in empty line), but not after."
(insert "\n")
(forward-line -1)
(cperl-indent-line)
- ;;(end-of-line)
- ;;(search-backward "{" beg)
(goto-char start)
(or (looking-at "{[ \t]*$") ; If there is a statement
; before, move it to separate line
@@ -1127,7 +1688,7 @@ place (even in empty line), but not after."
(forward-line 1) ; We are on the target line
(cperl-indent-line)
(beginning-of-line)
- (or (looking-at "[ \t]*}[ \t]*$") ; If there is a statement
+ (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement
; after, move it to separate line
(progn
(end-of-line)
@@ -1142,10 +1703,19 @@ place (even in empty line), but not after."
(end-of-line)
(newline-and-indent))
(end-of-line) ; else
- (if (not (looking-at "\n[ \t]*$"))
- (newline-and-indent)
- (forward-line 1)
- (cperl-indent-line)))))
+ (cond
+ ((and (looking-at "\n[ \t]*{$")
+ (save-excursion
+ (skip-chars-backward " \t")
+ (eq (preceding-char) ?\)))) ; Probably if () {} group
+ ; with an extra newline.
+ (forward-line 2)
+ (cperl-indent-line))
+ ((looking-at "\n[ \t]*$") ; Next line is empty - use it.
+ (forward-line 1)
+ (cperl-indent-line))
+ (t
+ (newline-and-indent))))))
(defun cperl-electric-semi (arg)
"Insert character and correct line's indentation."
@@ -1157,8 +1727,12 @@ place (even in empty line), but not after."
(defun cperl-electric-terminator (arg)
"Insert character and correct line's indentation."
(interactive "P")
- (let (insertpos (end (point)))
- (if (and (not arg) (eolp)
+ (let (insertpos (end (point))
+ (auto (and cperl-auto-newline
+ (or (not (eq last-command-char ?:))
+ cperl-auto-newline-after-colon))))
+ (if (and ;;(not arg)
+ (eolp)
(not (save-excursion
(beginning-of-line)
(skip-chars-forward " \t")
@@ -1180,26 +1754,47 @@ place (even in empty line), but not after."
(let ((pps (parse-partial-sexp (point) end)))
(or (nth 3 pps) (nth 4 pps) (nth 5 pps))))))))
(progn
- (if cperl-auto-newline
- (setq insertpos (point)))
(insert last-command-char)
+ ;;(forward-char -1)
+ (if auto (setq insertpos (point-marker)))
+ ;;(forward-char 1)
(cperl-indent-line)
- (if cperl-auto-newline
+ (if auto
(progn
(newline)
(cperl-indent-line)))
+;; (save-excursion
+;; (if insertpos (progn (goto-char (marker-position insertpos))
+;; (search-forward (make-string
+;; 1 last-command-char))
+;; (setq insertpos (1- (point)))))
+;; (delete-char -1))))
(save-excursion
- (if insertpos (progn (goto-char insertpos)
- (search-forward (make-string
- 1 last-command-char))
- (setq insertpos (1- (point)))))
- (delete-char -1))))
+ (if insertpos (goto-char (1- (marker-position insertpos)))
+ (forward-char -1))
+ (delete-char 1))))
(if insertpos
(save-excursion
(goto-char insertpos)
(self-insert-command (prefix-numeric-value arg)))
(self-insert-command (prefix-numeric-value arg)))))
+(defun cperl-electric-backspace (arg)
+ "Backspace-untabify, or remove the whitespace inserted by an electric key."
+ (interactive "p")
+ (if (and cperl-auto-newline
+ (memq last-command '(cperl-electric-semi
+ cperl-electric-terminator
+ cperl-electric-lbrace))
+ (memq (preceding-char) '(? ?\t ?\n)))
+ (let (p)
+ (if (eq last-command 'cperl-electric-lbrace)
+ (skip-chars-forward " \t\n"))
+ (setq p (point))
+ (skip-chars-backward " \t\n")
+ (delete-region (point) p))
+ (backward-delete-char-untabify arg)))
+
(defun cperl-inside-parens-p ()
(condition-case ()
(save-excursion
@@ -1211,7 +1806,6 @@ place (even in empty line), but not after."
(error nil)))
(defun cperl-indent-command (&optional whole-exp)
- (interactive "P")
"Indent current line as Perl code, or in some cases insert a tab character.
If `cperl-tab-always-indent' is non-nil (the default), always indent current line.
Otherwise, indent the current line only if point is at the left margin
@@ -1221,6 +1815,7 @@ A numeric argument, regardless of its value,
means indent rigidly all the lines of the expression starting after point
so that this line becomes properly indented.
The relative indentation among the lines of the expression are preserved."
+ (interactive "P")
(if whole-exp
;; If arg, always indent this line as Perl
;; and shift remaining lines of expression the same amount.
@@ -1254,7 +1849,7 @@ Return the amount the indentation changed by."
(setq indent (cperl-calculate-indent nil symbol))
(beginning-of-line)
(setq beg (point))
- (cond ((eq indent nil)
+ (cond ((or (eq indent nil) (eq indent t))
(setq indent (current-indentation)))
;;((eq indent t) ; Never?
;; (setq indent (cperl-calculate-indent-within-comment)))
@@ -1263,7 +1858,7 @@ Return the amount the indentation changed by."
(t
(skip-chars-forward " \t")
(if (listp indent) (setq indent (car indent)))
- (cond ((looking-at "[A-Za-z]+:[^:]")
+ (cond ((looking-at "[A-Za-z_][A-Za-z_0-9]*:[^:]")
(and (> indent 0)
(setq indent (max cperl-min-label-indent
(+ indent cperl-label-offset)))))
@@ -1293,7 +1888,7 @@ Return the amount the indentation changed by."
'(?w ?_))
(progn
(backward-sexp)
- (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:"))))
+ (looking-at "[a-zA-Z_][a-zA-Z0-9_]*:[^:]"))))
(defun cperl-get-state (&optional parse-start start-state)
;; returns list (START STATE DEPTH PRESTART), START is a good place
@@ -1331,34 +1926,68 @@ Return the amount the indentation changed by."
(or (memq (preceding-char) (append ";){}$@&%\C-@" nil)) ; Or label! \C-@ at bobp
; Label may be mixed up with `$blah :'
(save-excursion (cperl-after-label))
- (and (eq (char-syntax (preceding-char)) ?w)
+ (and (memq (char-syntax (preceding-char)) '(?w ?_))
(progn
(backward-sexp)
- (or (looking-at "\\sw+[ \t\n\f]*[{#]") ; Method call syntax
+ ;; Need take into account `bless', `return', `tr',...
+ (or (and (looking-at "[a-zA-Z0-9_:]+[ \t\n\f]*[{#]") ; Method call syntax
+ (not (looking-at "\\(bless\\|return\\|qw\\|tr\\|[smy]\\)\\>")))
(progn
(skip-chars-backward " \t\n\f")
- (and (eq (char-syntax (preceding-char)) ?w)
+ (and (memq (char-syntax (preceding-char)) '(?w ?_))
(progn
(backward-sexp)
(looking-at
- "sub[ \t]+\\sw+[ \t\n\f]*[#{]")))))))))
+ "sub[ \t]+[a-zA-Z0-9_:]+[ \t\n\f]*\\(([^()]*)[ \t\n\f]*\\)?[#{]")))))))))
+
+(defvar cperl-look-for-prop '((pod in-pod) (here-doc-delim here-doc-group)))
(defun cperl-calculate-indent (&optional parse-start symbol)
"Return appropriate indentation for current line as Perl code.
In usual case returns an integer: the column to indent to.
Returns nil if line starts inside a string, t if in a comment."
(save-excursion
- (if (memq (get-text-property (point) 'syntax-type) '(pod here-doc)) nil
- (beginning-of-line)
- (let* ((indent-point (point))
- (case-fold-search nil)
+ (if (or
+ (memq (get-text-property (point) 'syntax-type)
+ '(pod here-doc here-doc-delim format))
+ ;; before start of POD - whitespace found since do not have 'pod!
+ (and (looking-at "[ \t]*\n=")
+ (error "Spaces before pod section!"))
+ (and (not cperl-indent-left-aligned-comments)
+ (looking-at "^#")))
+ nil
+ (beginning-of-line)
+ (let ((indent-point (point))
+ (char-after (save-excursion
+ (skip-chars-forward " \t")
+ (following-char)))
+ (in-pod (get-text-property (point) 'in-pod))
+ (pre-indent-point (point))
+ p prop look-prop)
+ (cond
+ (in-pod
+ ;; In the verbatim part, probably code example. What to do???
+ )
+ (t
+ (save-excursion
+ ;; Not in pod
+ (cperl-backward-to-noncomment nil)
+ (setq p (max (point-min) (1- (point)))
+ prop (get-text-property p 'syntax-type)
+ look-prop (or (nth 1 (assoc prop cperl-look-for-prop))
+ 'syntax-type))
+ (if (memq prop '(pod here-doc format here-doc-delim))
+ (progn
+ (goto-char (or (previous-single-property-change p look-prop)
+ (point-min)))
+ (beginning-of-line)
+ (setq pre-indent-point (point)))))))
+ (goto-char pre-indent-point)
+ (let* ((case-fold-search nil)
(s-s (cperl-get-state))
(start (nth 0 s-s))
(state (nth 1 s-s))
(containing-sexp (car (cdr state)))
- (char-after (save-excursion
- (skip-chars-forward " \t")
- (following-char)))
(start-indent (save-excursion
(goto-char start)
(- (current-indentation)
@@ -1424,7 +2053,12 @@ Returns nil if line starts inside a string, t if in a comment."
;; Now add a little if this is a continuation line.
(if (or (bobp)
(memq (preceding-char) (append " ;}" nil)) ; Was ?\)
- (memq char-after (append ")]}" nil)))
+ (memq char-after (append ")]}" nil))
+ (and (eq (preceding-char) ?\:) ; label
+ (progn
+ (forward-sexp -1)
+ (skip-chars-backward " \t")
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*[ \t]*:"))))
0
cperl-continued-statement-offset))))
((/= (char-after containing-sexp) ?{)
@@ -1451,7 +2085,7 @@ Returns nil if line starts inside a string, t if in a comment."
(t
;; Statement level. Is it a continuation or a new statement?
;; Find previous non-comment character.
- (goto-char indent-point)
+ (goto-char pre-indent-point)
(cperl-backward-to-noncomment containing-sexp)
;; Back up over label lines, since they don't
;; affect whether our line is a continuation.
@@ -1486,7 +2120,7 @@ Returns nil if line starts inside a string, t if in a comment."
(or
;; If no, find that first statement and indent like
;; it. If the first statement begins with label, do
- ;; not belive when the indentation of the label is too
+ ;; not believe when the indentation of the label is too
;; small.
(save-excursion
(forward-char 1)
@@ -1509,7 +2143,7 @@ Returns nil if line starts inside a string, t if in a comment."
(if (> (current-indentation)
cperl-min-label-indent)
(- (current-indentation) cperl-label-offset)
- ;; Do not belive: `max' is involved
+ ;; Do not believe: `max' is involved
(+ old-indent cperl-indent-level))
(current-column)))))
;; If no previous statement,
@@ -1535,17 +2169,35 @@ Returns nil if line starts inside a string, t if in a comment."
(progn
(if (eq (preceding-char) ?\))
(forward-sexp -1))
- ;; Get initial indentation of the line we are on.
- ;; If line starts with label, calculate label indentation
- (if (save-excursion
- (beginning-of-line)
- (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]"))
- (if (> (current-indentation) cperl-min-label-indent)
- (- (current-indentation) cperl-label-offset)
- (cperl-calculate-indent
- (if (and parse-start (<= parse-start (point)))
- parse-start)))
- (current-indentation))))))))))))
+ ;; In the case it starts a subroutine, indent with
+ ;; respect to `sub', not with respect to the the
+ ;; first thing on the line, say in the case of
+ ;; anonymous sub in a hash.
+ ;;
+ (skip-chars-backward " \t")
+ (if (and (eq (preceding-char) ?b)
+ (progn
+ (forward-sexp -1)
+ (looking-at "sub\\>"))
+ (setq old-indent
+ (nth 1
+ (parse-partial-sexp
+ (save-excursion (beginning-of-line) (point))
+ (point)))))
+ (progn (goto-char (1+ old-indent))
+ (skip-chars-forward " \t")
+ (current-column))
+ ;; Get initial indentation of the line we are on.
+ ;; If line starts with label, calculate label indentation
+ (if (save-excursion
+ (beginning-of-line)
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
+ (if (> (current-indentation) cperl-min-label-indent)
+ (- (current-indentation) cperl-label-offset)
+ (cperl-calculate-indent
+ (if (and parse-start (<= parse-start (point)))
+ parse-start)))
+ (current-indentation))))))))))))))
(defvar cperl-indent-alist
'((string nil)
@@ -1641,7 +2293,7 @@ POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'."
(or
;; If no, find that first statement and indent like
;; it. If the first statement begins with label, do
- ;; not belive when the indentation of the label is too
+ ;; not believe when the indentation of the label is too
;; small.
(save-excursion
(forward-char 1)
@@ -1667,7 +2319,7 @@ POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'."
(if (> (current-indentation)
cperl-min-label-indent)
(list (list 'label-in-block (point)))
- ;; Do not belive: `max' is involved
+ ;; Do not believe: `max' is involved
(list
(list 'label-in-block-min-indent (point))))
;; Before statement
@@ -1699,7 +2351,7 @@ POS may be nil if it is hard to find, say, when TYPE is `string' or `comment'."
;; If line starts with label, calculate label indentation
(if (save-excursion
(beginning-of-line)
- (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]"))
+ (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_0-9]*:[^:]"))
(if (> (current-indentation) cperl-min-label-indent)
(- (current-indentation) cperl-label-offset)
(cperl-calculate-indent
@@ -1729,7 +2381,9 @@ the current line is to be regarded as part of a block comment."
Returns true if comment is found."
(let (state stop-in cpoint (lim (progn (end-of-line) (point))))
(beginning-of-line)
- (if (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t)
+ (if (or
+ (eq (get-text-property (point) 'syntax-type) 'pod)
+ (re-search-forward "\\=[ \t]*\\(#\\|$\\)" lim t))
(if (eq (preceding-char) ?\#) (progn (backward-char 1) t))
;; Else
(while (not stop-in)
@@ -1771,95 +2425,601 @@ Returns true if comment is found."
)
(nth 4 state))))
+(defsubst cperl-1- (p)
+ (max (point-min) (1- p)))
+
+(defsubst cperl-1+ (p)
+ (min (point-max) (1+ p)))
+
+(defvar cperl-st-cfence '(14)) ; Comment-fence
+(defvar cperl-st-sfence '(15)) ; String-fence
+(defvar cperl-st-punct '(1))
+(defvar cperl-st-word '(2))
+
+(defun cperl-protect-defun-start (s e)
+ ;; C code looks for "^\\s(" to skip comment backward in "hard" situations
+ (save-excursion
+ (goto-char s)
+ (while (re-search-forward "^\\s(" e 'to-end)
+ (put-text-property (1- (point)) (point) 'syntax-table cperl-st-punct))))
+
+(defun cperl-commentify (bb e string)
+ (if cperl-use-syntax-table-text-property
+ (progn
+ ;; We suppose that e is _after_ the end of construction, as after eol.
+ (setq string (if string cperl-st-sfence cperl-st-cfence))
+ (put-text-property bb (1+ bb) 'syntax-table string)
+ (put-text-property bb (1+ bb) 'rear-nonsticky t)
+ (put-text-property (1- e) e 'syntax-table string)
+ (put-text-property (1- e) e 'rear-nonsticky t)
+ (if (and (eq string cperl-st-sfence) (> (- e 2) bb))
+ (put-text-property (1+ bb) (1- e)
+ 'syntax-table cperl-string-syntax-table))
+ (cperl-protect-defun-start bb e))))
+
+(defun cperl-forward-re (is-2arg set-st st-l err-l argument
+ &optional ostart oend)
+ ;; Unfinished
+ ;; Works *before* syntax recognition is done
+ ;; May modify syntax-type text property if the situation is too hard
+ (let (b starter ender st i i2)
+ (skip-chars-forward " \t")
+ ;; ender means matching-char matcher.
+ (setq b (point)
+ starter (char-after b)
+ ;; ender:
+ ender (cdr (assoc starter '(( ?\( . ?\) )
+ ( ?\[ . ?\] )
+ ( ?\{ . ?\} )
+ ( ?\< . ?\> )
+ ))))
+ ;; What if starter == ?\\ ????
+ (if set-st
+ (if (car st-l)
+ (setq st (car st-l))
+ (setcar st-l (make-syntax-table))
+ (setq i 0 st (car st-l))
+ (while (< i 256)
+ (modify-syntax-entry i "." st)
+ (setq i (1+ i)))
+ (modify-syntax-entry ?\\ "\\" st)))
+ (setq set-st t)
+ ;; Whether we have an intermediate point
+ (setq i nil)
+ ;; Prepare the syntax table:
+ (and set-st
+ (if (not ender) ; m/blah/, s/x//, s/x/y/
+ (modify-syntax-entry starter "$" st)
+ (modify-syntax-entry starter (concat "(" (list ender)) st)
+ (modify-syntax-entry ender (concat ")" (list starter)) st)))
+ (condition-case bb
+ (progn
+ (if (and (eq starter (char-after (cperl-1+ b)))
+ (not ender))
+ ;; $ has TeXish matching rules, so $$ equiv $...
+ (forward-char 2)
+ (set-syntax-table st)
+ (forward-sexp 1)
+ (set-syntax-table cperl-mode-syntax-table)
+ ;; Now the problem is with m;blah;;
+ (and (not ender)
+ (eq (preceding-char)
+ (char-after (- (point) 2)))
+ (save-excursion
+ (forward-char -2)
+ (= 0 (% (skip-chars-backward "\\\\") 2)))
+ (forward-char -1)))
+ (and is-2arg ; Have trailing part
+ (not ender)
+ (eq (following-char) starter) ; Empty trailing part
+ (if (eq (char-syntax (following-char)) ?.)
+ (setq is-2arg nil) ; Ignore the tail
+ ;; Make trailing letter into punctuation
+ (setq is-2arg nil) ; Ignore the tail
+ (put-text-property (point) (1+ (point))
+ 'syntax-table cperl-st-punct)
+ (put-text-property (point) (1+ (point)) 'rear-nonsticky t)))
+ (if is-2arg ; Not number => have second part
+ (progn
+ (setq i (point) i2 i)
+ (if ender
+ (if (eq (char-syntax (following-char)) ?\ )
+ (progn
+ (while (looking-at "\\s *#")
+ (beginning-of-line 2))
+ (skip-chars-forward " \t\n\f")
+ (setq i2 (point))))
+ (forward-char -1))
+ (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)
+ (if ender (modify-syntax-entry ender "." st))
+ (setq set-st nil)
+ (setq
+ ender
+ (cperl-forward-re nil t st-l err-l argument starter ender)
+ ender (nth 2 ender)))))
+ (error (goto-char (point-max))
+ (message
+ "End of `%s%s%c ... %c' string not found: %s"
+ argument
+ (if ostart (format "%c ... %c" ostart (or oend ostart)) "")
+ starter (or ender starter) bb)
+ (or (car err-l) (setcar err-l b))))
+ (if set-st
+ (progn
+ (modify-syntax-entry starter (if (eq starter ?\\) "\\" ".") st)
+ (if ender (modify-syntax-entry ender "." st))))
+ (list i i2 ender starter)))
+
(defun cperl-find-pods-heres (&optional min max)
- "Scans the buffer for POD sections and here-documents.
+ "Scans the buffer for hard-to-parse Perl constructions.
If `cperl-pod-here-fontify' is not-nil after evaluation, will fontify
the sections using `cperl-pod-head-face', `cperl-pod-face',
`cperl-here-face'."
(interactive)
(or min (setq min (point-min)))
(or max (setq max (point-max)))
- (let (face head-face here-face b e bb tag err
+ (let (face head-face here-face b e bb tag qtag b1 e1 argument i c tail state
(cperl-pod-here-fontify (eval cperl-pod-here-fontify))
(case-fold-search nil) (inhibit-read-only t) (buffer-undo-list t)
- (modified (buffer-modified-p)))
+ (modified (buffer-modified-p))
+ (after-change-functions nil)
+ (state-point (point-min))
+ (st-l '(nil)) (err-l '(nil)) i2
+ ;; Somehow font-lock may be not loaded yet...
+ (font-lock-string-face (if (boundp 'font-lock-string-face)
+ font-lock-string-face
+ 'font-lock-string-face))
+ (search
+ (concat
+ "\\(\\`\n?\\|\n\n\\)="
+ "\\|"
+ ;; One extra () before this:
+ "<<"
+ "\\("
+ ;; First variant "BLAH" or just ``.
+ "\\([\"'`]\\)"
+ "\\([^\"'`\n]*\\)"
+ "\\3"
+ "\\|"
+ ;; Second variant: Identifier or empty
+ "\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)"
+ ;; Check that we do not have <<= or << 30 or << $blah.
+ "\\([^= \t$@%&]\\|[ \t]+[^ \t\n0-9$@%&]\\)"
+ "\\)"
+ "\\|"
+ ;; 1+6 extra () before this:
+ "^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"
+ (if cperl-use-syntax-table-text-property
+ (concat
+ "\\|"
+ ;; 1+6+2=9 extra () before this:
+ "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>"
+ "\\|"
+ ;; 1+6+2+1=10 extra () before this:
+ "\\([?/]\\)" ; /blah/ or ?blah?
+ "\\|"
+ ;; 1+6+2+1+1=11 extra () before this:
+ "\\<sub\\>[ \t]*\\([a-zA-Z_:'0-9]+[ \t]*\\)?\\(([^()]*)\\)"
+ "\\|"
+ ;; 1+6+2+1+1+2=13 extra () before this:
+ "\\$\\(['{]\\)"
+ "\\|"
+ ;; 1+6+2+1+1+2+1=14 extra () before this:
+ "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'"
+ ;; 1+6+2+1+1+2+1+1=15 extra () before this:
+ "\\|"
+ "__\\(END\\|DATA\\)__" ; Commented - does not help with indent...
+ )
+ ""))))
(unwind-protect
(progn
(save-excursion
- (message "Scanning for pods and here-docs...")
+ (message "Scanning for \"hard\" Perl constructions...")
(if cperl-pod-here-fontify
- (setq face (eval cperl-pod-face)
- head-face (eval cperl-pod-head-face)
- here-face (eval cperl-here-face)))
- (remove-text-properties min max '(syntax-type t))
+ ;; We had evals here, do not know why...
+ (setq face cperl-pod-face
+ head-face cperl-pod-head-face
+ here-face cperl-here-face))
+ (remove-text-properties min max
+ '(syntax-type t in-pod t syntax-table t))
;; Need to remove face as well...
(goto-char min)
- (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t)
- (if (looking-at "\n*cut\\>")
- (progn
- (message "=cut is not preceeded by a pod section")
- (setq err (point)))
- (beginning-of-line)
- (setq b (point) bb b)
- (or (re-search-forward "\n\n=cut\\>" max 'toend)
- (message "Cannot find the end of a pod section"))
- (beginning-of-line 4)
- (setq e (point))
- (put-text-property b e 'in-pod t)
- (goto-char b)
- (while (re-search-forward "\n\n[ \t]" e t)
+ (if (and (eq system-type 'emx)
+ (looking-at "extproc[ \t]")) ; Analogue of #!
+ (cperl-commentify min
+ (save-excursion (end-of-line) (point))
+ nil))
+ (while (re-search-forward search max t)
+ (cond
+ ((match-beginning 1) ; POD section
+ ;; "\\(\\`\n?\\|\n\n\\)="
+ (if (looking-at "\n*cut\\>")
+ (progn
+ (message "=cut is not preceded by a pod section")
+ (or (car err-l) (setcar err-l (point))))
(beginning-of-line)
- (put-text-property b (point) 'syntax-type 'pod)
- (put-text-property (max (point-min) (1- b))
- (point) cperl-do-not-fontify t)
- (if cperl-pod-here-fontify (put-text-property b (point) 'face face))
- (re-search-forward "\n\n[^ \t\f]" e 'toend)
- (beginning-of-line)
- (setq b (point)))
- (put-text-property (point) e 'syntax-type 'pod)
- (put-text-property (max (point-min) (1- (point)))
- e cperl-do-not-fontify t)
+
+ (setq b (point) bb b)
+ (or (re-search-forward "\n\n=cut\\>" max 'toend)
+ (progn
+ (message "Cannot find the end of a pod section")
+ (or (car err-l) (setcar err-l b))))
+ (beginning-of-line 2) ; An empty line after =cut is not POD!
+ (setq e (point))
+ (put-text-property b e 'in-pod t)
+ (goto-char b)
+ (while (re-search-forward "\n\n[ \t]" e t)
+ ;; We start 'pod 1 char earlier to include the preceding line
+ (beginning-of-line)
+ (put-text-property (cperl-1- b) (point) 'syntax-type 'pod)
+ (cperl-put-do-not-fontify b (point))
+ ;;(put-text-property (max (point-min) (1- b))
+ ;; (point) cperl-do-not-fontify t)
+ (if cperl-pod-here-fontify (put-text-property b (point) 'face face))
+ (re-search-forward "\n\n[^ \t\f\n]" e 'toend)
+ (beginning-of-line)
+ (setq b (point)))
+ (put-text-property (cperl-1- (point)) e 'syntax-type 'pod)
+ (cperl-put-do-not-fontify (point) e)
+ ;;(put-text-property (max (point-min) (1- (point)))
+ ;; e cperl-do-not-fontify t)
+ (if cperl-pod-here-fontify
+ (progn (put-text-property (point) e 'face face)
+ (goto-char bb)
+ (if (looking-at
+ "=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$")
+ (put-text-property
+ (match-beginning 1) (match-end 1)
+ 'face head-face))
+ (while (re-search-forward
+ ;; One paragraph
+ "\n\n=[a-zA-Z0-9_]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"
+ e 'toend)
+ (put-text-property
+ (match-beginning 1) (match-end 1)
+ 'face head-face))))
+ (cperl-commentify bb e nil)
+ (goto-char e)
+ (or (eq e (point-max))
+ (forward-char -1)))) ; Prepare for immediate pod start.
+ ;; Here document
+ ;; We do only one here-per-line
+ ;; 1 () ahead
+ ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)"
+ ((match-beginning 2) ; 1 + 1
+ ;; Abort in comment:
+ (setq b (point))
+ (setq state (parse-partial-sexp state-point b nil nil state)
+ state-point b)
+ (if ;;(save-excursion
+ ;; (beginning-of-line)
+ ;; (search-forward "#" b t))
+ (or (nth 3 state) (nth 4 state))
+ (goto-char (match-end 2))
+ (if (match-beginning 5) ;4 + 1
+ (setq b1 (match-beginning 5) ; 4 + 1
+ e1 (match-end 5)) ; 4 + 1
+ (setq b1 (match-beginning 4) ; 3 + 1
+ e1 (match-end 4))) ; 3 + 1
+ (setq tag (buffer-substring b1 e1)
+ qtag (regexp-quote tag))
+ (cond (cperl-pod-here-fontify
+ (put-text-property b1 e1 'face font-lock-reference-face)
+ (cperl-put-do-not-fontify b1 e1)))
+ (forward-line)
+ (setq b (point))
+ (cond ((re-search-forward (concat "^" qtag "$") max 'toend)
+ (if cperl-pod-here-fontify
+ (progn
+ (put-text-property (match-beginning 0) (match-end 0)
+ 'face font-lock-reference-face)
+ (cperl-put-do-not-fontify b (match-end 0))
+ ;;(put-text-property (max (point-min) (1- b))
+ ;; (min (point-max)
+ ;; (1+ (match-end 0)))
+ ;; cperl-do-not-fontify t)
+ (put-text-property b (match-beginning 0)
+ 'face here-face)))
+ (setq e1 (cperl-1+ (match-end 0)))
+ (put-text-property b (match-beginning 0)
+ 'syntax-type 'here-doc)
+ (put-text-property (match-beginning 0) e1
+ 'syntax-type 'here-doc-delim)
+ (put-text-property b e1
+ 'here-doc-group t)
+ (cperl-commentify b e1 nil)
+ (cperl-put-do-not-fontify b (match-end 0)))
+ (t (message "End of here-document `%s' not found." tag)
+ (or (car err-l) (setcar err-l b))))))
+ ;; format
+ ((match-beginning 8)
+ ;; 1+6=7 extra () before this:
+ ;;"^[ \t]*\\(format\\)[ \t]*\\([a-zA-Z0-9_]+\\)?[ \t]*=[ \t]*$"
+ (setq b (point)
+ name (if (match-beginning 8) ; 7 + 1
+ (buffer-substring (match-beginning 8) ; 7 + 1
+ (match-end 8)) ; 7 + 1
+ ""))
+ (setq argument nil)
(if cperl-pod-here-fontify
- (progn (put-text-property (point) e 'face face)
- (goto-char bb)
- (while (re-search-forward
- ;; One paragraph
- "\n\n=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"
- e 'toend)
- (put-text-property
- (match-beginning 1) (match-end 1)
- 'face head-face))))
- (goto-char e)))
- (goto-char min)
- (while (re-search-forward
- "<<\\(\\([\"'`]\\)?\\)\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\1"
- max t)
- (setq tag (buffer-substring (match-beginning 3)
- (match-end 3)))
- (if cperl-pod-here-fontify
- (put-text-property (match-beginning 3) (match-end 3)
- 'face font-lock-reference-face))
- (forward-line)
- (setq b (point))
- (and (re-search-forward (concat "^" tag "$") max 'toend)
- (progn
- (if cperl-pod-here-fontify
- (progn
- (put-text-property (match-beginning 0) (match-end 0)
- 'face font-lock-reference-face)
- (put-text-property (max (point-min) (1- b))
- (min (point-mox)
- (1+ (match-end 0)))
- cperl-do-not-fontify t)
- (put-text-property b (match-beginning 0)
- 'face here-face)))
- (put-text-property b (match-beginning 0)
- 'syntax-type 'here-doc)))))
- (if err (goto-char err)
- (message "Scan for pods and here-docs completed.")))
+ (while (and (eq (forward-line) 0)
+ (not (looking-at "^[.;]$")))
+ (cond
+ ((looking-at "^#")) ; Skip comments
+ ((and argument ; Skip argument multi-lines
+ (looking-at "^[ \t]*{"))
+ (forward-sexp 1)
+ (setq argument nil))
+ (argument ; Skip argument lines
+ (setq argument nil))
+ (t ; Format line
+ (setq b1 (point))
+ (setq argument (looking-at "^[^\n]*[@^]"))
+ (end-of-line)
+ (put-text-property b1 (point)
+ 'face font-lock-string-face)
+ (cperl-commentify b1 (point) nil)
+ (cperl-put-do-not-fontify b1 (point)))))
+ (re-search-forward (concat "^[.;]$") max 'toend))
+ (beginning-of-line)
+ (if (looking-at "^[.;]$")
+ (progn
+ (put-text-property (point) (+ (point) 2)
+ 'face font-lock-string-face)
+ (cperl-commentify (point) (+ (point) 2) nil)
+ (cperl-put-do-not-fontify (point) (+ (point) 2)))
+ (message "End of format `%s' not found." name)
+ (or (car err-l) (setcar err-l b)))
+ (forward-line)
+ (put-text-property b (point) 'syntax-type 'format)
+;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend)
+;;; (if cperl-pod-here-fontify
+;;; (progn
+;;; (put-text-property b (match-end 0)
+;;; 'face font-lock-string-face)
+;;; (cperl-put-do-not-fontify b (match-end 0))))
+;;; (put-text-property b (match-end 0)
+;;; 'syntax-type 'format)
+;;; (cperl-put-do-not-fontify b (match-beginning 0)))
+;;; (t (message "End of format `%s' not found." name)))
+ )
+ ;; Regexp:
+ ((or (match-beginning 10) (match-beginning 11))
+ ;; 1+6+2=9 extra () before this:
+ ;; "\\<\\(q[wxq]?\\|[msy]\\|tr\\)\\>"
+ ;; "\\|"
+ ;; "\\([?/]\\)" ; /blah/ or ?blah?
+ (setq b1 (if (match-beginning 10) 10 11)
+ argument (buffer-substring
+ (match-beginning b1) (match-end b1))
+ b (point)
+ i b
+ c (char-after (match-beginning b1))
+ bb (char-after (1- (match-beginning b1))) ; tmp holder
+ bb (and ; user variables/whatever
+ (match-beginning 10)
+ (or
+ (memq bb '(?\$ ?\@ ?\% ?\*))
+ (and (eq bb ?-) (eq c ?s)) ; -s file test
+ (and (eq bb ?\&) ; &&m/blah/
+ (not (eq (char-after
+ (- (match-beginning b1) 2))
+ ?\&))))))
+ (or bb
+ (if (eq b1 11) ; bare /blah/ or ?blah?
+ (setq argument ""
+ bb ; Not a regexp?
+ (progn
+ (goto-char (match-beginning b1))
+ (cperl-backward-to-noncomment (point-min))
+ (not (or (memq (preceding-char)
+ (append (if (eq c ?\?)
+ ;; $a++ ? 1 : 2
+ "~{(=|&*!,;"
+ "~{(=|&+-*!,;") nil))
+ (and (eq (preceding-char) ?\})
+ (cperl-after-block-p (point-min)))
+ (and (eq (char-syntax (preceding-char)) ?w)
+ (progn
+ (forward-sexp -1)
+ (looking-at
+ "\\(while\\|if\\|unless\\|until\\|and\\|or\\|not\\|xor\\|split\\|grep\\|map\\|print\\)\\>")))
+ (and (eq (preceding-char) ?.)
+ (eq (char-after (- (point) 2)) ?.))
+ (bobp))))
+ b (1- b))))
+ (or bb (setq state (parse-partial-sexp
+ state-point b nil nil state)
+ state-point b))
+ (goto-char b)
+ (if (or bb (nth 3 state) (nth 4 state))
+ (goto-char i)
+ (skip-chars-forward " \t")
+ ;; qtag means two-arg matcher, may be reset to
+ ;; 2 or 3 later if some special quoting is needed.
+ ;; e1 means matching-char matcher.
+ (setq b (point)
+ i (cperl-forward-re
+ (string-match "^\\([sy]\\|tr\\)$" argument)
+ t st-l err-l argument)
+ i2 (nth 1 i) ; start of the second part
+ e1 (nth 2 i) ; ender, true if matching second part
+ i (car i) ; intermediate point
+ tail (if (and i (not e1)) (1- (point))))
+ ;; Commenting \\ is dangerous, what about ( ?
+ (and i tail
+ (eq (char-after i) ?\\)
+ (setq i nil tail nil))
+ (if (null i)
+ (cperl-commentify b (point) t)
+ (cperl-commentify b i t)
+ (if (looking-at "\\sw*e") ; s///e
+ (cperl-find-pods-heres i2 (1- (point)))
+ (cperl-commentify i2 (point) t)
+ (setq tail nil)))
+ (if (eq (char-syntax (following-char)) ?w)
+ (progn
+ (forward-word 1) ; skip modifiers s///s
+ (if tail (cperl-commentify tail (point) t))))))
+ ((match-beginning 13) ; sub with prototypes
+ (setq b (match-beginning 0))
+ (if (memq (char-after (1- b))
+ '(?\$ ?\@ ?\% ?\& ?\*))
+ nil
+ (setq state (parse-partial-sexp
+ state-point (1- b) nil nil state)
+ state-point (1- b))
+ (if (or (nth 3 state) (nth 4 state))
+ nil
+ ;; Mark as string
+ (cperl-commentify (match-beginning 13) (match-end 13) t))
+ (goto-char (match-end 0))))
+ ;; 1+6+2+1+1+2=13 extra () before this:
+ ;; "\\$\\(['{]\\)"
+ ((and (match-beginning 14)
+ (eq (preceding-char) ?\')) ; $'
+ (setq b (1- (point))
+ state (parse-partial-sexp
+ state-point (1- b) nil nil state)
+ state-point (1- b))
+ (if (nth 3 state) ; in string
+ (progn
+ (put-text-property (1- b) b 'syntax-table cperl-st-punct)
+ (put-text-property (1- b) b 'rear-nonsticky t)))
+ (goto-char (1+ b)))
+ ;; 1+6+2+1+1+2=13 extra () before this:
+ ;; "\\$\\(['{]\\)"
+ ((match-beginning 14) ; ${
+ (setq bb (match-beginning 0))
+ (put-text-property bb (1+ bb) 'syntax-table cperl-st-punct)
+ (put-text-property bb (1+ bb) 'rear-nonsticky t))
+ ;; 1+6+2+1+1+2+1=14 extra () before this:
+ ;; "\\(\\<sub[ \t\n\f]+\\|[&*$@%]\\)[a-zA-Z0-9_]*'")
+ ((match-beginning 15) ; old $abc'efg syntax
+ (setq bb (match-end 0)
+ b (match-beginning 0)
+ state (parse-partial-sexp
+ state-point b nil nil state)
+ state-point b)
+ (if (nth 3 state) ; in string
+ nil
+ (put-text-property (1- bb) bb 'syntax-table cperl-st-word))
+ (goto-char bb))
+ ;; 1+6+2+1+1+2+1+1=15 extra () before this:
+ ;; "__\\(END\\|DATA\\)__"
+ (t ; __END__, __DATA__
+ (setq bb (match-end 0)
+ b (match-beginning 0)
+ state (parse-partial-sexp
+ state-point b nil nil state)
+ state-point b)
+ (if (or (nth 3 state) (nth 4 state))
+ nil
+ ;; (put-text-property b (1+ bb) 'syntax-type 'pod) ; Cheat
+ (cperl-commentify b bb nil)
+ )
+ (goto-char bb))))
+;;; (while (re-search-forward "\\(\\`\n?\\|\n\n\\)=" max t)
+;;; (if (looking-at "\n*cut\\>")
+;;; (progn
+;;; (message "=cut is not preceded by a pod section")
+;;; (setq err (point)))
+;;; (beginning-of-line)
+
+;;; (setq b (point) bb b)
+;;; (or (re-search-forward "\n\n=cut\\>" max 'toend)
+;;; (message "Cannot find the end of a pod section"))
+;;; (beginning-of-line 3)
+;;; (setq e (point))
+;;; (put-text-property b e 'in-pod t)
+;;; (goto-char b)
+;;; (while (re-search-forward "\n\n[ \t]" e t)
+;;; (beginning-of-line)
+;;; (put-text-property b (point) 'syntax-type 'pod)
+;;; (cperl-put-do-not-fontify b (point))
+;;; ;;(put-text-property (max (point-min) (1- b))
+;;; ;; (point) cperl-do-not-fontify t)
+;;; (if cperl-pod-here-fontify (put-text-property b (point) 'face face))
+;;; (re-search-forward "\n\n[^ \t\f\n]" e 'toend)
+;;; (beginning-of-line)
+;;; (setq b (point)))
+;;; (put-text-property (point) e 'syntax-type 'pod)
+;;; (cperl-put-do-not-fontify (point) e)
+;;; ;;(put-text-property (max (point-min) (1- (point)))
+;;; ;; e cperl-do-not-fontify t)
+;;; (if cperl-pod-here-fontify
+;;; (progn (put-text-property (point) e 'face face)
+;;; (goto-char bb)
+;;; (if (looking-at
+;;; "=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$")
+;;; (put-text-property
+;;; (match-beginning 1) (match-end 1)
+;;; 'face head-face))
+;;; (while (re-search-forward
+;;; ;; One paragraph
+;;; "\n\n=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"
+;;; e 'toend)
+;;; (put-text-property
+;;; (match-beginning 1) (match-end 1)
+;;; 'face head-face))))
+;;; (goto-char e)))
+;;; (goto-char min)
+;;; (while (re-search-forward
+;;; ;; We exclude \n to avoid misrecognition inside quotes.
+;;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\2\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)"
+;;; max t)
+;;; (if (match-beginning 4)
+;;; (setq b1 (match-beginning 4)
+;;; e1 (match-end 4))
+;;; (setq b1 (match-beginning 3)
+;;; e1 (match-end 3)))
+;;; (setq tag (buffer-substring b1 e1)
+;;; qtag (regexp-quote tag))
+;;; (cond (cperl-pod-here-fontify
+;;; (put-text-property b1 e1 'face font-lock-reference-face)
+;;; (cperl-put-do-not-fontify b1 e1)))
+;;; (forward-line)
+;;; (setq b (point))
+;;; (cond ((re-search-forward (concat "^" qtag "$") max 'toend)
+;;; (if cperl-pod-here-fontify
+;;; (progn
+;;; (put-text-property (match-beginning 0) (match-end 0)
+;;; 'face font-lock-reference-face)
+;;; (cperl-put-do-not-fontify b (match-end 0))
+;;; ;;(put-text-property (max (point-min) (1- b))
+;;; ;; (min (point-max)
+;;; ;; (1+ (match-end 0)))
+;;; ;; cperl-do-not-fontify t)
+;;; (put-text-property b (match-beginning 0)
+;;; 'face here-face)))
+;;; (put-text-property b (match-beginning 0)
+;;; 'syntax-type 'here-doc)
+;;; (cperl-put-do-not-fontify b (match-beginning 0)))
+;;; (t (message "End of here-document `%s' not found." tag))))
+;;; (goto-char min)
+;;; (while (re-search-forward
+;;; "^[ \t]*format[ \t]*\\(\\([a-zA-Z0-9_]+[ \t]*\\)?\\)=[ \t]*$"
+;;; max t)
+;;; (setq b (point)
+;;; name (buffer-substring (match-beginning 1)
+;;; (match-end 1)))
+;;; (cond ((re-search-forward (concat "^[.;]$") max 'toend)
+;;; (if cperl-pod-here-fontify
+;;; (progn
+;;; (put-text-property b (match-end 0)
+;;; 'face font-lock-string-face)
+;;; (cperl-put-do-not-fontify b (match-end 0))))
+;;; (put-text-property b (match-end 0)
+;;; 'syntax-type 'format)
+;;; (cperl-put-do-not-fontify b (match-beginning 0)))
+;;; (t (message "End of format `%s' not found." name))))
+)
+ (if (car err-l) (goto-char (car err-l))
+ (message "Scan for \"hard\" Perl constructions completed.")))
(and (buffer-modified-p)
(not modified)
- (set-buffer-modified-p nil)))))
+ (set-buffer-modified-p nil))
+ (set-syntax-table cperl-mode-syntax-table))))
(defun cperl-backward-to-noncomment (lim)
;; Stops at lim or after non-whitespace that is not in comment
@@ -1868,20 +3028,38 @@ the sections using `cperl-pod-head-face', `cperl-pod-face',
(skip-chars-backward " \t\n\f" lim)
(setq p (point))
(beginning-of-line)
- (if (looking-at "^[ \t]*\\(#\\|$\\)") nil ; Only comment, skip
+ (if (or (looking-at "^[ \t]*\\(#\\|$\\)")
+ (progn (cperl-to-comment-or-eol) (bolp)))
+ nil ; Only comment, skip
;; Else
- (cperl-to-comment-or-eol)
(skip-chars-backward " \t")
(if (< p (point)) (goto-char p))
(setq stop t)))))
+(defun cperl-after-block-p (lim)
+ ;; We suppose that the preceding char is }.
+ (save-excursion
+ (condition-case nil
+ (progn
+ (forward-sexp -1)
+ (cperl-backward-to-noncomment lim)
+ (or (eq (preceding-char) ?\) ) ; if () {}
+ (and (eq (char-syntax (preceding-char)) ?w) ; else {}
+ (progn
+ (forward-sexp -1)
+ (looking-at "\\(else\\|grep\\|map\\)\\>")))
+ (cperl-after-expr-p lim)))
+ (error nil))))
+
(defun cperl-after-expr-p (&optional lim chars test)
"Returns true if the position is good for start of expression.
TEST is the expression to evaluate at the found position. If absent,
-CHARS is a string that contains good characters to have before us."
- (let (stop p)
+CHARS is a string that contains good characters to have before us (however,
+`}' is treated \"smartly\" if it is not in the list)."
+ (let (stop p
+ (lim (or lim (point-min))))
(save-excursion
- (while (and (not stop) (> (point) (or lim 1)))
+ (while (and (not stop) (> (point) lim))
(skip-chars-backward " \t\n\f" lim)
(setq p (point))
(beginning-of-line)
@@ -1893,9 +3071,10 @@ CHARS is a string that contains good characters to have before us."
(setq stop t)))
(or (bobp)
(progn
- (backward-char 1)
(if test (eval test)
- (memq (following-char) (append (or chars "{};") nil))))))))
+ (or (memq (preceding-char) (append (or chars "{;") nil))
+ (and (eq (preceding-char) ?\})
+ (cperl-after-block-p lim)))))))))
(defun cperl-backward-to-start-of-continued-exp (lim)
(if (memq (preceding-char) (append ")]}\"'`" nil))
@@ -1917,8 +3096,8 @@ or looks like continuation of the comment on the previous line."
(save-excursion
(let ((tmp-end (progn (end-of-line) (point))) top done)
(save-excursion
+ (beginning-of-line)
(while (null done)
- (beginning-of-line)
(setq top (point))
(while (= (nth 0 (parse-partial-sexp (point) tmp-end
-1)) -1)
@@ -1963,7 +3142,8 @@ inclusive."
comment-column))
(setq old-comm-indent nil)))
(if (and old-comm-indent
- (= (current-indentation) old-comm-indent))
+ (= (current-indentation) old-comm-indent)
+ (not (eq (get-text-property (point) 'syntax-type) 'pod)))
(let ((comment-column new-comm-indent))
(indent-for-comment)))
(progn
@@ -1971,6 +3151,7 @@ inclusive."
(or comm
(progn
(if (setq old-comm-indent (and (cperl-to-comment-or-eol)
+ (not (eq (get-text-property (point) 'syntax-type) 'pod))
(current-column)))
(progn (indent-for-comment)
(skip-chars-backward " \t")
@@ -1981,16 +3162,16 @@ inclusive."
(imenu-progress-message pm 100)
(message nil)))))
-(defun cperl-slash-is-regexp (&optional pos)
- (save-excursion
- (goto-char (if pos pos (1- (point))))
- (and
- (not (memq (get-text-property (point) 'face)
- '(font-lock-string-face font-lock-comment-face)))
- (cperl-after-expr-p nil nil '
- (or (looking-at "[^]a-zA-Z0-9_)}]")
- (eq (get-text-property (point) 'face)
- 'font-lock-keyword-face))))))
+;;(defun cperl-slash-is-regexp (&optional pos)
+;; (save-excursion
+;; (goto-char (if pos pos (1- (point))))
+;; (and
+;; (not (memq (get-text-property (point) 'face)
+;; '(font-lock-string-face font-lock-comment-face)))
+;; (cperl-after-expr-p nil nil '
+;; (or (looking-at "[^]a-zA-Z0-9_)}]")
+;; (eq (get-text-property (point) 'face)
+;; 'font-lock-keyword-face))))))
;; Stolen from lisp-mode with a lot of improvements
@@ -2102,64 +3283,113 @@ indentation and initial hashes. Behaves usually outside of comment."
(or (memq (preceding-char) '(?\ ?\t)) (insert " "))))))
(defvar imenu-example--function-name-regexp-perl
- "^\\([ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\|=head\\([12]\\)[ \t]+\\([^\n]+\\)$\\)")
+ (concat
+ "^\\("
+ "[ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\(([^()]*)[ \t]*\\)?"
+ "\\|"
+ "=head\\([12]\\)[ \t]+\\([^\n]+\\)$"
+ "\\)"))
+
+(defun cperl-imenu-addback (lst &optional isback name)
+ ;; We suppose that the lst is a DAG, unless the first element only
+ ;; loops back, and ISBACK is set. Thus this function cannot be
+ ;; applied twice without ISBACK set.
+ (cond ((not cperl-imenu-addback) lst)
+ (t
+ (or name
+ (setq name "+++BACK+++"))
+ (mapcar (function (lambda (elt)
+ (if (and (listp elt) (listp (cdr elt)))
+ (progn
+ ;; In the other order it goes up
+ ;; one level only ;-(
+ (setcdr elt (cons (cons name lst)
+ (cdr elt)))
+ (cperl-imenu-addback (cdr elt) t name)
+ ))))
+ (if isback (cdr lst) lst))
+ lst)))
(defun imenu-example--create-perl-index (&optional regexp)
(require 'cl)
+ (require 'imenu) ; May be called from TAGS creator
(let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '())
(index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function))
+ (index-meth-alist '()) meth
packages ends-ranges p
(prev-pos 0) char fchar index index1 name (end-range 0) package)
(goto-char (point-min))
(imenu-progress-message prev-pos 0)
;; Search for the function
- (save-match-data
+ (progn ;;save-match-data
(while (re-search-forward
(or regexp imenu-example--function-name-regexp-perl)
nil t)
(imenu-progress-message prev-pos)
;;(backward-up-list 1)
(cond
- ((match-beginning 2) ; package or sub
+ ((and ; Skip some noise if building tags
+ (match-beginning 2) ; package or sub
+ (eq (char-after (match-beginning 2)) ?p) ; package
+ (not (save-match-data
+ (looking-at "[ \t\n]*;")))) ; Plain text word 'package'
+ nil)
+ ((and
+ (match-beginning 2) ; package or sub
+ ;; Skip if quoted (will not skip multi-line ''-comments :-():
+ (null (get-text-property (match-beginning 1) 'syntax-table))
+ (null (get-text-property (match-beginning 1) 'syntax-type))
+ (null (get-text-property (match-beginning 1) 'in-pod)))
(save-excursion
(goto-char (match-beginning 2))
(setq fchar (following-char))
)
- (setq char (following-char))
- (setq p (point))
+ ;; (if (looking-at "([^()]*)[ \t\n\f]*")
+ ;; (goto-char (match-end 0))) ; Messes what follows
+ (setq char (following-char)
+ meth nil
+ p (point))
(while (and ends-ranges (>= p (car ends-ranges)))
;; delete obsolete entries
(setq ends-ranges (cdr ends-ranges) packages (cdr packages)))
(setq package (or (car packages) "")
end-range (or (car ends-ranges) 0))
(if (eq fchar ?p)
- (progn
- (setq name (buffer-substring (match-beginning 3) (match-end 3))
- package (concat name "::")
- name (concat "package " name)
- end-range
- (save-excursion
- (parse-partial-sexp (point) (point-max) -1) (point))
- ends-ranges (cons end-range ends-ranges)
- packages (cons package packages))))
+ (setq name (buffer-substring (match-beginning 3) (match-end 3))
+ name (progn
+ (set-text-properties 0 (length name) nil name)
+ name)
+ package (concat name "::")
+ name (concat "package " name)
+ end-range
+ (save-excursion
+ (parse-partial-sexp (point) (point-max) -1) (point))
+ ends-ranges (cons end-range ends-ranges)
+ packages (cons package packages)))
;; )
;; Skip this function name if it is a prototype declaration.
(if (and (eq fchar ?s) (eq char ?\;)) nil
+ (setq index (imenu-example--name-and-position))
(if (eq fchar ?p) nil
(setq name (buffer-substring (match-beginning 3) (match-end 3)))
- (if (or (> p end-range) (string-match "[:']" name)) nil
- (setq name (concat package name))))
- (setq index (imenu-example--name-and-position))
+ (set-text-properties 0 (length name) nil name)
+ (cond ((string-match "[:']" name)
+ (setq meth t))
+ ((> p end-range) nil)
+ (t
+ (setq name (concat package name) meth t))))
(setcar index name)
(if (eq fchar ?p)
(push index index-pack-alist)
(push index index-alist))
+ (if meth (push index index-meth-alist))
(push index index-unsorted-alist)))
- (t ; Pod section
+ ((match-beginning 5) ; Pod section
;; (beginning-of-line)
(setq index (imenu-example--name-and-position)
- name (buffer-substring (match-beginning 5) (match-end 5)))
- (if (eq (char-after (match-beginning 4)) ?2)
+ name (buffer-substring (match-beginning 6) (match-end 6)))
+ (set-text-properties 0 (length name) nil name)
+ (if (eq (char-after (match-beginning 5)) ?2)
(setq name (concat " " name)))
(setcar index name)
(setq index1 (cons (concat "=" name) (cdr index)))
@@ -2171,20 +3401,55 @@ indentation and initial hashes. Behaves usually outside of comment."
(sort index-alist (default-value 'imenu-sort-function))
(nreverse index-alist)))
(and index-pod-alist
- (push (cons (imenu-create-submenu-name "+POD headers+")
+ (push (cons "+POD headers+..."
(nreverse index-pod-alist))
index-alist))
+ (and (or index-pack-alist index-meth-alist)
+ (let ((lst index-pack-alist) hier-list pack elt group name)
+ ;; Remove "package ", reverse and uniquify.
+ (while lst
+ (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8))
+ (if (assoc name hier-list) nil
+ (setq hier-list (cons (cons name (cdr elt)) hier-list))))
+ (setq lst index-meth-alist)
+ (while lst
+ (setq elt (car lst) lst (cdr lst))
+ (cond ((string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt))
+ (setq pack (substring (car elt) 0 (match-beginning 0)))
+ (if (setq group (assoc pack hier-list))
+ (if (listp (cdr group))
+ ;; Have some functions already
+ (setcdr group
+ (cons (cons (substring
+ (car elt)
+ (+ 2 (match-beginning 0)))
+ (cdr elt))
+ (cdr group)))
+ (setcdr group (list (cons (substring
+ (car elt)
+ (+ 2 (match-beginning 0)))
+ (cdr elt)))))
+ (setq hier-list
+ (cons (cons pack
+ (list (cons (substring
+ (car elt)
+ (+ 2 (match-beginning 0)))
+ (cdr elt))))
+ hier-list))))))
+ (push (cons "+Hierarchy+..."
+ hier-list)
+ index-alist)))
(and index-pack-alist
- (push (cons (imenu-create-submenu-name "+Packages+")
+ (push (cons "+Packages+..."
(nreverse index-pack-alist))
index-alist))
(and (or index-pack-alist index-pod-alist
(default-value 'imenu-sort-function))
index-unsorted-alist
- (push (cons (imenu-create-submenu-name "+Unsorted List+")
+ (push (cons "+Unsorted List+..."
(nreverse index-unsorted-alist))
index-alist))
- index-alist))
+ (cperl-imenu-addback index-alist)))
(defvar cperl-compilation-error-regexp-alist
;; This look like a paranoiac regexp: could anybody find a better one? (which WORK).
@@ -2246,36 +3511,43 @@ indentation and initial hashes. Behaves usually outside of comment."
"\\|") ; Flow control
"\\)\\>") 2) ; was "\\)[ \n\t;():,\|&]"
; In what follows we use `type' style
- ; for overwritable buildins
+ ; for overwritable builtins
(list
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
- ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm" "and" "atan2"
- ;; "bind" "binmode" "bless" "caller" "chdir" "chmod" "chown" "chr"
- ;; "chroot" "close" "closedir" "cmp" "connect" "continue" "cos"
- ;; "crypt" "dbmclose" "dbmopen" "die" "dump" "endgrent" "endhostent"
- ;; "endnetent" "endprotoent" "endpwent" "endservent" "eof" "eq" "exec"
- ;; "exit" "exp" "fcntl" "fileno" "flock" "fork" "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" "gt" "hex" "index" "int" "ioctl"
- ;; "join" "kill" "lc" "lcfirst" "le" "length" "link" "listen"
- ;; "localtime" "log" "lstat" "lt" "mkdir" "msgctl" "msgget" "msgrcv"
- ;; "msgsnd" "ne" "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe"
- ;; "quotemeta" "rand" "read" "readdir" "readline" "readlink"
- ;; "readpipe" "recv" "ref" "rename" "require" "reset" "reverse"
- ;; "rewinddir" "rindex" "rmdir" "seek" "seekdir" "select" "semctl"
- ;; "semget" "semop" "send" "setgrent" "sethostent" "setnetent"
- ;; "setpgrp" "setpriority" "setprotoent" "setpwent" "setservent"
- ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite" "shutdown"
- ;; "sin" "sleep" "socket" "socketpair" "sprintf" "sqrt" "srand" "stat"
- ;; "substr" "symlink" "syscall" "sysread" "system" "syswrite" "tell"
- ;; "telldir" "time" "times" "truncate" "uc" "ucfirst" "umask" "unlink"
- ;; "unpack" "utime" "values" "vec" "wait" "waitpid" "wantarray" "warn"
- ;; "write" "x" "xor"
+ ;; "CORE" "__FILE__" "__LINE__" "abs" "accept" "alarm"
+ ;; "and" "atan2" "bind" "binmode" "bless" "caller"
+ ;; "chdir" "chmod" "chown" "chr" "chroot" "close"
+ ;; "closedir" "cmp" "connect" "continue" "cos" "crypt"
+ ;; "dbmclose" "dbmopen" "die" "dump" "endgrent"
+ ;; "endhostent" "endnetent" "endprotoent" "endpwent"
+ ;; "endservent" "eof" "eq" "exec" "exit" "exp" "fcntl"
+ ;; "fileno" "flock" "fork" "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" "gt" "hex" "index" "int"
+ ;; "ioctl" "join" "kill" "lc" "lcfirst" "le" "length"
+ ;; "link" "listen" "localtime" "log" "lstat" "lt"
+ ;; "mkdir" "msgctl" "msgget" "msgrcv" "msgsnd" "ne"
+ ;; "not" "oct" "open" "opendir" "or" "ord" "pack" "pipe"
+ ;; "quotemeta" "rand" "read" "readdir" "readline"
+ ;; "readlink" "readpipe" "recv" "ref" "rename" "require"
+ ;; "reset" "reverse" "rewinddir" "rindex" "rmdir" "seek"
+ ;; "seekdir" "select" "semctl" "semget" "semop" "send"
+ ;; "setgrent" "sethostent" "setnetent" "setpgrp"
+ ;; "setpriority" "setprotoent" "setpwent" "setservent"
+ ;; "setsockopt" "shmctl" "shmget" "shmread" "shmwrite"
+ ;; "shutdown" "sin" "sleep" "socket" "socketpair"
+ ;; "sprintf" "sqrt" "srand" "stat" "substr" "symlink"
+ ;; "syscall" "sysread" "system" "syswrite" "tell"
+ ;; "telldir" "time" "times" "truncate" "uc" "ucfirst"
+ ;; "umask" "unlink" "unpack" "utime" "values" "vec"
+ ;; "wait" "waitpid" "wantarray" "warn" "write" "x" "xor"
"a\\(bs\\|ccept\\|tan2\\|larm\\|nd\\)\\|"
"b\\(in\\(d\\|mode\\)\\|less\\)\\|"
"c\\(h\\(r\\(\\|oot\\)\\|dir\\|mod\\|own\\)\\|aller\\|rypt\\|"
@@ -2306,21 +3578,23 @@ indentation and initial hashes. Behaves usually outside of comment."
"ell\\(\\|dir\\)\\|ime\\(\\|s\\)\\)\\|u\\(c\\(\\|first\\)\\|"
"time\\|mask\\|n\\(pack\\|link\\)\\)\\|v\\(alues\\|ec\\)\\|"
"w\\(a\\(rn\\|it\\(pid\\|\\)\\|ntarray\\)\\|rite\\)\\|"
- "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\)"
+ "x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\|PACKAGE__\\)"
"\\)\\>") 2 'font-lock-type-face)
;; In what follows we use `other' style
- ;; for nonoverwritable buildins
- ;; Somehow 's', 'm' are not autogenerated???
+ ;; for nonoverwritable builtins
+ ;; Somehow 's', 'm' are not auto-generated???
(list
(concat
"\\(^\\|[^$@%&\\]\\)\\<\\("
- ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp" "chop"
- ;; "defined" "delete" "do" "each" "else" "elsif" "eval" "exists" "for"
- ;; "foreach" "format" "goto" "grep" "if" "keys" "last" "local" "map"
- ;; "my" "next" "no" "package" "pop" "pos" "print" "printf" "push" "q"
- ;; "qq" "qw" "qx" "redo" "return" "scalar" "shift" "sort" "splice"
- ;; "split" "study" "sub" "tie" "tr" "undef" "unless" "unshift" "untie"
- ;; "until" "use" "while" "y"
+ ;; "AUTOLOAD" "BEGIN" "DESTROY" "END" "__END__" "chomp"
+ ;; "chop" "defined" "delete" "do" "each" "else" "elsif"
+ ;; "eval" "exists" "for" "foreach" "format" "goto"
+ ;; "grep" "if" "keys" "last" "local" "map" "my" "next"
+ ;; "no" "package" "pop" "pos" "print" "printf" "push"
+ ;; "q" "qq" "qw" "qx" "redo" "return" "scalar" "shift"
+ ;; "sort" "splice" "split" "study" "sub" "tie" "tr"
+ ;; "undef" "unless" "unshift" "untie" "until" "use"
+ ;; "while" "y"
"AUTOLOAD\\|BEGIN\\|cho\\(p\\|mp\\)\\|d\\(e\\(fined\\|lete\\)\\|"
"o\\)\\|DESTROY\\|e\\(ach\\|val\\|xists\\|ls\\(e\\|if\\)\\)\\|"
"END\\|for\\(\\|each\\|mat\\)\\|g\\(rep\\|oto\\)\\|if\\|keys\\|"
@@ -2337,11 +3611,13 @@ indentation and initial hashes. Behaves usually outside of comment."
;; "#include" "#define" "#undef")
;; "\\|")
'("-[rwxoRWXOezsfdlpSbctugkTBMAC]\\>\\([ \t]+_\\>\\)?" 0
- font-lock-function-name-face) ; Not very good, triggers at "[a-z]"
- '("\\<sub[ \t]+\\([^ \t{;]+\\)[ \t]*[{\n]" 1
+ font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"
+ '("\\<sub[ \t]+\\([^ \t{;]+\\)[ \t]*\\(([^()]*)[ \t]*\\)?[#{\n]" 1
font-lock-function-name-face)
'("\\<\\(package\\|require\\|use\\|import\\|no\\|bootstrap\\)[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t;]" ; require A if B;
2 font-lock-function-name-face)
+ '("^[ \t]*format[ \t]+\\([a-zA-z_][a-zA-z_0-9:]*\\)[ \t]*=[ \t]*$"
+ 1 font-lock-function-name-face)
(cond ((featurep 'font-lock-extra)
'("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}"
(2 font-lock-string-face t)
@@ -2369,20 +3645,26 @@ indentation and initial hashes. Behaves usually outside of comment."
(2 '(restart 2 nil) nil t)))
nil t))) ; local variables, multiple
(font-lock-anchored
- '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"
+ '("^[ \t{}]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"
(3 font-lock-variable-name-face)
("\\=[ \t]*,[ \t]*\\([$@%*][a-zA-Z0-9_:]+\\)"
nil nil
(1 font-lock-variable-name-face))))
- (t '("^[ \t]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"
+ (t '("^[ \t{}]*\\(my\\|local\\)[ \t]*\\(([ \t]*\\)?\\([$@%*][a-zA-Z0-9_:]+\\)"
3 font-lock-variable-name-face)))
'("\\<for\\(each\\)?[ \t]*\\(\\$[a-zA-Z_][a-zA-Z_0-9]*\\)[ \t]*("
2 font-lock-variable-name-face)))
(setq
t-font-lock-keywords-1
(and (fboundp 'turn-on-font-lock) ; Check for newer font-lock
- (not (cperl-xemacs-p)) ; not yet as of XEmacs 19.12
- '(("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
+ (not cperl-xemacs-p) ; not yet as of XEmacs 19.12
+ '(
+ ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
+ (if (eq (char-after (match-beginning 2)) ?%)
+ font-lock-other-emphasized-face
+ font-lock-emphasized-face)
+ t) ; arrays and hashes
+ ("\\(\\([$@]+\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)[ \t]*\\([[{]\\)"
1
(if (= (- (match-end 2) (match-beginning 2)) 1)
(if (eq (char-after (match-beginning 3)) ?{)
@@ -2390,11 +3672,6 @@ indentation and initial hashes. Behaves usually outside of comment."
font-lock-emphasized-face) ; arrays and hashes
font-lock-variable-name-face) ; Just to put something
t)
- ("\\(\\([@%]\\|\$#\\)[a-zA-Z_:][a-zA-Z0-9_:]*\\)" 1
- (if (eq (char-after (match-beginning 2)) ?%)
- font-lock-other-emphasized-face
- font-lock-emphasized-face)
- t) ; arrays and hashes
;;("\\([smy]\\|tr\\)\\([^a-z_A-Z0-9]\\)\\(\\([^\n\\]*||\\)\\)\\2")
;;; Too much noise from \s* @s[ and friends
;;("\\(\\<\\([msy]\\|tr\\)[ \t]*\\([^ \t\na-zA-Z0-9_]\\)\\|\\(/\\)\\)"
@@ -2506,7 +3783,7 @@ indentation and initial hashes. Behaves usually outside of comment."
'font-lock-other-type-face
"Face to use for data types from another group.")
)
- (if (not (cperl-xemacs-p)) nil
+ (if (not cperl-xemacs-p) nil
(or (boundp 'font-lock-comment-face)
(defconst font-lock-comment-face
'font-lock-comment-face
@@ -2692,34 +3969,52 @@ Available styles are GNU, K&R, BSD and Whitesmith."
(let ((perl-dbg-flags "-wc"))
(mode-compile)))
-(defun cperl-info-buffer ()
- ;; Returns buffer with documentation. Creats if missing
- (let ((info (get-buffer "*info-perl*")))
+(defun cperl-info-buffer (type)
+ ;; Returns buffer with documentation. Creates if missing.
+ ;; If TYPE, this vars buffer.
+ ;; Special care is taken to not stomp over an existing info buffer
+ (let* ((bname (if type "*info-perl-var*" "*info-perl*"))
+ (info (get-buffer bname))
+ (oldbuf (get-buffer "*info*")))
(if info info
(save-window-excursion
;; Get Info running
(require 'info)
+ (cond (oldbuf
+ (set-buffer oldbuf)
+ (rename-buffer "*info-perl-tmp*")))
(save-window-excursion
(info))
- (Info-find-node "perl5" "perlfunc")
+ (Info-find-node cperl-info-page (if type "perlvar" "perlfunc"))
(set-buffer "*info*")
- (rename-buffer "*info-perl*")
+ (rename-buffer bname)
+ (cond (oldbuf
+ (set-buffer "*info-perl-tmp*")
+ (rename-buffer "*info*")
+ (set-buffer bname)))
+ (make-variable-buffer-local 'window-min-height)
+ (setq window-min-height 2)
(current-buffer)))))
(defun cperl-word-at-point (&optional p)
;; Returns the word at point or at P.
(save-excursion
(if p (goto-char p))
- (require 'etags)
- (funcall (or (and (boundp 'find-tag-default-function)
- find-tag-default-function)
- (get major-mode 'find-tag-default-function)
- ;; XEmacs 19.12 has `find-tag-default-hook'; it is
- ;; automatically used within `find-tag-default':
- 'find-tag-default))))
+ (or (cperl-word-at-point-hard)
+ (progn
+ (require 'etags)
+ (funcall (or (and (boundp 'find-tag-default-function)
+ find-tag-default-function)
+ (get major-mode 'find-tag-default-function)
+ ;; XEmacs 19.12 has `find-tag-default-hook'; it is
+ ;; automatically used within `find-tag-default':
+ 'find-tag-default))))))
(defun cperl-info-on-command (command)
- "Shows documentation for Perl command in other window."
+ "Shows documentation for Perl command in other window.
+If perl-info buffer is shown in some frame, uses this frame.
+Customized by setting variables `cperl-shrink-wrap-info-frame',
+`cperl-max-help-size'."
(interactive
(let* ((default (cperl-word-at-point))
(read (read-string
@@ -2731,21 +4026,72 @@ Available styles are GNU, K&R, BSD and Whitesmith."
(let ((buffer (current-buffer))
(cmd-desc (concat "^" (regexp-quote command) "[^a-zA-Z_0-9]")) ; "tr///"
- pos)
+ pos isvar height iniheight frheight buf win fr1 fr2 iniwin not-loner
+ max-height char-height buf-list)
(if (string-match "^-[a-zA-Z]$" command)
(setq cmd-desc "^-X[ \t\n]"))
- (set-buffer (cperl-info-buffer))
+ (setq isvar (string-match "^[$@%]" command)
+ buf (cperl-info-buffer isvar)
+ iniwin (selected-window)
+ fr1 (window-frame iniwin))
+ (set-buffer buf)
(beginning-of-buffer)
- (re-search-forward "^-X[ \t\n]")
- (forward-line -1)
+ (or isvar
+ (progn (re-search-forward "^-X[ \t\n]")
+ (forward-line -1)))
(if (re-search-forward cmd-desc nil t)
(progn
- (setq pos (progn (beginning-of-line)
- (point)))
- (pop-to-buffer (cperl-info-buffer))
+ ;; Go back to beginning of the group (ex, for qq)
+ (if (re-search-backward "^[ \t\n\f]")
+ (forward-line 1))
+ (beginning-of-line)
+ ;; Get some of
+ (setq pos (point)
+ buf-list (list buf "*info-perl-var*" "*info-perl*"))
+ (while (and (not win) buf-list)
+ (setq win (get-buffer-window (car buf-list) t))
+ (setq buf-list (cdr buf-list)))
+ (or (not win)
+ (eq (window-buffer win) buf)
+ (set-window-buffer win buf))
+ (and win (setq fr2 (window-frame win)))
+ (if (or (not fr2) (eq fr1 fr2))
+ (pop-to-buffer buf)
+ (special-display-popup-frame buf) ; Make it visible
+ (select-window win))
+ (goto-char pos) ; Needed (?!).
+ ;; Resize
+ (setq iniheight (window-height)
+ frheight (frame-height)
+ not-loner (< iniheight (1- frheight))) ; Are not alone
+ (cond ((if not-loner cperl-max-help-size
+ cperl-shrink-wrap-info-frame)
+ (setq height
+ (+ 2
+ (count-lines
+ pos
+ (save-excursion
+ (if (re-search-forward
+ "^[ \t][^\n]*\n+\\([^ \t\n\f]\\|\\'\\)" nil t)
+ (match-beginning 0) (point-max)))))
+ max-height
+ (if not-loner
+ (/ (* (- frheight 3) cperl-max-help-size) 100)
+ (setq char-height (frame-char-height))
+ ;; Non-functioning under OS/2:
+ (if (eq char-height 1) (setq char-height 18))
+ ;; Title, menubar, + 2 for slack
+ (- (/ (x-display-pixel-height) char-height) 4)
+ ))
+ (if (> height max-height) (setq height max-height))
+ ;;(message "was %s doing %s" iniheight height)
+ (if not-loner
+ (enlarge-window (- height iniheight))
+ (set-frame-height (window-frame win) (1+ height)))))
(set-window-start (selected-window) pos))
(message "No entry for %s found." command))
- (pop-to-buffer buffer)))
+ ;;(pop-to-buffer buffer)
+ (select-window iniwin)))
(defun cperl-info-on-current-command ()
"Shows documentation for Perl command at point in other window."
@@ -2755,7 +4101,7 @@ Available styles are GNU, K&R, BSD and Whitesmith."
(defun cperl-imenu-info-imenu-search ()
(if (looking-at "^-X[ \t\n]") nil
(re-search-backward
- "^\n\\([-a-zA-Z]+\\)[ \t\n]")
+ "^\n\\([-a-zA-Z_]+\\)[ \t\n]")
(forward-line 1)))
(defun cperl-imenu-info-imenu-name ()
@@ -2770,7 +4116,7 @@ Available styles are GNU, K&R, BSD and Whitesmith."
imenu-extract-index-name-function
(index-item (save-restriction
(save-window-excursion
- (set-buffer (cperl-info-buffer))
+ (set-buffer (cperl-info-buffer nil))
(setq imenu-create-index-function
'imenu-default-create-index-function
imenu-prev-index-position-function
@@ -2793,7 +4139,7 @@ Available styles are GNU, K&R, BSD and Whitesmith."
(defun cperl-lineup (beg end &optional step minshift)
"Lineup construction in a region.
Beginning of region should be at the start of a construction.
-All first occurences of this construction in the lines that are
+All first occurrences of this construction in the lines that are
partially contained in the region are lined up at the same column.
MINSHIFT is the minimal amount of space to insert before the construction.
@@ -2813,8 +4159,8 @@ Will not move the position at the start to the left."
(indent-region beg end nil)
(goto-char beg)
(setq col (current-column))
- (if (looking-at "\\sw")
- (if (looking-at "\\<\\sw+\\>")
+ (if (looking-at "[a-zA-Z0-9_]")
+ (if (looking-at "\\<[a-zA-Z0-9_]+\\>")
(setq search
(concat "\\<"
(regexp-quote
@@ -2834,7 +4180,7 @@ Will not move the position at the start to the left."
(setq tcol (current-column) seen t)
(if (> tcol col) (setq col tcol)))
(or seen
- (error "The construction to line up occured only once"))
+ (error "The construction to line up occurred only once"))
(goto-char beg)
(setq col (+ col minshift))
(if (/= (% col step) 0) (setq step (* step (1+ (/ col step)))))
@@ -2855,7 +4201,7 @@ If optional argument ALL is `recursive', will process Perl files
in subdirectories too."
(interactive)
(let ((cmd "etags")
- (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\([{#]\\|$\\)\\)/\\4/"))
+ (args '("-l" "none" "-r" "/\\<\\(package\\|sub\\)[ \\t]+\\(\\([a-zA-Z0-9:_]*::\\)?\\([a-zA-Z0-9_]+\\)[ \\t]*\\(([^()]*)[ \t]*\\)?\\([{#]\\|$\\)\\)/\\4/"))
res)
(if add (setq args (cons "-a" args)))
(or files (setq files (list buffer-file-name)))
@@ -2863,7 +4209,7 @@ in subdirectories too."
((eq all 'recursive)
;;(error "Not implemented: recursive")
(setq args (append (list "-e"
- "sub wanted {push @ARGV, $File::Find::name if /\\.[Pp][Llm]$/}
+ "sub wanted {push @ARGV, $File::Find::name if /\\.[pP][Llm]$/}
use File::Find;
find(\\&wanted, '.');
exec @ARGV;"
@@ -2881,3 +4227,1382 @@ in subdirectories too."
(setq res (apply 'call-process cmd nil nil nil args))
(or (eq res 0)
(message "etags returned \"%s\"" res))))
+
+(defun cperl-toggle-auto-newline ()
+ "Toggle the state of `cperl-auto-newline'."
+ (interactive)
+ (setq cperl-auto-newline (not cperl-auto-newline))
+ (message "Newlines will %sbe auto-inserted now."
+ (if cperl-auto-newline "" "not ")))
+
+(defun cperl-toggle-abbrev ()
+ "Toggle the state of automatic keyword expansion in CPerl mode."
+ (interactive)
+ (abbrev-mode (if abbrev-mode 0 1))
+ (message "Perl control structure will %sbe auto-inserted now."
+ (if abbrev-mode "" "not ")))
+
+
+(defun cperl-toggle-electric ()
+ "Toggle the state of parentheses doubling in CPerl mode."
+ (interactive)
+ (setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t))
+ (message "Parentheses will %sbe auto-doubled now."
+ (if (cperl-val 'cperl-electric-parens) "" "not ")))
+
+;;;; Tags file creation.
+
+(defvar cperl-tmp-buffer " *cperl-tmp*")
+
+(defun cperl-setup-tmp-buf ()
+ (set-buffer (get-buffer-create cperl-tmp-buffer))
+ (set-syntax-table cperl-mode-syntax-table)
+ (buffer-disable-undo)
+ (auto-fill-mode 0)
+ (if cperl-use-syntax-table-text-property-for-tags
+ (progn
+ (make-variable-buffer-local 'parse-sexp-lookup-properties)
+ ;; Do not introduce variable if not needed, we check it!
+ (set 'parse-sexp-lookup-properties t))))
+
+(defun cperl-xsub-scan ()
+ (require 'cl)
+ (require 'imenu)
+ (let ((index-alist '())
+ (prev-pos 0) index index1 name package prefix)
+ (goto-char (point-min))
+ (imenu-progress-message prev-pos 0)
+ ;; Search for the function
+ (progn ;;save-match-data
+ (while (re-search-forward
+ "^\\([ \t]*MODULE\\>[^\n]*\\<PACKAGE[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9:]*\\)\\>\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)"
+ nil t)
+ (imenu-progress-message prev-pos)
+ (cond
+ ((match-beginning 2) ; SECTION
+ (setq package (buffer-substring (match-beginning 2) (match-end 2)))
+ (goto-char (match-beginning 0))
+ (skip-chars-forward " \t")
+ (forward-char 1)
+ (if (looking-at "[^\n]*\\<PREFIX[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\>")
+ (setq prefix (buffer-substring (match-beginning 1) (match-end 1)))
+ (setq prefix nil)))
+ ((not package) nil) ; C language section
+ ((match-beginning 3) ; XSUB
+ (goto-char (1+ (match-beginning 3)))
+ (setq index (imenu-example--name-and-position))
+ (setq name (buffer-substring (match-beginning 3) (match-end 3)))
+ (if (and prefix (string-match (concat "^" prefix) name))
+ (setq name (substring name (length prefix))))
+ (cond ((string-match "::" name) nil)
+ (t
+ (setq index1 (cons (concat package "::" name) (cdr index)))
+ (push index1 index-alist)))
+ (setcar index name)
+ (push index index-alist))
+ (t ; BOOT: section
+ ;; (beginning-of-line)
+ (setq index (imenu-example--name-and-position))
+ (setcar index (concat package "::BOOT:"))
+ (push index index-alist)))))
+ (imenu-progress-message prev-pos 100)
+ ;;(setq index-alist
+ ;; (if (default-value 'imenu-sort-function)
+ ;; (sort index-alist (default-value 'imenu-sort-function))
+ ;; (nreverse index-alist)))
+ index-alist))
+
+(defun cperl-find-tags (file xs)
+ (let (ind (b (get-buffer cperl-tmp-buffer)) lst elt pos ret
+ (cperl-pod-here-fontify nil))
+ (save-excursion
+ (if b (set-buffer b)
+ (cperl-setup-tmp-buf))
+ (erase-buffer)
+ (setq file (car (insert-file-contents file)))
+ (message "Scanning file %s..." file)
+ (if cperl-use-syntax-table-text-property-for-tags
+ (cperl-find-pods-heres))
+ (if xs
+ (setq lst (cperl-xsub-scan))
+ (setq ind (imenu-example--create-perl-index))
+ (setq lst (cdr (assoc "+Unsorted List+..." ind))))
+ (setq lst
+ (mapcar
+ (function
+ (lambda (elt)
+ (cond ((string-match "^[_a-zA-Z]" (car elt))
+ (goto-char (cdr elt))
+ (list (car elt)
+ (point) (count-lines 1 (point))
+ (buffer-substring (progn
+ (skip-chars-forward
+ ":_a-zA-Z0-9")
+ (or (eolp) (forward-char 1))
+ (point))
+ (progn
+ (beginning-of-line)
+ (point))))))))
+ lst))
+ (erase-buffer)
+ (while lst
+ (setq elt (car lst) lst (cdr lst))
+ (if elt
+ (progn
+ (insert (elt elt 3)
+ 127
+ (if (string-match "^package " (car elt))
+ (substring (car elt) 8)
+ (car elt) )
+ 1
+ (number-to-string (elt elt 1))
+ ","
+ (number-to-string (elt elt 2))
+ "\n")
+ (if (and (string-match "^[_a-zA-Z]+::" (car elt))
+ (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]"
+ (elt elt 3)))
+ ;; Need to insert the name without package as well
+ (setq lst (cons (cons (substring (elt elt 3)
+ (match-beginning 1)
+ (match-end 1))
+ (cdr elt))
+ lst))))))
+ (setq pos (point))
+ (goto-char 1)
+ (insert "\f\n" file "," (number-to-string (1- pos)) "\n")
+ (setq ret (buffer-substring 1 (point-max)))
+ (erase-buffer)
+ (message "Scanning file %s finished" file)
+ ret)))
+
+(defun cperl-write-tags (&optional file erase recurse dir inbuffer)
+ ;; If INBUFFER, do not select buffer, and do not save
+ ;; If ERASE is `ignore', do not erase, and do not try to delete old info.
+ (require 'etags)
+ (if file nil
+ (setq file (if dir default-directory (buffer-file-name)))
+ (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!")))
+ (let ((tags-file-name "TAGS")
+ (case-fold-search (eq system-type 'emx))
+ xs)
+ (save-excursion
+ (cond (inbuffer nil) ; Already there
+ ((file-exists-p tags-file-name)
+ (visit-tags-table-buffer tags-file-name))
+ (t (set-buffer (find-file-noselect tags-file-name))))
+ (cond
+ (dir
+ (cond ((eq erase 'ignore))
+ (erase
+ (erase-buffer)
+ (setq erase 'ignore)))
+ (let ((files
+ (directory-files file t
+ (if recurse nil cperl-scan-files-regexp)
+ t)))
+ (mapcar (function (lambda (file)
+ (cond
+ ((string-match cperl-noscan-files-regexp file)
+ nil)
+ ((not (file-directory-p file))
+ (if (string-match cperl-scan-files-regexp file)
+ (cperl-write-tags file erase recurse nil t)))
+ ((not recurse) nil)
+ (t (cperl-write-tags file erase recurse t t)))))
+ files))
+ )
+ (t
+ (setq xs (string-match "\\.xs$" file))
+ (cond ((eq erase 'ignore) (goto-char (point-max)))
+ (erase (erase-buffer))
+ (t
+ (goto-char 1)
+ (if (search-forward (concat "\f\n" file ",") nil t)
+ (progn
+ (search-backward "\f\n")
+ (delete-region (point)
+ (save-excursion
+ (forward-char 1)
+ (if (search-forward "\f\n" nil 'toend)
+ (- (point) 2)
+ (point-max)))))
+ (goto-char (point-max)))))
+ (insert (cperl-find-tags file xs))))
+ (if inbuffer nil ; Delegate to the caller
+ (save-buffer 0) ; No backup
+ (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs?
+ (initialize-new-tags-table))))))
+
+(defvar cperl-tags-hier-regexp-list
+ (concat
+ "^\\("
+ "\\(package\\)\\>"
+ "\\|"
+ "sub\\>[^\n]+::"
+ "\\|"
+ "[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::" ; XSUB?
+ "\\|"
+ "[ \t]*BOOT:\C-?[^\n]+::" ; BOOT section
+ "\\)"))
+
+(defvar cperl-hierarchy '(() ())
+ "Global hierarchy of classes")
+
+(defun cperl-tags-hier-fill ()
+ ;; Suppose we are in a tag table cooked by cperl.
+ (goto-char 1)
+ (let (type pack name pos line chunk ord cons1 file str info fileind)
+ (while (re-search-forward cperl-tags-hier-regexp-list nil t)
+ (setq pos (match-beginning 0)
+ pack (match-beginning 2))
+ (beginning-of-line)
+ (if (looking-at (concat
+ "\\([^\n]+\\)"
+ "\C-?"
+ "\\([^\n]+\\)"
+ "\C-a"
+ "\\([0-9]+\\)"
+ ","
+ "\\([0-9]+\\)"))
+ (progn
+ (setq ;;str (buffer-substring (match-beginning 1) (match-end 1))
+ name (buffer-substring (match-beginning 2) (match-end 2))
+ ;;pos (buffer-substring (match-beginning 3) (match-end 3))
+ line (buffer-substring (match-beginning 4) (match-end 4))
+ ord (if pack 1 0)
+ info (etags-snarf-tag) ; Moves to beginning of the next line
+ file (file-of-tag)
+ fileind (format "%s:%s" file line))
+ ;; Move back
+ (forward-char -1)
+ ;; Make new member of hierarchy name ==> file ==> pos if needed
+ (if (setq cons1 (assoc name (nth ord cperl-hierarchy)))
+ ;; Name known
+ (setcdr cons1 (cons (cons fileind (vector file info))
+ (cdr cons1)))
+ ;; First occurrence of the name, start alist
+ (setq cons1 (cons name (list (cons fileind (vector file info)))))
+ (if pack
+ (setcar (cdr cperl-hierarchy)
+ (cons cons1 (nth 1 cperl-hierarchy)))
+ (setcar cperl-hierarchy
+ (cons cons1 (car cperl-hierarchy)))))))
+ (end-of-line))))
+
+(defun cperl-tags-hier-init (&optional update)
+ "Show hierarchical menu of classes and methods.
+Finds info about classes by a scan of loaded TAGS files.
+Supposes that the TAGS files contain fully qualified function names.
+One may build such TAGS files from CPerl mode menu."
+ (interactive)
+ (require 'etags)
+ (require 'imenu)
+ (if (or update (null (nth 2 cperl-hierarchy)))
+ (let (pack name cons1 to l1 l2 l3 l4
+ (remover (function (lambda (elt) ; (name (file1...) (file2..))
+ (or (nthcdr 2 elt)
+ ;; Only in one file
+ (setcdr elt (cdr (nth 1 elt))))))))
+ ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later!
+ (setq cperl-hierarchy (list l1 l2 l3))
+ (or tags-table-list
+ (call-interactively 'visit-tags-table))
+ (message "Updating list of classes...")
+ (mapcar
+ (function
+ (lambda (tagsfile)
+ (set-buffer (get-file-buffer tagsfile))
+ (cperl-tags-hier-fill)))
+ tags-table-list)
+ (mapcar remover (car cperl-hierarchy))
+ (mapcar remover (nth 1 cperl-hierarchy))
+ (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy))
+ (cons "Methods: " (car cperl-hierarchy))))
+ (cperl-tags-treeify to 1)
+ (setcar (nthcdr 2 cperl-hierarchy)
+ (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to))))
+ (message "Updating list of classes: done, requesting display...")
+ ;;(cperl-imenu-addback (nth 2 cperl-hierarchy))
+ ))
+ (or (nth 2 cperl-hierarchy)
+ (error "No items found"))
+ (setq update
+;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy))
+ (if window-system
+ (x-popup-menu t (nth 2 cperl-hierarchy))
+ (require 'tmm)
+ (tmm-prompt (nth 2 cperl-hierarchy))))
+ (if (and update (listp update))
+ (progn (while (cdr update) (setq update (cdr update)))
+ (setq update (car update)))) ; Get the last from the list
+ (if (vectorp update)
+ (progn
+ (find-file (elt update 0))
+ (etags-goto-tag-location (elt update 1))))
+ (if (eq update -999) (cperl-tags-hier-init t)))
+
+(defun cperl-tags-treeify (to level)
+ ;; cadr of `to' is read-write. On start it is a cons
+ (let* ((regexp (concat "^\\(" (mapconcat
+ 'identity
+ (make-list level "[_a-zA-Z0-9]+")
+ "::")
+ "\\)\\(::\\)?"))
+ (packages (cdr (nth 1 to)))
+ (methods (cdr (nth 2 to)))
+ l1 head tail cons1 cons2 ord writeto packs recurse
+ root-packages root-functions ms many_ms same_name ps
+ (move-deeper
+ (function
+ (lambda (elt)
+ (cond ((and (string-match regexp (car elt))
+ (or (eq ord 1) (match-end 2)))
+ (setq head (substring (car elt) 0 (match-end 1))
+ tail (if (match-end 2) (substring (car elt)
+ (match-end 2)))
+ recurse t)
+ (if (setq cons1 (assoc head writeto)) nil
+ ;; Need to init new head
+ (setcdr writeto (cons (list head (list "Packages: ")
+ (list "Methods: "))
+ (cdr writeto)))
+ (setq cons1 (nth 1 writeto)))
+ (setq cons2 (nth ord cons1)) ; Either packs or meths
+ (setcdr cons2 (cons elt (cdr cons2))))
+ ((eq ord 2)
+ (setq root-functions (cons elt root-functions)))
+ (t
+ (setq root-packages (cons elt root-packages))))))))
+ (setcdr to l1) ; Init to dynamic space
+ (setq writeto to)
+ (setq ord 1)
+ (mapcar move-deeper packages)
+ (setq ord 2)
+ (mapcar move-deeper methods)
+ (if recurse
+ (mapcar (function (lambda (elt)
+ (cperl-tags-treeify elt (1+ level))))
+ (cdr to)))
+ ;;Now clean up leaders with one child only
+ (mapcar (function (lambda (elt)
+ (if (not (and (listp (cdr elt))
+ (eq (length elt) 2))) nil
+ (setcar elt (car (nth 1 elt)))
+ (setcdr elt (cdr (nth 1 elt))))))
+ (cdr to))
+ ;; Sort the roots of subtrees
+ (if (default-value 'imenu-sort-function)
+ (setcdr to
+ (sort (cdr to) (default-value 'imenu-sort-function))))
+ ;; Now add back functions removed from display
+ (mapcar (function (lambda (elt)
+ (setcdr to (cons elt (cdr to)))))
+ (if (default-value 'imenu-sort-function)
+ (nreverse
+ (sort root-functions (default-value 'imenu-sort-function)))
+ root-functions))
+ ;; Now add back packages removed from display
+ (mapcar (function (lambda (elt)
+ (setcdr to (cons (cons (concat "package " (car elt))
+ (cdr elt))
+ (cdr to)))))
+ (if (default-value 'imenu-sort-function)
+ (nreverse
+ (sort root-packages (default-value 'imenu-sort-function)))
+ root-packages))
+ ))
+
+;;;(x-popup-menu t
+;;; '(keymap "Name1"
+;;; ("Ret1" "aa")
+;;; ("Head1" "ab"
+;;; keymap "Name2"
+;;; ("Tail1" "x") ("Tail2" "y"))))
+
+(defun cperl-list-fold (list name limit)
+ (let (list1 list2 elt1 (num 0))
+ (if (<= (length list) limit) list
+ (setq list1 nil list2 nil)
+ (while list
+ (setq num (1+ num)
+ elt1 (car list)
+ list (cdr list))
+ (if (<= num imenu-max-items)
+ (setq list2 (cons elt1 list2))
+ (setq list1 (cons (cons name
+ (nreverse list2))
+ list1)
+ list2 (list elt1)
+ num 1)))
+ (nreverse (cons (cons name
+ (nreverse list2))
+ list1)))))
+
+(defun cperl-menu-to-keymap (menu &optional name)
+ (let (list)
+ (cons 'keymap
+ (mapcar
+ (function
+ (lambda (elt)
+ (cond ((listp (cdr elt))
+ (setq list (cperl-list-fold
+ (cdr elt) (car elt) imenu-max-items))
+ (cons nil
+ (cons (car elt)
+ (cperl-menu-to-keymap list))))
+ (t
+ (list (cdr elt) (car elt) t))))) ; t is needed in 19.34
+ (cperl-list-fold menu "Root" imenu-max-items)))))
+
+
+(defvar cperl-bad-style-regexp
+ (mapconcat 'identity
+ '("[^-\n\t <>=+!.&|(*/'`\"#^][-=+<>!|&^]" ; char sign
+ "[-<>=+^&|]+[^- \t\n=+<>~]" ; sign+ char
+ )
+ "\\|")
+ "Finds places such that insertion of a whitespace may help a lot.")
+
+(defvar cperl-not-bad-style-regexp
+ (mapconcat 'identity
+ '("[^-\t <>=+]\\(--\\|\\+\\+\\)" ; var-- var++
+ "[a-zA-Z0-9_][|&][a-zA-Z0-9_$]" ; abc|def abc&def are often used.
+ "&[(a-zA-Z0-9_$]" ; &subroutine &(var->field)
+ "<\\$?\\sw+\\(\\.\\sw+\\)?>" ; <IN> <stdin.h>
+ "-[a-zA-Z][ \t]+[_$\"'`]" ; -f file
+ "-[0-9]" ; -5
+ "\\+\\+" ; ++var
+ "--" ; --var
+ ".->" ; a->b
+ "->" ; a SPACE ->b
+ "\\[-" ; a[-1]
+ "^=" ; =head
+ "||"
+ "&&"
+ "[CBIXSLFZ]<\\(\\sw\\|\\s \\|\\s_\\|[\n]\\)*>" ; C<code like text>
+ "-[a-zA-Z_0-9]+[ \t]*=>" ; -option => value
+ ;; Unaddressed trouble spots: = -abc, f(56, -abc) --- specialcased below
+ ;;"[*/+-|&<.]+="
+ )
+ "\\|")
+ "If matches at the start of match found by `my-bad-c-style-regexp',
+insertion of a whitespace will not help.")
+
+(defvar found-bad)
+
+(defun cperl-find-bad-style ()
+ "Find places in the buffer where insertion of a whitespace may help.
+Prompts user for insertion of spaces.
+Currently it is tuned to C and Perl syntax."
+ (interactive)
+ (let (found-bad (p (point)))
+ (setq last-nonmenu-event 13) ; To disable popup
+ (beginning-of-buffer)
+ (map-y-or-n-p "Insert space here? "
+ (function (lambda (arg) (insert " ")))
+ 'cperl-next-bad-style
+ '("location" "locations" "insert a space into")
+ '((?\C-r (lambda (arg)
+ (let ((buffer-quit-function
+ 'exit-recursive-edit))
+ (message "Exit with Esc Esc")
+ (recursive-edit)
+ t)) ; Consider acted upon
+ "edit, exit with Esc Esc")
+ (?e (lambda (arg)
+ (let ((buffer-quit-function
+ 'exit-recursive-edit))
+ (message "Exit with Esc Esc")
+ (recursive-edit)
+ t)) ; Consider acted upon
+ "edit, exit with Esc Esc"))
+ t)
+ (if found-bad (goto-char found-bad)
+ (goto-char p)
+ (message "No appropriate place found"))))
+
+(defun cperl-next-bad-style ()
+ (let (p (not-found t) (point (point)) found)
+ (while (and not-found
+ (re-search-forward cperl-bad-style-regexp nil 'to-end))
+ (setq p (point))
+ (goto-char (match-beginning 0))
+ (if (or
+ (looking-at cperl-not-bad-style-regexp)
+ ;; Check for a < -b and friends
+ (and (eq (following-char) ?\-)
+ (save-excursion
+ (skip-chars-backward " \t\n")
+ (memq (preceding-char) '(?\= ?\> ?\< ?\, ?\(, ?\[, ?\{))))
+ ;; Now check for syntax type
+ (save-match-data
+ (setq found (point))
+ (beginning-of-defun)
+ (let ((pps (parse-partial-sexp (point) found)))
+ (or (nth 3 pps) (nth 4 pps) (nth 5 pps)))))
+ (goto-char (match-end 0))
+ (goto-char (1- p))
+ (setq not-found nil
+ found-bad found)))
+ (not not-found)))
+
+
+;;; Getting help
+(defvar cperl-have-help-regexp
+ ;;(concat "\\("
+ (mapconcat
+ 'identity
+ '("[$@%*&][0-9a-zA-Z_:]+\\([ \t]*[[{]\\)?" ; Usual variable
+ "[$@]\\^[a-zA-Z]" ; Special variable
+ "[$@][^ \n\t]" ; Special variable
+ "-[a-zA-Z]" ; File test
+ "\\\\[a-zA-Z0]" ; Special chars
+ "^=[a-z][a-zA-Z0-9_]*" ; Pod sections
+ "[-!&*+,-./<=>?\\\\^|~]+" ; Operator
+ "[a-zA-Z_0-9:]+" ; symbol or number
+ "x="
+ "#!"
+ )
+ ;;"\\)\\|\\("
+ "\\|"
+ )
+ ;;"\\)"
+ ;;)
+ "Matches places in the buffer we can find help for.")
+
+(defvar cperl-message-on-help-error t)
+(defvar cperl-help-from-timer nil)
+
+(defun cperl-word-at-point-hard ()
+ ;; Does not save-excursion
+ ;; Get to the something meaningful
+ (or (eobp) (eolp) (forward-char 1))
+ (re-search-backward "[-a-zA-Z0-9_:!&*+,-./<=>?\\\\^|~$%@]"
+ (save-excursion (beginning-of-line) (point))
+ 'to-beg)
+ ;; (cond
+ ;; ((or (eobp) (looking-at "[][ \t\n{}();,]")) ; Not at a symbol
+ ;; (skip-chars-backward " \n\t\r({[]});,")
+ ;; (or (bobp) (backward-char 1))))
+ ;; Try to backtrace
+ (cond
+ ((looking-at "[a-zA-Z0-9_:]") ; symbol
+ (skip-chars-backward "a-zA-Z0-9_:")
+ (cond
+ ((and (eq (preceding-char) ?^) ; $^I
+ (eq (char-after (- (point) 2)) ?\$))
+ (forward-char -2))
+ ((memq (preceding-char) (append "*$@%&\\" nil)) ; *glob
+ (forward-char -1))
+ ((and (eq (preceding-char) ?\=)
+ (eq (current-column) 1))
+ (forward-char -1))) ; =head1
+ (if (and (eq (preceding-char) ?\<)
+ (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <FH>
+ (forward-char -1)))
+ ((and (looking-at "=") (eq (preceding-char) ?x)) ; x=
+ (forward-char -1))
+ ((and (looking-at "\\^") (eq (preceding-char) ?\$)) ; $^I
+ (forward-char -1))
+ ((looking-at "[-!&*+,-./<=>?\\\\^|~]")
+ (skip-chars-backward "-!&*+,-./<=>?\\\\^|~")
+ (cond
+ ((and (eq (preceding-char) ?\$)
+ (not (eq (char-after (- (point) 2)) ?\$))) ; $-
+ (forward-char -1))
+ ((and (eq (following-char) ?\>)
+ (string-match "[a-zA-Z0-9_]" (char-to-string (preceding-char)))
+ (save-excursion
+ (forward-sexp -1)
+ (and (eq (preceding-char) ?\<)
+ (looking-at "\\$?[a-zA-Z0-9_:]+>")))) ; <FH>
+ (search-backward "<"))))
+ ((and (eq (following-char) ?\$)
+ (eq (preceding-char) ?\<)
+ (looking-at "\\$?[a-zA-Z0-9_:]+>")) ; <$fh>
+ (forward-char -1)))
+ (if (looking-at cperl-have-help-regexp)
+ (buffer-substring (match-beginning 0) (match-end 0))))
+
+(defun cperl-get-help ()
+ "Get one-line docs on the symbol at the point.
+The data for these docs is a little bit obsolete and may be in fact longer
+than a line. Your contribution to update/shorten it is appreciated."
+ (interactive)
+ (save-match-data ; May be called "inside" query-replace
+ (save-excursion
+ (let ((word (cperl-word-at-point-hard)))
+ (if word
+ (if (and cperl-help-from-timer ; Bail out if not in mainland
+ (not (string-match "^#!\\|\\\\\\|^=" word)) ; Show help even in comments/strings.
+ (or (memq (get-text-property (point) 'face)
+ '(font-lock-comment-face font-lock-string-face))
+ (memq (get-text-property (point) 'syntax-type)
+ '(pod here-doc format))))
+ nil
+ (cperl-describe-perl-symbol word))
+ (if cperl-message-on-help-error
+ (message "Nothing found for %s..."
+ (buffer-substring (point) (min (+ 5 (point)) (point-max))))))))))
+
+;;; Stolen from perl-descr.el by Johan Vromans:
+
+(defvar cperl-doc-buffer " *perl-doc*"
+ "Where the documentation can be found.")
+
+(defun cperl-describe-perl-symbol (val)
+ "Display the documentation of symbol at point, a Perl operator."
+ (let ((enable-recursive-minibuffers t)
+ args-file regexp)
+ (cond
+ ((string-match "^[&*][a-zA-Z_]" val)
+ (setq val (concat (substring val 0 1) "NAME")))
+ ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*\\[" val)
+ (setq val (concat "@" (substring val 1 (match-end 1)))))
+ ((string-match "^[$@]\\([a-zA-Z_:0-9]+\\)[ \t]*{" val)
+ (setq val (concat "%" (substring val 1 (match-end 1)))))
+ ((and (string= val "x") (string-match "^x=" val))
+ (setq val "x="))
+ ((string-match "^\\$[\C-a-\C-z]" val)
+ (setq val (concat "$^" (char-to-string (+ ?A -1 (aref val 1))))))
+ ((string-match "^CORE::" val)
+ (setq val "CORE::"))
+ ((string-match "^SUPER::" val)
+ (setq val "SUPER::"))
+ ((and (string= "<" val) (string-match "^<\\$?[a-zA-Z0-9_:]+>" val))
+ (setq val "<NAME>")))
+ (setq regexp (concat "^"
+ "\\([^a-zA-Z0-9_:]+[ \t]+\\)?"
+ (regexp-quote val)
+ "\\([ \t([/]\\|$\\)"))
+
+ ;; get the buffer with the documentation text
+ (cperl-switch-to-doc-buffer)
+
+ ;; lookup in the doc
+ (goto-char (point-min))
+ (let ((case-fold-search nil))
+ (list
+ (if (re-search-forward regexp (point-max) t)
+ (save-excursion
+ (beginning-of-line 1)
+ (let ((lnstart (point)))
+ (end-of-line)
+ (message "%s" (buffer-substring lnstart (point)))))
+ (if cperl-message-on-help-error
+ (message "No definition for %s" val)))))))
+
+(defvar cperl-short-docs "Ignore my value"
+ ;; Perl4 version was written by Johan Vromans (jvromans@squirrel.nl)
+ "# based on '@(#)@ perl-descr.el 1.9 - describe-perl-symbol' [Perl 5]
+! ... Logical negation.
+... != ... Numeric inequality.
+... !~ ... Search pattern, substitution, or translation (negated).
+$! In numeric context: errno. In a string context: error string.
+$\" The separator which joins elements of arrays interpolated in strings.
+$# The output format for printed numbers. Initial value is %.20g.
+$$ Process number of this script. Changes in the fork()ed child process.
+$% The current page number of the currently selected output channel.
+
+ The following variables are always local to the current block:
+
+$1 Match of the 1st set of parentheses in the last match (auto-local).
+$2 Match of the 2nd set of parentheses in the last match (auto-local).
+$3 Match of the 3rd set of parentheses in the last match (auto-local).
+$4 Match of the 4th set of parentheses in the last match (auto-local).
+$5 Match of the 5th set of parentheses in the last match (auto-local).
+$6 Match of the 6th set of parentheses in the last match (auto-local).
+$7 Match of the 7th set of parentheses in the last match (auto-local).
+$8 Match of the 8th set of parentheses in the last match (auto-local).
+$9 Match of the 9th set of parentheses in the last match (auto-local).
+$& The string matched by the last pattern match (auto-local).
+$' The string after what was matched by the last match (auto-local).
+$` The string before what was matched by the last match (auto-local).
+
+$( The real gid of this process.
+$) The effective gid of this process.
+$* Deprecated: Set to 1 to do multiline matching within a string.
+$+ The last bracket matched by the last search pattern.
+$, The output field separator for the print operator.
+$- The number of lines left on the page.
+$. The current input line number of the last filehandle that was read.
+$/ The input record separator, newline by default.
+$0 Name of the file containing the perl script being executed. May be set.
+$: String may be broken after these characters to fill ^-lines in a format.
+$; Subscript separator for multi-dim array emulation. Default \"\\034\".
+$< The real uid of this process.
+$= The page length of the current output channel. Default is 60 lines.
+$> The effective uid of this process.
+$? The status returned by the last ``, pipe close or `system'.
+$@ The perl error message from the last eval or do @var{EXPR} command.
+$ARGV The name of the current file used with <> .
+$[ Deprecated: The index of the first element/char in an array/string.
+$\\ The output record separator for the print operator.
+$] The perl version string as displayed with perl -v.
+$^ The name of the current top-of-page format.
+$^A The current value of the write() accumulator for format() lines.
+$^D The value of the perl debug (-D) flags.
+$^E Information about the last system error other than that provided by $!.
+$^F The highest system file descriptor, ordinarily 2.
+$^H The current set of syntax checks enabled by `use strict'.
+$^I The value of the in-place edit extension (perl -i option).
+$^L What formats output to perform a formfeed. Default is \f.
+$^O The operating system name under which this copy of Perl was built.
+$^P Internal debugging flag.
+$^T The time the script was started. Used by -A/-M/-C file tests.
+$^W True if warnings are requested (perl -w flag).
+$^X The name under which perl was invoked (argv[0] in C-speech).
+$_ The default input and pattern-searching space.
+$| Auto-flush after write/print on the current output channel? Default 0.
+$~ The name of the current report format.
+... % ... Modulo division.
+... %= ... Modulo division assignment.
+%ENV Contains the current environment.
+%INC List of files that have been require-d or do-ne.
+%SIG Used to set signal handlers for various signals.
+... & ... Bitwise and.
+... && ... Logical and.
+... &&= ... Logical and assignment.
+... &= ... Bitwise and assignment.
+... * ... Multiplication.
+... ** ... Exponentiation.
+*NAME Glob: all objects refered by NAME. *NAM1 = *NAM2 aliases NAM1 to NAM2.
+&NAME(arg0, ...) Subroutine call. Arguments go to @_.
+... + ... Addition. +EXPR Makes EXPR into scalar context.
+++ Auto-increment (magical on strings). ++EXPR EXPR++
+... += ... Addition assignment.
+, Comma operator.
+... - ... Subtraction.
+-- Auto-decrement (NOT magical on strings). --EXPR EXPR--
+... -= ... Subtraction assignment.
+-A Access time in days since script started.
+-B File is a non-text (binary) file.
+-C Inode change time in days since script started.
+-M Age in days since script started.
+-O File is owned by real uid.
+-R File is readable by real uid.
+-S File is a socket .
+-T File is a text file.
+-W File is writable by real uid.
+-X File is executable by real uid.
+-b File is a block special file.
+-c File is a character special file.
+-d File is a directory.
+-e File exists .
+-f File is a plain file.
+-g File has setgid bit set.
+-k File has sticky bit set.
+-l File is a symbolic link.
+-o File is owned by effective uid.
+-p File is a named pipe (FIFO).
+-r File is readable by effective uid.
+-s File has non-zero size.
+-t Tests if filehandle (STDIN by default) is opened to a tty.
+-u File has setuid bit set.
+-w File is writable by effective uid.
+-x File is executable by effective uid.
+-z File has zero size.
+. Concatenate strings.
+.. Alternation, also range operator.
+.= Concatenate assignment strings
+... / ... Division. /PATTERN/ioxsmg Pattern match
+... /= ... Division assignment.
+/PATTERN/ioxsmg Pattern match.
+... < ... Numeric less than. <pattern> Glob. See <NAME>, <> as well.
+<NAME> Reads line from filehandle NAME. NAME must be bareword/dollar-bareword.
+<pattern> Glob. (Unless pattern is bareword/dollar-bareword - see <NAME>)
+<> Reads line from union of files in @ARGV (= command line) and STDIN.
+... << ... Bitwise shift left. << start of HERE-DOCUMENT.
+... <= ... Numeric less than or equal to.
+... <=> ... Numeric compare.
+... = ... Assignment.
+... == ... Numeric equality.
+... =~ ... Search pattern, substitution, or translation
+... > ... Numeric greater than.
+... >= ... Numeric greater than or equal to.
+... >> ... Bitwise shift right.
+... >>= ... Bitwise shift right assignment.
+... ? ... : ... Condition=if-then-else operator. ?PAT? One-time pattern match.
+?PATTERN? One-time pattern match.
+@ARGV Command line arguments (not including the command name - see $0).
+@INC List of places to look for perl scripts during do/include/use.
+@_ Parameter array for subroutines. Also used by split unless in array context.
+\\ Creates reference to what follows, like \$var, or quotes non-\w in strings.
+\\0 Octal char, e.g. \\033.
+\\E Case modification terminator. See \\Q, \\L, and \\U.
+\\L Lowercase until \\E . See also \l, lc.
+\\U Upcase until \\E . See also \u, uc.
+\\Q Quote metacharacters until \\E . See also quotemeta.
+\\a Alarm character (octal 007).
+\\b Backspace character (octal 010).
+\\c Control character, e.g. \\c[ .
+\\e Escape character (octal 033).
+\\f Formfeed character (octal 014).
+\\l Lowercase the next character. See also \\L and \\u, lcfirst.
+\\n Newline character (octal 012 on most systems).
+\\r Return character (octal 015 on most systems).
+\\t Tab character (octal 011).
+\\u Upcase the next character. See also \\U and \\l, ucfirst.
+\\x Hex character, e.g. \\x1b.
+... ^ ... Bitwise exclusive or.
+__END__ Ends program source.
+__DATA__ Ends program source.
+__FILE__ Current (source) filename.
+__LINE__ Current line in current source.
+__PACKAGE__ Current package.
+ARGV Default multi-file input filehandle. <ARGV> is a synonym for <>.
+ARGVOUT Output filehandle with -i flag.
+BEGIN { ... } Immediately executed (during compilation) piece of code.
+END { ... } Pseudo-subroutine executed after the script finishes.
+DATA Input filehandle for what follows after __END__ or __DATA__.
+accept(NEWSOCKET,GENERICSOCKET)
+alarm(SECONDS)
+atan2(X,Y)
+bind(SOCKET,NAME)
+binmode(FILEHANDLE)
+caller[(LEVEL)]
+chdir(EXPR)
+chmod(LIST)
+chop[(LIST|VAR)]
+chown(LIST)
+chroot(FILENAME)
+close(FILEHANDLE)
+closedir(DIRHANDLE)
+... cmp ... String compare.
+connect(SOCKET,NAME)
+continue of { block } continue { block }. Is executed after `next' or at end.
+cos(EXPR)
+crypt(PLAINTEXT,SALT)
+dbmclose(%HASH)
+dbmopen(%HASH,DBNAME,MODE)
+defined(EXPR)
+delete($HASH{KEY})
+die(LIST)
+do { ... }|SUBR while|until EXPR executes at least once
+do(EXPR|SUBR([LIST])) (with while|until executes at least once)
+dump LABEL
+each(%HASH)
+endgrent
+endhostent
+endnetent
+endprotoent
+endpwent
+endservent
+eof[([FILEHANDLE])]
+... eq ... String equality.
+eval(EXPR) or eval { BLOCK }
+exec(LIST)
+exit(EXPR)
+exp(EXPR)
+fcntl(FILEHANDLE,FUNCTION,SCALAR)
+fileno(FILEHANDLE)
+flock(FILEHANDLE,OPERATION)
+for (EXPR;EXPR;EXPR) { ... }
+foreach [VAR] (@ARRAY) { ... }
+fork
+... ge ... String greater than or equal.
+getc[(FILEHANDLE)]
+getgrent
+getgrgid(GID)
+getgrnam(NAME)
+gethostbyaddr(ADDR,ADDRTYPE)
+gethostbyname(NAME)
+gethostent
+getlogin
+getnetbyaddr(ADDR,ADDRTYPE)
+getnetbyname(NAME)
+getnetent
+getpeername(SOCKET)
+getpgrp(PID)
+getppid
+getpriority(WHICH,WHO)
+getprotobyname(NAME)
+getprotobynumber(NUMBER)
+getprotoent
+getpwent
+getpwnam(NAME)
+getpwuid(UID)
+getservbyname(NAME,PROTO)
+getservbyport(PORT,PROTO)
+getservent
+getsockname(SOCKET)
+getsockopt(SOCKET,LEVEL,OPTNAME)
+gmtime(EXPR)
+goto LABEL
+grep(EXPR,LIST)
+... gt ... String greater than.
+hex(EXPR)
+if (EXPR) { ... } [ elsif (EXPR) { ... } ... ] [ else { ... } ] or EXPR if EXPR
+index(STR,SUBSTR[,OFFSET])
+int(EXPR)
+ioctl(FILEHANDLE,FUNCTION,SCALAR)
+join(EXPR,LIST)
+keys(%HASH)
+kill(LIST)
+last [LABEL]
+... le ... String less than or equal.
+length(EXPR)
+link(OLDFILE,NEWFILE)
+listen(SOCKET,QUEUESIZE)
+local(LIST)
+localtime(EXPR)
+log(EXPR)
+lstat(EXPR|FILEHANDLE|VAR)
+... lt ... String less than.
+m/PATTERN/iogsmx
+mkdir(FILENAME,MODE)
+msgctl(ID,CMD,ARG)
+msgget(KEY,FLAGS)
+msgrcv(ID,VAR,SIZE,TYPE.FLAGS)
+msgsnd(ID,MSG,FLAGS)
+my VAR or my (VAR1,...) Introduces a lexical variable ($VAR, @ARR, or %HASH).
+... ne ... String inequality.
+next [LABEL]
+oct(EXPR)
+open(FILEHANDLE[,EXPR])
+opendir(DIRHANDLE,EXPR)
+ord(EXPR) ASCII value of the first char of the string.
+pack(TEMPLATE,LIST)
+package NAME Introduces package context.
+pipe(READHANDLE,WRITEHANDLE) Create a pair of filehandles on ends of a pipe.
+pop(ARRAY)
+print [FILEHANDLE] [(LIST)]
+printf [FILEHANDLE] (FORMAT,LIST)
+push(ARRAY,LIST)
+q/STRING/ Synonym for 'STRING'
+qq/STRING/ Synonym for \"STRING\"
+qx/STRING/ Synonym for `STRING`
+rand[(EXPR)]
+read(FILEHANDLE,SCALAR,LENGTH[,OFFSET])
+readdir(DIRHANDLE)
+readlink(EXPR)
+recv(SOCKET,SCALAR,LEN,FLAGS)
+redo [LABEL]
+rename(OLDNAME,NEWNAME)
+require [FILENAME | PERL_VERSION]
+reset[(EXPR)]
+return(LIST)
+reverse(LIST)
+rewinddir(DIRHANDLE)
+rindex(STR,SUBSTR[,OFFSET])
+rmdir(FILENAME)
+s/PATTERN/REPLACEMENT/gieoxsm
+scalar(EXPR)
+seek(FILEHANDLE,POSITION,WHENCE)
+seekdir(DIRHANDLE,POS)
+select(FILEHANDLE | RBITS,WBITS,EBITS,TIMEOUT)
+semctl(ID,SEMNUM,CMD,ARG)
+semget(KEY,NSEMS,SIZE,FLAGS)
+semop(KEY,...)
+send(SOCKET,MSG,FLAGS[,TO])
+setgrent
+sethostent(STAYOPEN)
+setnetent(STAYOPEN)
+setpgrp(PID,PGRP)
+setpriority(WHICH,WHO,PRIORITY)
+setprotoent(STAYOPEN)
+setpwent
+setservent(STAYOPEN)
+setsockopt(SOCKET,LEVEL,OPTNAME,OPTVAL)
+shift[(ARRAY)]
+shmctl(ID,CMD,ARG)
+shmget(KEY,SIZE,FLAGS)
+shmread(ID,VAR,POS,SIZE)
+shmwrite(ID,STRING,POS,SIZE)
+shutdown(SOCKET,HOW)
+sin(EXPR)
+sleep[(EXPR)]
+socket(SOCKET,DOMAIN,TYPE,PROTOCOL)
+socketpair(SOCKET1,SOCKET2,DOMAIN,TYPE,PROTOCOL)
+sort [SUBROUTINE] (LIST)
+splice(ARRAY,OFFSET[,LENGTH[,LIST]])
+split[(/PATTERN/[,EXPR[,LIMIT]])]
+sprintf(FORMAT,LIST)
+sqrt(EXPR)
+srand(EXPR)
+stat(EXPR|FILEHANDLE|VAR)
+study[(SCALAR)]
+sub [NAME [(format)]] { BODY } sub NAME [(format)]; sub [(format)] {...}
+substr(EXPR,OFFSET[,LEN])
+symlink(OLDFILE,NEWFILE)
+syscall(LIST)
+sysread(FILEHANDLE,SCALAR,LENGTH[,OFFSET])
+system(LIST)
+syswrite(FILEHANDLE,SCALAR,LENGTH[,OFFSET])
+tell[(FILEHANDLE)]
+telldir(DIRHANDLE)
+time
+times
+tr/SEARCHLIST/REPLACEMENTLIST/cds
+truncate(FILE|EXPR,LENGTH)
+umask[(EXPR)]
+undef[(EXPR)]
+unless (EXPR) { ... } [ else { ... } ] or EXPR unless EXPR
+unlink(LIST)
+unpack(TEMPLATE,EXPR)
+unshift(ARRAY,LIST)
+until (EXPR) { ... } EXPR until EXPR
+utime(LIST)
+values(%HASH)
+vec(EXPR,OFFSET,BITS)
+wait
+waitpid(PID,FLAGS)
+wantarray Returns true if the sub/eval is called in list context.
+warn(LIST)
+while (EXPR) { ... } EXPR while EXPR
+write[(EXPR|FILEHANDLE)]
+... x ... Repeat string or array.
+x= ... Repetition assignment.
+y/SEARCHLIST/REPLACEMENTLIST/
+... | ... Bitwise or.
+... || ... Logical or.
+~ ... Unary bitwise complement.
+#! OS interpreter indicator. If contains `perl', used for options, and -x.
+AUTOLOAD {...} Shorthand for `sub AUTOLOAD {...}'.
+CORE:: Prefix to access builtin function if imported sub obscures it.
+SUPER:: Prefix to lookup for a method in @ISA classes.
+DESTROY Shorthand for `sub DESTROY {...}'.
+... EQ ... Obsolete synonym of `eq'.
+... GE ... Obsolete synonym of `ge'.
+... GT ... Obsolete synonym of `gt'.
+... LE ... Obsolete synonym of `le'.
+... LT ... Obsolete synonym of `lt'.
+... NE ... Obsolete synonym of `ne'.
+abs [ EXPR ] absolute value
+... and ... Low-precedence synonym for &&.
+bless REFERENCE [, PACKAGE] Makes reference into an object of a package.
+chomp [LIST] Strips $/ off LIST/$_. Returns count. Special if $/ eq ''!
+chr Converts a number to char with the same ordinal.
+else Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
+elsif Part of if/unless {BLOCK} elsif {BLOCK} else {BLOCK}.
+exists $HASH{KEY} True if the key exists.
+format [NAME] = Start of output format. Ended by a single dot (.) on a line.
+formline PICTURE, LIST Backdoor into \"format\" processing.
+glob EXPR Synonym of <EXPR>.
+lc [ EXPR ] Returns lowercased EXPR.
+lcfirst [ EXPR ] Returns EXPR with lower-cased first letter.
+map EXPR, LIST or map {BLOCK} LIST Applies EXPR/BLOCK to elts of LIST.
+no PACKAGE [SYMBOL1, ...] Partial reverse for `use'. Runs `unimport' method.
+not ... Low-precedence synonym for ! - negation.
+... or ... Low-precedence synonym for ||.
+pos STRING Set/Get end-position of the last match over this string, see \\G.
+quotemeta [ EXPR ] Quote regexp metacharacters.
+qw/WORD1 .../ Synonym of split('', 'WORD1 ...')
+readline FH Synonym of <FH>.
+readpipe CMD Synonym of `CMD`.
+ref [ EXPR ] Type of EXPR when dereferenced.
+sysopen FH, FILENAME, MODE [, PERM] (MODE is numeric, see Fcntl.)
+tie VAR, PACKAGE, LIST Hide an object behind a simple Perl variable.
+tied Returns internal object for a tied data.
+uc [ EXPR ] Returns upcased EXPR.
+ucfirst [ EXPR ] Returns EXPR with upcased first letter.
+untie VAR Unlink an object from a simple Perl variable.
+use PACKAGE [SYMBOL1, ...] Compile-time `require' with consequent `import'.
+... xor ... Low-precedence synonym for exclusive or.
+prototype \&SUB Returns prototype of the function given a reference.
+=head1 Top-level heading.
+=head2 Second-level heading.
+=head3 Third-level heading (is there such?).
+=over [ NUMBER ] Start list.
+=item [ TITLE ] Start new item in the list.
+=back End list.
+=cut Switch from POD to Perl.
+=pod Switch from Perl to POD.
+")
+
+(defun cperl-switch-to-doc-buffer ()
+ "Go to the perl documentation buffer and insert the documentation."
+ (interactive)
+ (let ((buf (get-buffer-create cperl-doc-buffer)))
+ (if (interactive-p)
+ (switch-to-buffer-other-window buf)
+ (set-buffer buf))
+ (if (= (buffer-size) 0)
+ (progn
+ (insert (documentation-property 'cperl-short-docs
+ 'variable-documentation))
+ (setq buffer-read-only t)))))
+
+(defun cperl-beautify-regexp-piece (b e embed)
+ ;; b is before the starting delimiter, e before the ending
+ ;; e should be a marker, may be changed, but remains "correct".
+ (let (s c tmp (m (make-marker)) (m1 (make-marker)) c1 spaces inline code)
+ (if (not embed)
+ (goto-char (1+ b))
+ (goto-char b)
+ (cond ((looking-at "(\\?\\\\#") ; badly commented (?#)
+ (forward-char 2)
+ (delete-char 1)
+ (forward-char 1))
+ ((looking-at "(\\?[^a-zA-Z]")
+ (forward-char 3))
+ ((looking-at "(\\?") ; (?i)
+ (forward-char 2))
+ (t
+ (forward-char 1))))
+ (setq c (if embed (current-indentation) (1- (current-column)))
+ c1 (+ c (or cperl-regexp-indent-step cperl-indent-level)))
+ (or (looking-at "[ \t]*[\n#]")
+ (progn
+ (insert "\n")))
+ (goto-char e)
+ (beginning-of-line)
+ (if (re-search-forward "[^ \t]" e t)
+ (progn
+ (goto-char e)
+ (insert "\n")
+ (indent-to-column c)
+ (set-marker e (point))))
+ (goto-char b)
+ (end-of-line 2)
+ (while (< (point) (marker-position e))
+ (beginning-of-line)
+ (setq s (point)
+ inline t)
+ (skip-chars-forward " \t")
+ (delete-region s (point))
+ (indent-to-column c1)
+ (while (and
+ inline
+ (looking-at
+ (concat "\\([a-zA-Z0-9]+[^*+{?]\\)" ; 1 word
+ "\\|" ; Embedded variable
+ "\\$\\([a-zA-Z0-9_]+\\([[{]\\)?\\|[^\n \t)|]\\)" ; 2 3
+ "\\|" ; $ ^
+ "[$^]"
+ "\\|" ; simple-code simple-code*?
+ "\\(\\\\.\\|[^][()#|*+?\n]\\)\\([*+{?]\\??\\)?" ; 4 5
+ "\\|" ; Class
+ "\\(\\[\\)" ; 6
+ "\\|" ; Grouping
+ "\\((\\(\\?\\)?\\)" ; 7 8
+ "\\|" ; |
+ "\\(|\\)" ; 9
+ )))
+ (goto-char (match-end 0))
+ (setq spaces t)
+ (cond ((match-beginning 1) ; Alphanum word + junk
+ (forward-char -1))
+ ((or (match-beginning 3) ; $ab[12]
+ (and (match-beginning 5) ; X* X+ X{2,3}
+ (eq (preceding-char) ?\{)))
+ (forward-char -1)
+ (forward-sexp 1))
+ ((match-beginning 6) ; []
+ (setq tmp (point))
+ (if (looking-at "\\^?\\]")
+ (goto-char (match-end 0)))
+ (or (re-search-forward "\\]\\([*+{?]\\)?" e t)
+ (progn
+ (goto-char (1- tmp))
+ (error "[]-group not terminated")))
+ (if (not (eq (preceding-char) ?\{)) nil
+ (forward-char -1)
+ (forward-sexp 1)))
+ ((match-beginning 7) ; ()
+ (goto-char (match-beginning 0))
+ (or (eq (current-column) c1)
+ (progn
+ (insert "\n")
+ (indent-to-column c1)))
+ (setq tmp (point))
+ (forward-sexp 1)
+ ;; (or (forward-sexp 1)
+ ;; (progn
+ ;; (goto-char tmp)
+ ;; (error "()-group not terminated")))
+ (set-marker m (1- (point)))
+ (set-marker m1 (point))
+ (cond
+ ((not (match-beginning 8))
+ (cperl-beautify-regexp-piece tmp m t))
+ ((eq (char-after (+ 2 tmp)) ?\{) ; Code
+ t)
+ ((eq (char-after (+ 2 tmp)) ?\() ; Conditional
+ (goto-char (+ 2 tmp))
+ (forward-sexp 1)
+ (cperl-beautify-regexp-piece (point) m t))
+ (t
+ (cperl-beautify-regexp-piece tmp m t)))
+ (goto-char m1)
+ (cond ((looking-at "[*+?]\\??")
+ (goto-char (match-end 0)))
+ ((eq (following-char) ?\{)
+ (forward-sexp 1)
+ (if (eq (following-char) ?\?)
+ (forward-char))))
+ (skip-chars-forward " \t")
+ (setq spaces nil)
+ (if (looking-at "[#\n]")
+ (progn
+ (or (eolp) (indent-for-comment))
+ (beginning-of-line 2))
+ (insert "\n"))
+ (end-of-line)
+ (setq inline nil))
+ ((match-beginning 9) ; |
+ (forward-char -1)
+ (setq tmp (point))
+ (beginning-of-line)
+ (if (re-search-forward "[^ \t]" tmp t)
+ (progn
+ (goto-char tmp)
+ (insert "\n"))
+ ;; first at line
+ (delete-region (point) tmp))
+ (indent-to-column c)
+ (forward-char 1)
+ (skip-chars-forward " \t")
+ (setq spaces nil)
+ (if (looking-at "[#\n]")
+ (beginning-of-line 2)
+ (insert "\n"))
+ (end-of-line)
+ (setq inline nil)))
+ (or (looking-at "[ \t\n]")
+ (not spaces)
+ (insert " "))
+ (skip-chars-forward " \t"))
+ (or (looking-at "[#\n]")
+ (error "unknown code \"%s\" in a regexp" (buffer-substring (point)
+ (1+ (point)))))
+ (and inline (end-of-line 2)))
+ ;; Special-case the last line of group
+ (if (and (>= (point) (marker-position e))
+ (/= (current-indentation) c))
+ (progn
+ (beginning-of-line)
+ (setq s (point))
+ (skip-chars-forward " \t")
+ (delete-region s (point))
+ (indent-to-column c)))
+ ))
+
+(defun cperl-make-regexp-x ()
+ (save-excursion
+ (or cperl-use-syntax-table-text-property
+ (error "I need to have regex marked!"))
+ ;; Find the start
+ (re-search-backward "\\s|") ; Assume it is scanned already.
+ ;;(forward-char 1)
+ (let ((b (point)) (e (make-marker)) have-x delim (c (current-column))
+ (sub-p (eq (preceding-char) ?s)) s)
+ (forward-sexp 1)
+ (set-marker e (1- (point)))
+ (setq delim (preceding-char))
+ (if (and sub-p (eq delim (char-after (- (point) 2))))
+ (error "Possible s/blah// - do not know how to deal with"))
+ (if sub-p (forward-sexp 1))
+ (if (looking-at "\\sw*x")
+ (setq have-x t)
+ (insert "x"))
+ ;; Protect fragile " ", "#"
+ (if have-x nil
+ (goto-char (1+ b))
+ (while (re-search-forward "\\(\\=\\|[^\\\\]\\)\\(\\\\\\\\\\)*[ \t\n#]" e t) ; Need to include (?#) too?
+ (forward-char -1)
+ (insert "\\")
+ (forward-char 1)))
+ b)))
+
+(defun cperl-beautify-regexp ()
+ "do it. (Experimental, may change semantics, recheck the result.)
+We suppose that the regexp is scanned already."
+ (interactive)
+ (cperl-make-regexp-x)
+ (re-search-backward "\\s|") ; Assume it is scanned already.
+ ;;(forward-char 1)
+ (let ((b (point)) (e (make-marker)))
+ (forward-sexp 1)
+ (set-marker e (1- (point)))
+ (cperl-beautify-regexp-piece b e nil)))
+
+(defun cperl-contract-level ()
+ "Find an enclosing group in regexp and contract it. (Experimental, may change semantics, recheck the result.) Unfinished.
+We suppose that the regexp is scanned already."
+ (interactive)
+ (let ((bb (cperl-make-regexp-x)) done)
+ (while (not done)
+ (or (eq (following-char) ?\()
+ (search-backward "(" (1+ bb) t)
+ (error "Cannot find `(' which starts a group"))
+ (setq done
+ (save-excursion
+ (skip-chars-backward "\\")
+ (looking-at "\\(\\\\\\\\\\)*(")))
+ (or done (forward-char -1)))
+ (let ((b (point)) (e (make-marker)) s c)
+ (forward-sexp 1)
+ (set-marker e (1- (point)))
+ (goto-char b)
+ (while (re-search-forward "\\(#\\)\\|\n" e t)
+ (cond
+ ((match-beginning 1) ; #-comment
+ (or c (setq c (current-indentation)))
+ (beginning-of-line 2) ; Skip
+ (setq s (point))
+ (skip-chars-forward " \t")
+ (delete-region s (point))
+ (indent-to-column c))
+ (t
+ (delete-char -1)
+ (just-one-space)))))))
+
+(defun cperl-beautify-level ()
+ "Find an enclosing group in regexp and beautify it. (Experimental, may change semantics, recheck the result.)
+We suppose that the regexp is scanned already."
+ (interactive)
+ (let ((bb (cperl-make-regexp-x)) done)
+ (while (not done)
+ (or (eq (following-char) ?\()
+ (search-backward "(" (1+ bb) t)
+ (error "Cannot find `(' which starts a group"))
+ (setq done
+ (save-excursion
+ (skip-chars-backward "\\")
+ (looking-at "\\(\\\\\\\\\\)*(")))
+ (or done (forward-char -1)))
+ (let ((b (point)) (e (make-marker)))
+ (forward-sexp 1)
+ (set-marker e (1- (point)))
+ (cperl-beautify-regexp-piece b e nil))))
+
+(if (fboundp 'run-with-idle-timer)
+ (progn
+ (defvar cperl-help-shown nil
+ "Non-nil means that the help was already shown now.")
+
+ (defvar cperl-lazy-installed nil
+ "Non-nil means that the lazy-help handlers are installed now.")
+
+ (defun cperl-lazy-install ()
+ (interactive)
+ (make-variable-buffer-local 'cperl-help-shown)
+ (if (and (cperl-val 'cperl-lazy-help-time)
+ (not cperl-lazy-installed))
+ (progn
+ (add-hook 'post-command-hook 'cperl-lazy-hook)
+ (run-with-idle-timer
+ (cperl-val 'cperl-lazy-help-time 1000000 5)
+ t
+ 'cperl-get-help-defer)
+ (setq cperl-lazy-installed t))))
+
+ (defun cperl-lazy-unstall ()
+ (interactive)
+ (remove-hook 'post-command-hook 'cperl-lazy-hook)
+ (cancel-function-timers 'cperl-get-help-defer)
+ (setq cperl-lazy-installed nil))
+
+ (defun cperl-lazy-hook ()
+ (setq cperl-help-shown nil))
+
+ (defun cperl-get-help-defer ()
+ (if (not (eq major-mode 'perl-mode)) nil
+ (let ((cperl-message-on-help-error nil) (cperl-help-from-timer t))
+ (cperl-get-help)
+ (setq cperl-help-shown t))))
+ (cperl-lazy-install)))
+
+(provide 'cperl-mode)
diff --git a/gnu/usr.bin/perl/embed.h b/gnu/usr.bin/perl/embed.h
index bfd73bd7f6d..51e5f406e7a 100644
--- a/gnu/usr.bin/perl/embed.h
+++ b/gnu/usr.bin/perl/embed.h
@@ -1,4 +1,7 @@
-/* This file is derived from global.sym and interp.sym */
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by embed.pl from global.sym, interp.sym,
+ and compat3.sym. Any changes made here will be lost!
+*/
/* (Doing namespace management portably in C is really gross.) */
@@ -12,1378 +15,1647 @@
# define EMBED 1
#endif
+/* Hide global symbols? */
+
#ifdef EMBED
-/* globals we need to hide from the world */
-#define AMG_names Perl_AMG_names
-#define No Perl_No
-#define Sv Perl_Sv
-#define Xpv Perl_Xpv
-#define Yes Perl_Yes
-#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 AMG_names Perl_AMG_names
+#define Gv_AMupdate Perl_Gv_AMupdate
+#define No Perl_No
+#define Sv Perl_Sv
+#define Xpv Perl_Xpv
+#define Yes Perl_Yes
+#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 amagic_generation Perl_amagic_generation
-#define an Perl_an
-#define atan2_amg Perl_atan2_amg
-#define band_amg Perl_band_amg
-#define bool__amg Perl_bool__amg
-#define bor_amg Perl_bor_amg
-#define buf Perl_buf
-#define bufend Perl_bufend
-#define bufptr Perl_bufptr
-#define bxor_amg Perl_bxor_amg
-#define check Perl_check
-#define compiling Perl_compiling
-#define compl_amg Perl_compl_amg
-#define compcv Perl_compcv
-#define comppad Perl_comppad
-#define comppad_name Perl_comppad_name
+#define an Perl_an
+#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 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 bool__amg Perl_bool__amg
+#define bor_amg Perl_bor_amg
+#define bufend Perl_bufend
+#define bufptr Perl_bufptr
+#define bxor_amg Perl_bxor_amg
+#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 collation_ix Perl_collation_ix
+#define collation_name Perl_collation_name
+#define collation_standard Perl_collation_standard
+#define collxfrm_base Perl_collxfrm_base
+#define collxfrm_mult Perl_collxfrm_mult
+#define compcv Perl_compcv
+#define compiling Perl_compiling
+#define compl_amg Perl_compl_amg
+#define comppad Perl_comppad
+#define comppad_name Perl_comppad_name
#define comppad_name_fill Perl_comppad_name_fill
-#define concat_amg Perl_concat_amg
-#define concat_ass_amg Perl_concat_ass_amg
-#define cop_seqmax Perl_cop_seqmax
-#define cos_amg Perl_cos_amg
-#define cryptseen Perl_cryptseen
-#define cshlen Perl_cshlen
-#define cshname Perl_cshname
-#define curcop Perl_curcop
-#define curinterp Perl_curinterp
-#define curpad Perl_curpad
-#define dc Perl_dc
-#define dec_amg Perl_dec_amg
-#define di Perl_di
-#define div_amg Perl_div_amg
-#define div_ass_amg Perl_div_ass_amg
-#define ds Perl_ds
-#define egid Perl_egid
-#define envgv Perl_envgv
-#define eq_amg Perl_eq_amg
-#define error_count Perl_error_count
-#define euid Perl_euid
-#define evalseq Perl_evalseq
-#define exp_amg Perl_exp_amg
-#define expect Perl_expect
-#define expectterm Perl_expectterm
-#define fallback_amg Perl_fallback_amg
-#define filter_add Perl_filter_add
-#define filter_del Perl_filter_del
-#define filter_read Perl_filter_read
-#define fold Perl_fold
-#define freq Perl_freq
-#define ge_amg Perl_ge_amg
-#define gid Perl_gid
-#define gt_amg Perl_gt_amg
-#define hexdigit Perl_hexdigit
-#define hints Perl_hints
-#define in_my Perl_in_my
-#define inc_amg Perl_inc_amg
-#define io_close Perl_io_close
-#define know_next Perl_know_next
-#define last_lop Perl_last_lop
-#define last_lop_op Perl_last_lop_op
-#define last_uni Perl_last_uni
-#define le_amg Perl_le_amg
-#define lex_state Perl_lex_state
-#define lex_defer Perl_lex_defer
-#define lex_expect Perl_lex_expect
-#define lex_brackets Perl_lex_brackets
-#define lex_formbrack Perl_lex_formbrack
-#define lex_fakebrack Perl_lex_fakebrack
-#define lex_casemods Perl_lex_casemods
-#define lex_dojoin Perl_lex_dojoin
-#define lex_starts Perl_lex_starts
-#define lex_stuff Perl_lex_stuff
-#define lex_repl Perl_lex_repl
-#define lex_op Perl_lex_op
-#define lex_inpat Perl_lex_inpat
-#define lex_inwhat Perl_lex_inwhat
-#define lex_brackstack Perl_lex_brackstack
-#define lex_casestack Perl_lex_casestack
-#define linestr Perl_linestr
-#define log_amg Perl_log_amg
-#define lshift_amg Perl_lshift_amg
-#define lshift_ass_amg Perl_lshift_ass_amg
-#define lt_amg Perl_lt_amg
-#define markstack Perl_markstack
-#define markstack_max Perl_markstack_max
-#define markstack_ptr Perl_markstack_ptr
-#define maxo Perl_maxo
-#define max_intro_pending Perl_max_intro_pending
-#define min_intro_pending Perl_min_intro_pending
-#define mod_amg Perl_mod_amg
-#define mod_ass_amg Perl_mod_ass_amg
-#define mult_amg Perl_mult_amg
-#define mult_ass_amg Perl_mult_ass_amg
-#define multi_close Perl_multi_close
-#define multi_end Perl_multi_end
-#define multi_open Perl_multi_open
-#define multi_start Perl_multi_start
-#define na Perl_na
-#define ncmp_amg Perl_ncmp_amg
-#define nextval Perl_nextval
-#define nexttype Perl_nexttype
-#define nexttoke Perl_nexttoke
-#define ne_amg Perl_ne_amg
-#define neg_amg Perl_neg_amg
-#define nexttype Perl_nexttype
-#define nextval Perl_nextval
-#define no_aelem Perl_no_aelem
-#define no_dir_func Perl_no_dir_func
-#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_security Perl_no_security
-#define no_sock_func Perl_no_sock_func
-#define no_usym Perl_no_usym
-#define nointrp Perl_nointrp
-#define nomem Perl_nomem
-#define nomemok Perl_nomemok
-#define nomethod_amg Perl_nomethod_amg
-#define not_amg Perl_not_amg
-#define numer_amg Perl_numer_amg
-#define oldbufptr Perl_oldbufptr
-#define oldoldbufptr Perl_oldoldbufptr
-#define op Perl_op
-#define op_desc Perl_op_desc
-#define op_name Perl_op_name
-#define op_seqmax Perl_op_seqmax
-#define opargs Perl_opargs
-#define origalen Perl_origalen
-#define origenviron Perl_origenviron
-#define osname Perl_osname
-#define padix Perl_padix
-#define patleave Perl_patleave
-#define pow_amg Perl_pow_amg
-#define pow_ass_amg Perl_pow_ass_amg
-#define ppaddr Perl_ppaddr
-#define profiledata Perl_profiledata
-#define provide_ref Perl_provide_ref
-#define qrt_amg Perl_qrt_amg
-#define rcsid Perl_rcsid
-#define reall_srchlen Perl_reall_srchlen
-#define regarglen Perl_regarglen
-#define regbol Perl_regbol
-#define regcode Perl_regcode
-#define regdummy Perl_regdummy
-#define regendp Perl_regendp
-#define regeol Perl_regeol
-#define regfold Perl_regfold
-#define reginput Perl_reginput
-#define regkind Perl_regkind
-#define reglastparen Perl_reglastparen
-#define regmyendp Perl_regmyendp
-#define regmyp_size Perl_regmyp_size
-#define regmystartp Perl_regmystartp
-#define regnarrate Perl_regnarrate
-#define regnaughty Perl_regnaughty
-#define regnpar Perl_regnpar
-#define regparse Perl_regparse
-#define regprecomp Perl_regprecomp
-#define regprev Perl_regprev
-#define regsawback Perl_regsawback
-#define regsize Perl_regsize
-#define regstartp Perl_regstartp
-#define regtill Perl_regtill
-#define regxend Perl_regxend
-#define repeat_amg Perl_repeat_amg
-#define repeat_ass_amg Perl_repeat_ass_amg
-#define retstack Perl_retstack
-#define retstack_ix Perl_retstack_ix
-#define retstack_max Perl_retstack_max
-#define rsfp Perl_rsfp
-#define rsfp_filters Perl_rsfp_filters
-#define rshift_amg Perl_rshift_amg
-#define rshift_ass_amg Perl_rshift_ass_amg
-#define save_pptr Perl_save_pptr
-#define savestack Perl_savestack
-#define savestack_ix Perl_savestack_ix
-#define savestack_max Perl_savestack_max
-#define saw_return Perl_saw_return
-#define scmp_amg Perl_scmp_amg
-#define scopestack Perl_scopestack
-#define scopestack_ix Perl_scopestack_ix
-#define scopestack_max Perl_scopestack_max
-#define scrgv Perl_scrgv
-#define seq_amg Perl_seq_amg
-#define sge_amg Perl_sge_amg
-#define sgt_amg Perl_sgt_amg
-#define sig_name Perl_sig_name
-#define sig_num Perl_sig_num
-#define siggv Perl_siggv
-#define sighandler Perl_sighandler
-#define simple Perl_simple
-#define sin_amg Perl_sin_amg
-#define sle_amg Perl_sle_amg
-#define slt_amg Perl_slt_amg
-#define sne_amg Perl_sne_amg
-#define stack Perl_stack
-#define stack_base Perl_stack_base
-#define stack_max Perl_stack_max
-#define stack_sp Perl_stack_sp
-#define statbuf Perl_statbuf
-#define string_amg Perl_string_amg
-#define sub_generation Perl_sub_generation
-#define subline Perl_subline
-#define subname Perl_subname
-#define subtr_amg Perl_subtr_amg
-#define subtr_ass_amg Perl_subtr_ass_amg
-#define sv_no Perl_sv_no
-#define sv_undef Perl_sv_undef
-#define sv_yes Perl_sv_yes
-#define tainting Perl_tainting
-#define thisexpr Perl_thisexpr
-#define timesbuf Perl_timesbuf
-#define tokenbuf Perl_tokenbuf
-#define uid Perl_uid
-#define varies Perl_varies
-#define vert Perl_vert
-#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_dbline Perl_vtbl_dbline
-#define vtbl_env Perl_vtbl_env
-#define vtbl_envelem Perl_vtbl_envelem
-#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_pack Perl_vtbl_pack
-#define vtbl_packelem Perl_vtbl_packelem
-#define vtbl_pos Perl_vtbl_pos
-#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 warn_nl Perl_warn_nl
-#define warn_nosemi Perl_warn_nosemi
-#define warn_reserved Perl_warn_reserved
-#define watchaddr Perl_watchaddr
-#define watchok Perl_watchok
-#define yychar Perl_yychar
-#define yycheck Perl_yycheck
-#define yydebug Perl_yydebug
-#define yydefred Perl_yydefred
-#define yydgoto Perl_yydgoto
-#define yyerrflag Perl_yyerrflag
-#define yygindex Perl_yygindex
-#define yylen Perl_yylen
-#define yylhs Perl_yylhs
-#define yylval Perl_yylval
-#define yyname Perl_yyname
-#define yynerrs Perl_yynerrs
-#define yyrindex Perl_yyrindex
-#define yyrule Perl_yyrule
-#define yysindex Perl_yysindex
-#define yytable Perl_yytable
-#define yyval Perl_yyval
-#define Gv_AMupdate Perl_Gv_AMupdate
-#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 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_shift Perl_av_shift
-#define av_store Perl_av_store
-#define av_undef Perl_av_undef
-#define av_unshift Perl_av_unshift
-#define bind_match Perl_bind_match
-#define block_end Perl_block_end
-#define block_start Perl_block_start
-#define calllist Perl_calllist
-#define cando Perl_cando
-#define cast_ulong Perl_cast_ulong
-#define check_uni Perl_check_uni
-#define checkcomma Perl_checkcomma
-#define chsize Perl_chsize
-#define ck_aelem Perl_ck_aelem
-#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_formline Perl_ck_formline
-#define ck_ftst Perl_ck_ftst
-#define ck_fun Perl_ck_fun
-#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_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 convert Perl_convert
-#define cpytill Perl_cpytill
-#define croak Perl_croak
-#define cv_clone Perl_cv_clone
-#define cv_undef Perl_cv_undef
-#define cx_dump Perl_cx_dump
-#define cxinc Perl_cxinc
-#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 deprecate Perl_deprecate
-#define die Perl_die
-#define die_where Perl_die_where
-#define do_aexec Perl_do_aexec
-#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_tell Perl_do_tell
-#define do_trans Perl_do_trans
-#define do_vecset Perl_do_vecset
-#define do_vop Perl_do_vop
-#define doeval Perl_doeval
-#define dofindlabel Perl_dofindlabel
-#define dopoptoeval Perl_dopoptoeval
-#define dounwind Perl_dounwind
-#define dowantarray Perl_dowantarray
-#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 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 fold_constants Perl_fold_constants
-#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 free_tmps Perl_free_tmps
+#define concat_amg Perl_concat_amg
+#define concat_ass_amg Perl_concat_ass_amg
+#define convert Perl_convert
+#define cop_seqmax Perl_cop_seqmax
+#define cos_amg Perl_cos_amg
+#define croak Perl_croak
+#define cryptseen Perl_cryptseen
+#define cshlen Perl_cshlen
+#define cshname Perl_cshname
+#define curinterp Perl_curinterp
+#define curpad Perl_curpad
+#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_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 doeval Perl_doeval
+#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 egid Perl_egid
+#define eq_amg Perl_eq_amg
+#define error_count Perl_error_count
+#define euid Perl_euid
+#define evalseq Perl_evalseq
+#define exp_amg Perl_exp_amg
+#define expect Perl_expect
+#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 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 gp_free Perl_gp_free
-#define gp_ref Perl_gp_ref
-#define gv_AVadd Perl_gv_AVadd
-#define gv_HVadd Perl_gv_HVadd
-#define gv_IOadd Perl_gv_IOadd
-#define gv_check Perl_gv_check
-#define gv_efullname Perl_gv_efullname
-#define gv_fetchfile Perl_gv_fetchfile
-#define gv_fetchmeth Perl_gv_fetchmeth
-#define gv_fetchmethod Perl_gv_fetchmethod
-#define gv_fetchpv Perl_gv_fetchpv
-#define gv_fullname Perl_gv_fullname
-#define gv_init Perl_gv_init
-#define gv_stashpv Perl_gv_stashpv
-#define gv_stashsv Perl_gv_stashsv
-#define he_delayfree Perl_he_delayfree
-#define he_free Perl_he_free
-#define he_root Perl_he_root
-#define hoistmust Perl_hoistmust
-#define hv_clear Perl_hv_clear
-#define hv_delete Perl_hv_delete
-#define hv_exists Perl_hv_exists
-#define hv_fetch Perl_hv_fetch
-#define hv_iterinit Perl_hv_iterinit
-#define hv_iterkey Perl_hv_iterkey
-#define hv_iternext Perl_hv_iternext
-#define hv_iternextsv Perl_hv_iternextsv
-#define hv_iterval Perl_hv_iterval
-#define hv_magic Perl_hv_magic
-#define hv_stashpv Perl_hv_stashpv
-#define hv_store Perl_hv_store
-#define hv_undef Perl_hv_undef
-#define ibcmp Perl_ibcmp
-#define ingroup Perl_ingroup
-#define instr Perl_instr
-#define intuit_more Perl_intuit_more
-#define invert Perl_invert
-#define jmaybe Perl_jmaybe
-#define keyword Perl_keyword
-#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 gid Perl_gid
+#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 he_root Perl_he_root
+#define hexdigit Perl_hexdigit
+#define hints Perl_hints
+#define hoistmust Perl_hoistmust
+#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 in_my Perl_in_my
+#define inc_amg Perl_inc_amg
+#define ingroup Perl_ingroup
+#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 last_lop Perl_last_lop
+#define last_lop_op Perl_last_lop_op
+#define last_uni Perl_last_uni
+#define le_amg Perl_le_amg
+#define leave_scope Perl_leave_scope
+#define lex_brackets Perl_lex_brackets
+#define lex_brackstack Perl_lex_brackstack
+#define lex_casemods Perl_lex_casemods
+#define lex_casestack Perl_lex_casestack
+#define lex_defer Perl_lex_defer
+#define lex_dojoin Perl_lex_dojoin
+#define lex_end Perl_lex_end
+#define lex_expect Perl_lex_expect
+#define lex_fakebrack Perl_lex_fakebrack
+#define lex_formbrack Perl_lex_formbrack
+#define lex_inpat Perl_lex_inpat
+#define lex_inwhat Perl_lex_inwhat
+#define lex_op Perl_lex_op
+#define lex_repl Perl_lex_repl
+#define lex_start Perl_lex_start
+#define lex_starts Perl_lex_starts
+#define lex_state Perl_lex_state
+#define lex_stuff Perl_lex_stuff
+#define linestr Perl_linestr
+#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 magic_clearenv Perl_magic_clearenv
-#define magic_clearpack Perl_magic_clearpack
+#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_get Perl_magic_get
-#define magic_getarylen Perl_magic_getarylen
-#define magic_getglob Perl_magic_getglob
-#define magic_getpack Perl_magic_getpack
-#define magic_getpos Perl_magic_getpos
-#define magic_gettaint Perl_magic_gettaint
-#define magic_getuvar Perl_magic_getuvar
-#define magic_len Perl_magic_len
-#define magic_nextpack Perl_magic_nextpack
-#define magic_set Perl_magic_set
-#define magic_setamagic Perl_magic_setamagic
-#define magic_setarylen Perl_magic_setarylen
-#define magic_setbm Perl_magic_setbm
-#define magic_setdbline Perl_magic_setdbline
-#define magic_setenv Perl_magic_setenv
-#define magic_setglob Perl_magic_setglob
-#define magic_setisa Perl_magic_setisa
-#define magic_setmglob Perl_magic_setmglob
-#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_wipepack Perl_magic_wipepack
-#define magicname Perl_magicname
-#define markstack_grow Perl_markstack_grow
-#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_len Perl_mg_len
-#define mg_magical Perl_mg_magical
-#define mg_set Perl_mg_set
-#define mod Perl_mod
-#define modkids Perl_modkids
-#define moreswitches Perl_moreswitches
-#define mstats Perl_mstats
-#define my Perl_my
-#define my_bcopy Perl_my_bcopy
-#define my_bzero Perl_my_bzero
-#define my_exit Perl_my_exit
-#define my_htonl Perl_my_htonl
-#define my_lstat Perl_my_lstat
-#define my_memcmp Perl_my_memcmp
-#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 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 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 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 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 newSVrv Perl_newSVrv
-#define newSVsv Perl_newSVsv
-#define newUNOP Perl_newUNOP
-#define newWHILEOP Perl_newWHILEOP
-#define newXS Perl_newXS
-#define newXSUB Perl_newXSUB
-#define nextargv Perl_nextargv
-#define ninstr Perl_ninstr
-#define no_fh_allowed Perl_no_fh_allowed
-#define no_op Perl_no_op
-#define oopsAV Perl_oopsAV
-#define oopsCV Perl_oopsCV
-#define oopsHV Perl_oopsHV
-#define op_free Perl_op_free
-#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 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_indread Perl_pp_indread
-#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_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_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_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_system Perl_pp_system
-#define pp_syswrite Perl_pp_syswrite
-#define pp_tell Perl_pp_tell
-#define pp_telldir Perl_pp_telldir
-#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 pregcomp Perl_pregcomp
-#define pregexec Perl_pregexec
-#define pregfree Perl_pregfree
-#define prepend_elem Perl_prepend_elem
-#define push_return Perl_push_return
-#define push_scope Perl_push_scope
-#define q Perl_q
-#define ref Perl_ref
-#define refkids Perl_refkids
-#define regdump Perl_regdump
-#define regnext Perl_regnext
-#define regprop Perl_regprop
-#define repeatcpy Perl_repeatcpy
-#define rninstr Perl_rninstr
-#define runops Perl_runops
-#define same_dirent Perl_same_dirent
-#define save_I32 Perl_save_I32
-#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_hash Perl_save_hash
-#define save_hptr Perl_save_hptr
-#define save_int Perl_save_int
-#define save_item Perl_save_item
-#define save_list Perl_save_list
-#define save_long Perl_save_long
-#define save_nogv Perl_save_nogv
-#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 savepv Perl_savepv
-#define savepvn Perl_savepvn
-#define savestack_grow Perl_savestack_grow
-#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 magic_freedefelem Perl_magic_freedefelem
+#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_getpack Perl_magic_getpack
+#define magic_getpos Perl_magic_getpos
+#define magic_getsig Perl_magic_getsig
+#define magic_gettaint Perl_magic_gettaint
+#define magic_getuvar Perl_magic_getuvar
+#define magic_len Perl_magic_len
+#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_wipepack Perl_magic_wipepack
+#define magicname Perl_magicname
+#define markstack Perl_markstack
+#define markstack_grow Perl_markstack_grow
+#define markstack_max Perl_markstack_max
+#define markstack_ptr Perl_markstack_ptr
+#define max_intro_pending Perl_max_intro_pending
+#define maxo Perl_maxo
+#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_len Perl_mg_len
+#define mg_magical Perl_mg_magical
+#define mg_set Perl_mg_set
+#define min_intro_pending Perl_min_intro_pending
+#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 multi_close Perl_multi_close
+#define multi_end Perl_multi_end
+#define multi_open Perl_multi_open
+#define multi_start Perl_multi_start
+#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 na Perl_na
+#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 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 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 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 newSVrv Perl_newSVrv
+#define newSVsv Perl_newSVsv
+#define newUNOP Perl_newUNOP
+#define newWHILEOP Perl_newWHILEOP
+#define newXS Perl_newXS
+#define newXSUB Perl_newXSUB
+#define nextargv Perl_nextargv
+#define nexttoke Perl_nexttoke
+#define nexttype Perl_nexttype
+#define nextval Perl_nextval
+#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_op Perl_no_op
+#define no_security Perl_no_security
+#define no_sock_func Perl_no_sock_func
+#define no_usym Perl_no_usym
+#define nointrp Perl_nointrp
+#define nomem Perl_nomem
+#define nomemok Perl_nomemok
+#define nomethod_amg Perl_nomethod_amg
+#define not_amg Perl_not_amg
+#define numer_amg Perl_numer_amg
+#define numeric_local Perl_numeric_local
+#define numeric_name Perl_numeric_name
+#define numeric_standard Perl_numeric_standard
+#define oldbufptr Perl_oldbufptr
+#define oldoldbufptr Perl_oldoldbufptr
+#define oopsAV Perl_oopsAV
+#define oopsCV Perl_oopsCV
+#define oopsHV Perl_oopsHV
+#define op Perl_op
+#define op_desc Perl_op_desc
+#define op_free Perl_op_free
+#define op_name Perl_op_name
+#define op_seqmax Perl_op_seqmax
+#define opargs Perl_opargs
+#define origalen Perl_origalen
+#define origenviron Perl_origenviron
+#define osname Perl_osname
+#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 padix Perl_padix
+#define patleave Perl_patleave
+#define peep Perl_peep
+#define pidgone Perl_pidgone
+#define pidstatus Perl_pidstatus
+#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_indread Perl_pp_indread
+#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_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_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_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_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 profiledata Perl_profiledata
+#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 rcsid Perl_rcsid
+#define reall_srchlen Perl_reall_srchlen
+#define ref Perl_ref
+#define refkids Perl_refkids
+#define regarglen Perl_regarglen
+#define regbol Perl_regbol
+#define regcode Perl_regcode
+#define regdummy Perl_regdummy
+#define regdump Perl_regdump
+#define regendp Perl_regendp
+#define regeol Perl_regeol
+#define reginput Perl_reginput
+#define regkind Perl_regkind
+#define reglastparen Perl_reglastparen
+#define regmyendp Perl_regmyendp
+#define regmyp_size Perl_regmyp_size
+#define regmystartp Perl_regmystartp
+#define regnarrate Perl_regnarrate
+#define regnaughty Perl_regnaughty
+#define regnext Perl_regnext
+#define regnpar Perl_regnpar
+#define regparse Perl_regparse
+#define regprecomp Perl_regprecomp
+#define regprev Perl_regprev
+#define regprop Perl_regprop
+#define regsawback Perl_regsawback
+#define regsize Perl_regsize
+#define regstartp Perl_regstartp
+#define regtill Perl_regtill
+#define regxend Perl_regxend
+#define repeat_amg Perl_repeat_amg
+#define repeat_ass_amg Perl_repeat_ass_amg
+#define repeatcpy Perl_repeatcpy
+#define retstack Perl_retstack
+#define retstack_ix Perl_retstack_ix
+#define retstack_max Perl_retstack_max
+#define rninstr Perl_rninstr
+#define rsfp Perl_rsfp
+#define rsfp_filters Perl_rsfp_filters
+#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 Perl_runops
+#define rxres_free Perl_rxres_free
+#define rxres_restore Perl_rxres_restore
+#define rxres_save Perl_rxres_save
+#define same_dirent Perl_same_dirent
+#define save_I16 Perl_save_I16
+#define save_I32 Perl_save_I32
+#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_hptr Perl_save_hptr
+#define save_int Perl_save_int
+#define save_item Perl_save_item
+#define save_list Perl_save_list
+#define save_long Perl_save_long
+#define save_nogv Perl_save_nogv
+#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 savepv Perl_savepv
+#define savepvn Perl_savepvn
+#define savestack Perl_savestack
+#define savestack_grow Perl_savestack_grow
+#define savestack_ix Perl_savestack_ix
+#define savestack_max Perl_savestack_max
+#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 scope Perl_scope
-#define screaminstr Perl_screaminstr
-#define setdefout Perl_setdefout
-#define setenv_getix Perl_setenv_getix
-#define sighandler Perl_sighandler
-#define skipspace Perl_skipspace
-#define stack_grow Perl_stack_grow
-#define start_subparse Perl_start_subparse
-#define sublex_done Perl_sublex_done
-#define sublex_start Perl_sublex_start
-#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_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_catpvn Perl_sv_catpvn
-#define sv_catsv Perl_sv_catsv
-#define sv_chop Perl_sv_chop
-#define sv_clean_all Perl_sv_clean_all
-#define sv_clean_objs Perl_sv_clean_objs
-#define sv_clear Perl_sv_clear
-#define sv_cmp Perl_sv_cmp
-#define sv_dec Perl_sv_dec
-#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_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_peek Perl_sv_peek
-#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_setnv Perl_sv_setnv
-#define sv_setptrobj Perl_sv_setptrobj
-#define sv_setpv Perl_sv_setpv
-#define sv_setpvn Perl_sv_setpvn
-#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_unmagic Perl_sv_unmagic
-#define sv_unref Perl_sv_unref
-#define sv_upgrade Perl_sv_upgrade
-#define sv_usepvn Perl_sv_usepvn
-#define taint_env Perl_taint_env
-#define taint_not Perl_taint_not
-#define taint_proper Perl_taint_proper
+#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 scopestack Perl_scopestack
+#define scopestack_ix Perl_scopestack_ix
+#define scopestack_max Perl_scopestack_max
+#define screaminstr Perl_screaminstr
+#define scrgv Perl_scrgv
+#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 sh_path Perl_sh_path
+#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_base Perl_stack_base
+#define stack_grow Perl_stack_grow
+#define stack_max Perl_stack_max
+#define stack_sp Perl_stack_sp
+#define start_subparse Perl_start_subparse
+#define statbuf Perl_statbuf
+#define string_amg Perl_string_amg
+#define sub_crush_depth Perl_sub_crush_depth
+#define sub_generation Perl_sub_generation
+#define subline Perl_subline
+#define subname Perl_subname
+#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_catpvf Perl_sv_catpvf
+#define sv_catpvn Perl_sv_catpvn
+#define sv_catsv Perl_sv_catsv
+#define sv_chop Perl_sv_chop
+#define sv_clean_all Perl_sv_clean_all
+#define sv_clean_objs Perl_sv_clean_objs
+#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_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_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_no Perl_sv_no
+#define sv_peek Perl_sv_peek
+#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_setnv Perl_sv_setnv
+#define sv_setptrobj Perl_sv_setptrobj
+#define sv_setpv Perl_sv_setpv
+#define sv_setpvf Perl_sv_setpvf
+#define sv_setpviv Perl_sv_setpviv
+#define sv_setpvn Perl_sv_setpvn
+#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_setuv Perl_sv_setuv
+#define sv_taint Perl_sv_taint
+#define sv_tainted Perl_sv_tainted
+#define sv_undef Perl_sv_undef
+#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_vcatpvfn Perl_sv_vcatpvfn
+#define sv_vsetpvfn Perl_sv_vsetpvfn
+#define sv_yes Perl_sv_yes
+#define taint_env Perl_taint_env
+#define taint_proper Perl_taint_proper
+#define thisexpr Perl_thisexpr
+#define timesbuf Perl_timesbuf
+#define tokenbuf Perl_tokenbuf
#define too_few_arguments Perl_too_few_arguments
#define too_many_arguments Perl_too_many_arguments
-#define unlnk Perl_unlnk
-#define utilize Perl_utilize
-#define wait4pid Perl_wait4pid
-#define warn Perl_warn
-#define watch Perl_watch
-#define whichsig Perl_whichsig
-#define xiv_arenaroot Perl_xiv_arenaroot
-#define xiv_root Perl_xiv_root
-#define xnv_root Perl_xnv_root
-#define xpv_root Perl_xpv_root
-#define xrv_root Perl_xrv_root
-#define yyerror Perl_yyerror
-#define yylex Perl_yylex
-#define yyparse Perl_yyparse
-#define yywarn Perl_yywarn
+#define uid Perl_uid
+#define unlnk Perl_unlnk
+#define unshare_hek Perl_unshare_hek
+#define unsharepvn Perl_unsharepvn
+#define utilize Perl_utilize
+#define varies Perl_varies
+#define vert Perl_vert
+#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_nkeys Perl_vtbl_nkeys
+#define vtbl_pack Perl_vtbl_pack
+#define vtbl_packelem Perl_vtbl_packelem
+#define vtbl_pos Perl_vtbl_pos
+#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 watch Perl_watch
+#define watchaddr Perl_watchaddr
+#define watchok Perl_watchok
+#define whichsig Perl_whichsig
+#define xiv_arenaroot Perl_xiv_arenaroot
+#define xiv_root Perl_xiv_root
+#define xnv_root Perl_xnv_root
+#define xpv_root Perl_xpv_root
+#define xrv_root Perl_xrv_root
+#define yychar Perl_yychar
+#define yycheck Perl_yycheck
+#define yydebug Perl_yydebug
+#define yydefred Perl_yydefred
+#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
+
+/* Hide global symbols that 5.003 revealed? */
+
+#ifndef BINCOMPAT3
+
+#define Error Perl_Error
+#define SvIV Perl_SvIV
+#define SvNV Perl_SvNV
+#define SvTRUE Perl_SvTRUE
+#define SvUV Perl_SvUV
+#define block_type Perl_block_type
+#define boot_core_UNIVERSAL Perl_boot_core_UNIVERSAL
+#define comppad_name_floor Perl_comppad_name_floor
+#define debug Perl_debug
+#define do_undump Perl_do_undump
+#define nice_chunk Perl_nice_chunk
+#define nice_chunk_size Perl_nice_chunk_size
+#define no_myglob Perl_no_myglob
+#define no_symref Perl_no_symref
+#define no_wrongref Perl_no_wrongref
+#define pad_reset_pending Perl_pad_reset_pending
+#define padix_floor Perl_padix_floor
+#define regflags Perl_regflags
+#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 save_iv Perl_save_iv
+#define sv_pvn Perl_sv_pvn
+#define warn_uninit Perl_warn_uninit
+#define yydestruct Perl_yydestruct
+
+#endif /* !BINCOMPAT3 */
#endif /* EMBED */
-/* Put interpreter specific symbols into a struct? */
+/* Put interpreter-specific symbols into a struct? */
#ifdef MULTIPLICITY
-#define Argv (curinterp->IArgv)
-#define Cmd (curinterp->ICmd)
-#define DBgv (curinterp->IDBgv)
-#define DBline (curinterp->IDBline)
-#define DBsignal (curinterp->IDBsignal)
-#define DBsingle (curinterp->IDBsingle)
-#define DBsub (curinterp->IDBsub)
-#define DBtrace (curinterp->IDBtrace)
-#define allgvs (curinterp->Iallgvs)
-#define ampergv (curinterp->Iampergv)
-#define argvgv (curinterp->Iargvgv)
-#define argvoutgv (curinterp->Iargvoutgv)
-#define basetime (curinterp->Ibasetime)
-#define beginav (curinterp->Ibeginav)
-#define bodytarget (curinterp->Ibodytarget)
-#define cddir (curinterp->Icddir)
-#define chopset (curinterp->Ichopset)
-#define copline (curinterp->Icopline)
-#define curblock (curinterp->Icurblock)
-#define curcop (curinterp->Icurcop)
-#define curcsv (curinterp->Icurcsv)
-#define curpm (curinterp->Icurpm)
-#define curstash (curinterp->Icurstash)
-#define curstname (curinterp->Icurstname)
-#define cxstack (curinterp->Icxstack)
-#define cxstack_ix (curinterp->Icxstack_ix)
-#define cxstack_max (curinterp->Icxstack_max)
-#define dbargs (curinterp->Idbargs)
-#define debdelim (curinterp->Idebdelim)
-#define debname (curinterp->Idebname)
-#define debstash (curinterp->Idebstash)
-#define debug (curinterp->Idebug)
-#define defgv (curinterp->Idefgv)
-#define defoutgv (curinterp->Idefoutgv)
-#define defstash (curinterp->Idefstash)
-#define delaymagic (curinterp->Idelaymagic)
-#define diehook (curinterp->Idiehook)
-#define dirty (curinterp->Idirty)
-#define dlevel (curinterp->Idlevel)
-#define dlmax (curinterp->Idlmax)
-#define do_undump (curinterp->Ido_undump)
-#define doextract (curinterp->Idoextract)
-#define doswitches (curinterp->Idoswitches)
-#define dowarn (curinterp->Idowarn)
-#define dumplvl (curinterp->Idumplvl)
-#define e_fp (curinterp->Ie_fp)
-#define e_tmpname (curinterp->Ie_tmpname)
-#define endav (curinterp->Iendav)
-#define envgv (curinterp->Ienvgv)
-#define errgv (curinterp->Ierrgv)
-#define eval_root (curinterp->Ieval_root)
-#define eval_start (curinterp->Ieval_start)
-#define fdpid (curinterp->Ifdpid)
-#define filemode (curinterp->Ifilemode)
-#define firstgv (curinterp->Ifirstgv)
-#define forkprocess (curinterp->Iforkprocess)
-#define formfeed (curinterp->Iformfeed)
-#define formtarget (curinterp->Iformtarget)
-#define gensym (curinterp->Igensym)
-#define in_eval (curinterp->Iin_eval)
-#define incgv (curinterp->Iincgv)
-#define inplace (curinterp->Iinplace)
-#define last_in_gv (curinterp->Ilast_in_gv)
-#define lastfd (curinterp->Ilastfd)
-#define lastretstr (curinterp->Ilastretstr)
-#define lastscream (curinterp->Ilastscream)
-#define lastsize (curinterp->Ilastsize)
-#define lastspbase (curinterp->Ilastspbase)
-#define laststatval (curinterp->Ilaststatval)
-#define laststype (curinterp->Ilaststype)
-#define leftgv (curinterp->Ileftgv)
-#define lineary (curinterp->Ilineary)
-#define localizing (curinterp->Ilocalizing)
-#define main_cv (curinterp->Imain_cv)
-#define main_root (curinterp->Imain_root)
-#define main_start (curinterp->Imain_start)
-#define mainstack (curinterp->Imainstack)
-#define maxscream (curinterp->Imaxscream)
-#define maxsysfd (curinterp->Imaxsysfd)
-#define minus_F (curinterp->Iminus_F)
-#define minus_a (curinterp->Iminus_a)
-#define minus_c (curinterp->Iminus_c)
-#define minus_l (curinterp->Iminus_l)
-#define minus_n (curinterp->Iminus_n)
-#define minus_p (curinterp->Iminus_p)
-#define multiline (curinterp->Imultiline)
-#define mystack_base (curinterp->Imystack_base)
-#define mystack_mark (curinterp->Imystack_mark)
-#define mystack_max (curinterp->Imystack_max)
-#define mystack_sp (curinterp->Imystack_sp)
-#define mystrk (curinterp->Imystrk)
-#define nrs (curinterp->Inrs)
-#define ofmt (curinterp->Iofmt)
-#define ofs (curinterp->Iofs)
-#define ofslen (curinterp->Iofslen)
-#define oldlastpm (curinterp->Ioldlastpm)
-#define oldname (curinterp->Ioldname)
-#define op_mask (curinterp->Iop_mask)
-#define origargc (curinterp->Iorigargc)
-#define origargv (curinterp->Iorigargv)
-#define origfilename (curinterp->Iorigfilename)
-#define ors (curinterp->Iors)
-#define orslen (curinterp->Iorslen)
-#define pad (curinterp->Ipad)
-#define padname (curinterp->Ipadname)
-#define parsehook (curinterp->Iparsehook)
-#define patchlevel (curinterp->Ipatchlevel)
-#define perldb (curinterp->Iperldb)
+#define Argv (curinterp->IArgv)
+#define Cmd (curinterp->ICmd)
+#define DBgv (curinterp->IDBgv)
+#define DBline (curinterp->IDBline)
+#define DBsignal (curinterp->IDBsignal)
+#define DBsingle (curinterp->IDBsingle)
+#define DBsub (curinterp->IDBsub)
+#define DBtrace (curinterp->IDBtrace)
+#define allgvs (curinterp->Iallgvs)
+#define ampergv (curinterp->Iampergv)
+#define argvgv (curinterp->Iargvgv)
+#define argvoutgv (curinterp->Iargvoutgv)
+#define basetime (curinterp->Ibasetime)
+#define beginav (curinterp->Ibeginav)
+#define bodytarget (curinterp->Ibodytarget)
+#define cddir (curinterp->Icddir)
+#define chopset (curinterp->Ichopset)
+#define copline (curinterp->Icopline)
+#define curblock (curinterp->Icurblock)
+#define curcop (curinterp->Icurcop)
+#define curcopdb (curinterp->Icurcopdb)
+#define curcsv (curinterp->Icurcsv)
+#define curpm (curinterp->Icurpm)
+#define curstack (curinterp->Icurstack)
+#define curstash (curinterp->Icurstash)
+#define curstname (curinterp->Icurstname)
+#define cxstack (curinterp->Icxstack)
+#define cxstack_ix (curinterp->Icxstack_ix)
+#define cxstack_max (curinterp->Icxstack_max)
+#define dbargs (curinterp->Idbargs)
+#define debdelim (curinterp->Idebdelim)
+#define debname (curinterp->Idebname)
+#define debstash (curinterp->Idebstash)
+#define defgv (curinterp->Idefgv)
+#define defoutgv (curinterp->Idefoutgv)
+#define defstash (curinterp->Idefstash)
+#define delaymagic (curinterp->Idelaymagic)
+#define diehook (curinterp->Idiehook)
+#define dirty (curinterp->Idirty)
+#define dlevel (curinterp->Idlevel)
+#define dlmax (curinterp->Idlmax)
+#define doextract (curinterp->Idoextract)
+#define doswitches (curinterp->Idoswitches)
+#define dowarn (curinterp->Idowarn)
+#define dumplvl (curinterp->Idumplvl)
+#define e_fp (curinterp->Ie_fp)
+#define e_tmpname (curinterp->Ie_tmpname)
+#define endav (curinterp->Iendav)
+#define envgv (curinterp->Ienvgv)
+#define errgv (curinterp->Ierrgv)
+#define eval_root (curinterp->Ieval_root)
+#define eval_start (curinterp->Ieval_start)
+#define fdpid (curinterp->Ifdpid)
+#define filemode (curinterp->Ifilemode)
+#define firstgv (curinterp->Ifirstgv)
+#define forkprocess (curinterp->Iforkprocess)
+#define formfeed (curinterp->Iformfeed)
+#define formtarget (curinterp->Iformtarget)
+#define gensym (curinterp->Igensym)
+#define in_eval (curinterp->Iin_eval)
+#define incgv (curinterp->Iincgv)
+#define inplace (curinterp->Iinplace)
+#define last_in_gv (curinterp->Ilast_in_gv)
+#define lastfd (curinterp->Ilastfd)
+#define lastretstr (curinterp->Ilastretstr)
+#define lastscream (curinterp->Ilastscream)
+#define lastsize (curinterp->Ilastsize)
+#define lastspbase (curinterp->Ilastspbase)
+#define laststatval (curinterp->Ilaststatval)
+#define laststype (curinterp->Ilaststype)
+#define leftgv (curinterp->Ileftgv)
+#define lineary (curinterp->Ilineary)
+#define localizing (curinterp->Ilocalizing)
+#define localpatches (curinterp->Ilocalpatches)
+#define main_cv (curinterp->Imain_cv)
+#define main_root (curinterp->Imain_root)
+#define main_start (curinterp->Imain_start)
+#define mainstack (curinterp->Imainstack)
+#define maxscream (curinterp->Imaxscream)
+#define maxsysfd (curinterp->Imaxsysfd)
+#define mess_sv (curinterp->Imess_sv)
+#define minus_F (curinterp->Iminus_F)
+#define minus_a (curinterp->Iminus_a)
+#define minus_c (curinterp->Iminus_c)
+#define minus_l (curinterp->Iminus_l)
+#define minus_n (curinterp->Iminus_n)
+#define minus_p (curinterp->Iminus_p)
+#define multiline (curinterp->Imultiline)
+#define mystack_base (curinterp->Imystack_base)
+#define mystack_mark (curinterp->Imystack_mark)
+#define mystack_max (curinterp->Imystack_max)
+#define mystack_sp (curinterp->Imystack_sp)
+#define mystrk (curinterp->Imystrk)
+#define nrs (curinterp->Inrs)
+#define ofmt (curinterp->Iofmt)
+#define ofs (curinterp->Iofs)
+#define ofslen (curinterp->Iofslen)
+#define oldlastpm (curinterp->Ioldlastpm)
+#define oldname (curinterp->Ioldname)
+#define op_mask (curinterp->Iop_mask)
+#define origargc (curinterp->Iorigargc)
+#define origargv (curinterp->Iorigargv)
+#define origfilename (curinterp->Iorigfilename)
+#define ors (curinterp->Iors)
+#define orslen (curinterp->Iorslen)
+#define parsehook (curinterp->Iparsehook)
+#define patchlevel (curinterp->Ipatchlevel)
#define perl_destruct_level (curinterp->Iperl_destruct_level)
-#define pidstatus (curinterp->Ipidstatus)
-#define preambled (curinterp->Ipreambled)
-#define preambleav (curinterp->Ipreambleav)
-#define preprocess (curinterp->Ipreprocess)
-#define restartop (curinterp->Irestartop)
-#define rightgv (curinterp->Irightgv)
-#define rs (curinterp->Irs)
-#define runlevel (curinterp->Irunlevel)
-#define sawampersand (curinterp->Isawampersand)
-#define sawi (curinterp->Isawi)
-#define sawstudy (curinterp->Isawstudy)
-#define sawvec (curinterp->Isawvec)
-#define screamfirst (curinterp->Iscreamfirst)
-#define screamnext (curinterp->Iscreamnext)
-#define secondgv (curinterp->Isecondgv)
-#define siggv (curinterp->Isiggv)
-#define signalstack (curinterp->Isignalstack)
-#define sortcop (curinterp->Isortcop)
-#define sortstack (curinterp->Isortstack)
-#define sortstash (curinterp->Isortstash)
-#define splitstr (curinterp->Isplitstr)
-#define stack (curinterp->Istack)
-#define statcache (curinterp->Istatcache)
-#define statgv (curinterp->Istatgv)
-#define statname (curinterp->Istatname)
-#define statusvalue (curinterp->Istatusvalue)
-#define stdingv (curinterp->Istdingv)
-#define strchop (curinterp->Istrchop)
-#define sv_count (curinterp->Isv_count)
-#define sv_objcount (curinterp->Isv_objcount)
-#define sv_root (curinterp->Isv_root)
-#define sv_arenaroot (curinterp->Isv_arenaroot)
-#define tainted (curinterp->Itainted)
-#define tainting (curinterp->Itainting)
-#define tmps_floor (curinterp->Itmps_floor)
-#define tmps_ix (curinterp->Itmps_ix)
-#define tmps_max (curinterp->Itmps_max)
-#define tmps_stack (curinterp->Itmps_stack)
-#define top_env (curinterp->Itop_env)
-#define toptarget (curinterp->Itoptarget)
-#define unsafe (curinterp->Iunsafe)
-#define warnhook (curinterp->Iwarnhook)
+#define perldb (curinterp->Iperldb)
+#define preambleav (curinterp->Ipreambleav)
+#define preambled (curinterp->Ipreambled)
+#define preprocess (curinterp->Ipreprocess)
+#define restartop (curinterp->Irestartop)
+#define rightgv (curinterp->Irightgv)
+#define rs (curinterp->Irs)
+#define runlevel (curinterp->Irunlevel)
+#define sawampersand (curinterp->Isawampersand)
+#define sawstudy (curinterp->Isawstudy)
+#define sawvec (curinterp->Isawvec)
+#define screamfirst (curinterp->Iscreamfirst)
+#define screamnext (curinterp->Iscreamnext)
+#define secondgv (curinterp->Isecondgv)
+#define siggv (curinterp->Isiggv)
+#define signalstack (curinterp->Isignalstack)
+#define sortcop (curinterp->Isortcop)
+#define sortstack (curinterp->Isortstack)
+#define sortstash (curinterp->Isortstash)
+#define splitstr (curinterp->Isplitstr)
+#define start_env (curinterp->Istart_env)
+#define statcache (curinterp->Istatcache)
+#define statgv (curinterp->Istatgv)
+#define statname (curinterp->Istatname)
+#define statusvalue (curinterp->Istatusvalue)
+#define statusvalue_vms (curinterp->Istatusvalue_vms)
+#define stdingv (curinterp->Istdingv)
+#define strchop (curinterp->Istrchop)
+#define strtab (curinterp->Istrtab)
+#define sv_arenaroot (curinterp->Isv_arenaroot)
+#define sv_count (curinterp->Isv_count)
+#define sv_objcount (curinterp->Isv_objcount)
+#define sv_root (curinterp->Isv_root)
+#define tainted (curinterp->Itainted)
+#define tainting (curinterp->Itainting)
+#define tmps_floor (curinterp->Itmps_floor)
+#define tmps_ix (curinterp->Itmps_ix)
+#define tmps_max (curinterp->Itmps_max)
+#define tmps_stack (curinterp->Itmps_stack)
+#define top_env (curinterp->Itop_env)
+#define toptarget (curinterp->Itoptarget)
+#define unsafe (curinterp->Iunsafe)
+#define warnhook (curinterp->Iwarnhook)
-#else /* not multiple, so translate interpreter symbols the other way... */
+#else /* !MULTIPLICITY */
-#define IArgv Argv
-#define ICmd Cmd
-#define IDBgv DBgv
-#define IDBline DBline
-#define IDBsignal DBsignal
-#define IDBsingle DBsingle
-#define IDBsub DBsub
-#define IDBtrace DBtrace
-#define Iallgvs allgvs
-#define Iampergv ampergv
-#define Iargvgv argvgv
-#define Iargvoutgv argvoutgv
-#define Ibasetime basetime
-#define Ibeginav beginav
-#define Ibodytarget bodytarget
-#define Icddir cddir
-#define Ichopset chopset
-#define Icopline copline
-#define Icurblock curblock
-#define Icurcop curcop
-#define Icurcsv curcsv
-#define Icurpm curpm
-#define Icurstash curstash
-#define Icurstname curstname
-#define Icxstack cxstack
-#define Icxstack_ix cxstack_ix
-#define Icxstack_max cxstack_max
-#define Idbargs dbargs
-#define Idebdelim debdelim
-#define Idebname debname
-#define Idebstash debstash
-#define Idebug debug
-#define Idefgv defgv
-#define Idefoutgv defoutgv
-#define Idefstash defstash
-#define Idelaymagic delaymagic
-#define Idiehook diehook
-#define Idirty dirty
-#define Idlevel dlevel
-#define Idlmax dlmax
-#define Ido_undump do_undump
-#define Idoextract doextract
-#define Idoswitches doswitches
-#define Idowarn dowarn
-#define Idumplvl dumplvl
-#define Ie_fp e_fp
-#define Ie_tmpname e_tmpname
-#define Iendav endav
-#define Ienvgv envgv
-#define Ierrgv errgv
-#define Ieval_root eval_root
-#define Ieval_start eval_start
-#define Ifdpid fdpid
-#define Ifilemode filemode
-#define Ifirstgv firstgv
-#define Iforkprocess forkprocess
-#define Iformfeed formfeed
-#define Iformtarget formtarget
-#define Igensym gensym
-#define Iin_eval in_eval
-#define Iincgv incgv
-#define Iinplace inplace
-#define Ilast_in_gv last_in_gv
-#define Ilastfd lastfd
-#define Ilastretstr lastretstr
-#define Ilastscream lastscream
-#define Ilastsize lastsize
-#define Ilastspbase lastspbase
-#define Ilaststatval laststatval
-#define Ilaststype laststype
-#define Ileftgv leftgv
-#define Ilineary lineary
-#define Ilocalizing localizing
-#define Imain_cv main_cv
-#define Imain_root main_root
-#define Imain_start main_start
-#define Imainstack mainstack
-#define Imaxscream maxscream
-#define Imaxsysfd maxsysfd
-#define Iminus_F minus_F
-#define Iminus_a minus_a
-#define Iminus_c minus_c
-#define Iminus_l minus_l
-#define Iminus_n minus_n
-#define Iminus_p minus_p
-#define Imultiline multiline
-#define Imystack_base mystack_base
-#define Imystack_mark mystack_mark
-#define Imystack_max mystack_max
-#define Imystack_sp mystack_sp
-#define Imystrk mystrk
-#define Inrs nrs
-#define Iofmt ofmt
-#define Iofs ofs
-#define Iofslen ofslen
-#define Ioldlastpm oldlastpm
-#define Ioldname oldname
-#define Iop_mask op_mask
-#define Iorigargc origargc
-#define Iorigargv origargv
-#define Iorigfilename origfilename
-#define Iors ors
-#define Iorslen orslen
-#define Ipad pad
-#define Ipadname padname
-#define Iparsehook parsehook
-#define Ipatchlevel patchlevel
-#define Iperldb perldb
+#define IArgv Argv
+#define ICmd Cmd
+#define IDBgv DBgv
+#define IDBline DBline
+#define IDBsignal DBsignal
+#define IDBsingle DBsingle
+#define IDBsub DBsub
+#define IDBtrace DBtrace
+#define Iallgvs allgvs
+#define Iampergv ampergv
+#define Iargvgv argvgv
+#define Iargvoutgv argvoutgv
+#define Ibasetime basetime
+#define Ibeginav beginav
+#define Ibodytarget bodytarget
+#define Icddir cddir
+#define Ichopset chopset
+#define Icopline copline
+#define Icurblock curblock
+#define Icurcop curcop
+#define Icurcopdb curcopdb
+#define Icurcsv curcsv
+#define Icurpm curpm
+#define Icurstack curstack
+#define Icurstash curstash
+#define Icurstname curstname
+#define Icxstack cxstack
+#define Icxstack_ix cxstack_ix
+#define Icxstack_max cxstack_max
+#define Idbargs dbargs
+#define Idebdelim debdelim
+#define Idebname debname
+#define Idebstash debstash
+#define Idefgv defgv
+#define Idefoutgv defoutgv
+#define Idefstash defstash
+#define Idelaymagic delaymagic
+#define Idiehook diehook
+#define Idirty dirty
+#define Idlevel dlevel
+#define Idlmax dlmax
+#define Idoextract doextract
+#define Idoswitches doswitches
+#define Idowarn dowarn
+#define Idumplvl dumplvl
+#define Ie_fp e_fp
+#define Ie_tmpname e_tmpname
+#define Iendav endav
+#define Ienvgv envgv
+#define Ierrgv errgv
+#define Ieval_root eval_root
+#define Ieval_start eval_start
+#define Ifdpid fdpid
+#define Ifilemode filemode
+#define Ifirstgv firstgv
+#define Iforkprocess forkprocess
+#define Iformfeed formfeed
+#define Iformtarget formtarget
+#define Igensym gensym
+#define Iin_eval in_eval
+#define Iincgv incgv
+#define Iinplace inplace
+#define Ilast_in_gv last_in_gv
+#define Ilastfd lastfd
+#define Ilastretstr lastretstr
+#define Ilastscream lastscream
+#define Ilastsize lastsize
+#define Ilastspbase lastspbase
+#define Ilaststatval laststatval
+#define Ilaststype laststype
+#define Ileftgv leftgv
+#define Ilineary lineary
+#define Ilocalizing localizing
+#define Ilocalpatches localpatches
+#define Imain_cv main_cv
+#define Imain_root main_root
+#define Imain_start main_start
+#define Imainstack mainstack
+#define Imaxscream maxscream
+#define Imaxsysfd maxsysfd
+#define Imess_sv mess_sv
+#define Iminus_F minus_F
+#define Iminus_a minus_a
+#define Iminus_c minus_c
+#define Iminus_l minus_l
+#define Iminus_n minus_n
+#define Iminus_p minus_p
+#define Imultiline multiline
+#define Imystack_base mystack_base
+#define Imystack_mark mystack_mark
+#define Imystack_max mystack_max
+#define Imystack_sp mystack_sp
+#define Imystrk mystrk
+#define Inrs nrs
+#define Iofmt ofmt
+#define Iofs ofs
+#define Iofslen ofslen
+#define Ioldlastpm oldlastpm
+#define Ioldname oldname
+#define Iop_mask op_mask
+#define Iorigargc origargc
+#define Iorigargv origargv
+#define Iorigfilename origfilename
+#define Iors ors
+#define Iorslen orslen
+#define Iparsehook parsehook
+#define Ipatchlevel patchlevel
#define Iperl_destruct_level perl_destruct_level
-#define Ipidstatus pidstatus
-#define Ipreambled preambled
-#define Ipreambleav preambleav
-#define Ipreprocess preprocess
-#define Irestartop restartop
-#define Irightgv rightgv
-#define Irs rs
-#define Irunlevel runlevel
-#define Isawampersand sawampersand
-#define Isawi sawi
-#define Isawstudy sawstudy
-#define Isawvec sawvec
-#define Iscreamfirst screamfirst
-#define Iscreamnext screamnext
-#define Isecondgv secondgv
-#define Isiggv siggv
-#define Isignalstack signalstack
-#define Isortcop sortcop
-#define Isortstack sortstack
-#define Isortstash sortstash
-#define Isplitstr splitstr
-#define Istack stack
-#define Istatcache statcache
-#define Istatgv statgv
-#define Istatname statname
-#define Istatusvalue statusvalue
-#define Istdingv stdingv
-#define Istrchop strchop
-#define Isv_count sv_count
-#define Isv_objcount sv_objcount
-#define Isv_root sv_root
-#define Isv_arenaroot sv_arenaroot
-#define Itainted tainted
-#define Itainting tainting
-#define Itmps_floor tmps_floor
-#define Itmps_ix tmps_ix
-#define Itmps_max tmps_max
-#define Itmps_stack tmps_stack
-#define Itop_env top_env
-#define Itoptarget toptarget
-#define Iunsafe unsafe
-#define Iwarnhook warnhook
+#define Iperldb perldb
+#define Ipreambleav preambleav
+#define Ipreambled preambled
+#define Ipreprocess preprocess
+#define Irestartop restartop
+#define Irightgv rightgv
+#define Irs rs
+#define Irunlevel runlevel
+#define Isawampersand sawampersand
+#define Isawstudy sawstudy
+#define Isawvec sawvec
+#define Iscreamfirst screamfirst
+#define Iscreamnext screamnext
+#define Isecondgv secondgv
+#define Isiggv siggv
+#define Isignalstack signalstack
+#define Isortcop sortcop
+#define Isortstack sortstack
+#define Isortstash sortstash
+#define Isplitstr splitstr
+#define Istart_env start_env
+#define Istatcache statcache
+#define Istatgv statgv
+#define Istatname statname
+#define Istatusvalue statusvalue
+#define Istatusvalue_vms statusvalue_vms
+#define Istdingv stdingv
+#define Istrchop strchop
+#define Istrtab strtab
+#define Isv_arenaroot sv_arenaroot
+#define Isv_count sv_count
+#define Isv_objcount sv_objcount
+#define Isv_root sv_root
+#define Itainted tainted
+#define Itainting tainting
+#define Itmps_floor tmps_floor
+#define Itmps_ix tmps_ix
+#define Itmps_max tmps_max
+#define Itmps_stack tmps_stack
+#define Itop_env top_env
+#define Itoptarget toptarget
+#define Iunsafe unsafe
+#define Iwarnhook warnhook
+
+/* Hide interpreter-specific symbols? */
+
+#ifdef EMBED
+
+#define curcop Perl_curcop
+#define curcopdb Perl_curcopdb
+#define envgv Perl_envgv
+#define siggv Perl_siggv
+#define tainting Perl_tainting
+
+/* Hide interpreter symbols that 5.003 revealed? */
+
+#ifndef BINCOMPAT3
+
+#define Argv Perl_Argv
+#define Cmd Perl_Cmd
+#define DBgv Perl_DBgv
+#define DBline Perl_DBline
+#define DBsignal Perl_DBsignal
+#define DBsingle Perl_DBsingle
+#define DBsub Perl_DBsub
+#define DBtrace Perl_DBtrace
+#define allgvs Perl_allgvs
+#define ampergv Perl_ampergv
+#define argvgv Perl_argvgv
+#define argvoutgv Perl_argvoutgv
+#define basetime Perl_basetime
+#define beginav Perl_beginav
+#define bodytarget Perl_bodytarget
+#define cddir Perl_cddir
+#define chopset Perl_chopset
+#define copline Perl_copline
+#define curblock Perl_curblock
+#define curcsv Perl_curcsv
+#define curpm Perl_curpm
+#define curstack Perl_curstack
+#define curstash Perl_curstash
+#define curstname Perl_curstname
+#define cxstack Perl_cxstack
+#define cxstack_ix Perl_cxstack_ix
+#define cxstack_max Perl_cxstack_max
+#define dbargs Perl_dbargs
+#define debdelim Perl_debdelim
+#define debname Perl_debname
+#define debstash Perl_debstash
+#define defgv Perl_defgv
+#define defoutgv Perl_defoutgv
+#define defstash Perl_defstash
+#define delaymagic Perl_delaymagic
+#define diehook Perl_diehook
+#define dirty Perl_dirty
+#define dlevel Perl_dlevel
+#define dlmax Perl_dlmax
+#define doextract Perl_doextract
+#define doswitches Perl_doswitches
+#define dowarn Perl_dowarn
+#define dumplvl Perl_dumplvl
+#define e_fp Perl_e_fp
+#define e_tmpname Perl_e_tmpname
+#define endav Perl_endav
+#define errgv Perl_errgv
+#define eval_root Perl_eval_root
+#define eval_start Perl_eval_start
+#define fdpid Perl_fdpid
+#define filemode Perl_filemode
+#define firstgv Perl_firstgv
+#define forkprocess Perl_forkprocess
+#define formfeed Perl_formfeed
+#define formtarget Perl_formtarget
+#define gensym Perl_gensym
+#define in_eval Perl_in_eval
+#define incgv Perl_incgv
+#define inplace Perl_inplace
+#define last_in_gv Perl_last_in_gv
+#define lastfd Perl_lastfd
+#define lastretstr Perl_lastretstr
+#define lastscream Perl_lastscream
+#define lastsize Perl_lastsize
+#define lastspbase Perl_lastspbase
+#define laststatval Perl_laststatval
+#define laststype Perl_laststype
+#define leftgv Perl_leftgv
+#define lineary Perl_lineary
+#define localizing Perl_localizing
+#define localpatches Perl_localpatches
+#define main_cv Perl_main_cv
+#define main_root Perl_main_root
+#define main_start Perl_main_start
+#define mainstack Perl_mainstack
+#define maxscream Perl_maxscream
+#define maxsysfd Perl_maxsysfd
+#define mess_sv Perl_mess_sv
+#define minus_F Perl_minus_F
+#define minus_a Perl_minus_a
+#define minus_c Perl_minus_c
+#define minus_l Perl_minus_l
+#define minus_n Perl_minus_n
+#define minus_p Perl_minus_p
+#define multiline Perl_multiline
+#define mystack_base Perl_mystack_base
+#define mystack_mark Perl_mystack_mark
+#define mystack_max Perl_mystack_max
+#define mystack_sp Perl_mystack_sp
+#define mystrk Perl_mystrk
+#define nrs Perl_nrs
+#define ofmt Perl_ofmt
+#define ofs Perl_ofs
+#define ofslen Perl_ofslen
+#define oldlastpm Perl_oldlastpm
+#define oldname Perl_oldname
+#define op_mask Perl_op_mask
+#define origargc Perl_origargc
+#define origargv Perl_origargv
+#define origfilename Perl_origfilename
+#define ors Perl_ors
+#define orslen Perl_orslen
+#define parsehook Perl_parsehook
+#define patchlevel Perl_patchlevel
+#define perl_destruct_level Perl_perl_destruct_level
+#define perldb Perl_perldb
+#define preambleav Perl_preambleav
+#define preambled Perl_preambled
+#define preprocess Perl_preprocess
+#define restartop Perl_restartop
+#define rightgv Perl_rightgv
+#define rs Perl_rs
+#define runlevel Perl_runlevel
+#define sawampersand Perl_sawampersand
+#define sawstudy Perl_sawstudy
+#define sawvec Perl_sawvec
+#define screamfirst Perl_screamfirst
+#define screamnext Perl_screamnext
+#define secondgv Perl_secondgv
+#define signalstack Perl_signalstack
+#define sortcop Perl_sortcop
+#define sortstack Perl_sortstack
+#define sortstash Perl_sortstash
+#define splitstr Perl_splitstr
+#define start_env Perl_start_env
+#define statcache Perl_statcache
+#define statgv Perl_statgv
+#define statname Perl_statname
+#define statusvalue Perl_statusvalue
+#define statusvalue_vms Perl_statusvalue_vms
+#define stdingv Perl_stdingv
+#define strchop Perl_strchop
+#define strtab Perl_strtab
+#define sv_arenaroot Perl_sv_arenaroot
+#define sv_count Perl_sv_count
+#define sv_objcount Perl_sv_objcount
+#define sv_root Perl_sv_root
+#define tainted Perl_tainted
+#define tmps_floor Perl_tmps_floor
+#define tmps_ix Perl_tmps_ix
+#define tmps_max Perl_tmps_max
+#define tmps_stack Perl_tmps_stack
+#define top_env Perl_top_env
+#define toptarget Perl_toptarget
+#define unsafe Perl_unsafe
+#define warnhook Perl_warnhook
+
+#endif /* !BINCOMPAT3 */
+
+#endif /* EMBED */
#endif /* MULTIPLICITY */
diff --git a/gnu/usr.bin/perl/embed.pl b/gnu/usr.bin/perl/embed.pl
index e5423dde3cc..266a33e7e0a 100644
--- a/gnu/usr.bin/perl/embed.pl
+++ b/gnu/usr.bin/perl/embed.pl
@@ -1,9 +1,53 @@
-#!/usr/bin/perl
+#!/usr/bin/perl -w
-open(EM, ">embed.h") || die "Can't create embed.h: $!\n";
+require 5.003;
+
+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';
+readsyms %compat3, 'compat3.sym';
+
+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 multon ($) {
+ my ($sym) = @_;
+ hide($sym, "(curinterp->I$sym)");
+}
+sub multoff ($) {
+ my ($sym) = @_;
+ hide("I$sym", $sym);
+}
+
+unlink 'embed.h';
+open(EM, '> embed.h')
+ or die "Can't create embed.h: $!\n";
print EM <<'END';
-/* This file is derived from global.sym and interp.sym */
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by embed.pl from global.sym, interp.sym,
+ and compat3.sym. Any changes made here will be lost!
+*/
/* (Doing namespace management portably in C is really gross.) */
@@ -17,61 +61,84 @@ print EM <<'END';
# define EMBED 1
#endif
+/* Hide global symbols? */
+
#ifdef EMBED
-/* globals we need to hide from the world */
END
-open(GL, "<global.sym") || die "Can't open global.sym: $!\n";
-
-while(<GL>) {
- s/[ \t]*#.*//; # Delete comments.
- next unless /\S/;
- s/(.*)/#define $1\t\tPerl_$1/;
- s/(................\t)\t/$1/;
- print EM $_;
+for $sym (sort keys %global) {
+ print EM embed($sym) unless $compat3{$sym};
}
-close(GL) || warn "Can't close global.sym: $!\n";
+print EM <<'END';
+
+/* Hide global symbols that 5.003 revealed? */
+
+#ifndef BINCOMPAT3
+
+END
+
+for $sym (sort keys %global) {
+ print EM embed($sym) if $compat3{$sym};
+}
print EM <<'END';
+#endif /* !BINCOMPAT3 */
+
#endif /* EMBED */
-/* Put interpreter specific symbols into a struct? */
+/* Put interpreter-specific symbols into a struct? */
#ifdef MULTIPLICITY
END
-open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n";
-while (<INT>) {
- s/[ \t]*#.*//; # Delete comments.
- next unless /\S/;
- s/(.*)/#define $1\t\t(curinterp->I$1)/;
- s/(................\t)\t/$1/;
- print EM $_;
+for $sym (sort keys %interp) {
+ print EM multon($sym);
}
-close(INT) || warn "Can't close interp.sym: $!\n";
print EM <<'END';
-#else /* not multiple, so translate interpreter symbols the other way... */
+#else /* !MULTIPLICITY */
END
-open(INT, "<interp.sym") || die "Can't open interp.sym: $!\n";
-while (<INT>) {
- s/[ \t]*#.*//; # Delete comments.
- next unless /\S/;
- s/(.*)/#define I$1\t\t$1/;
- s/(................\t)\t/$1/;
- print EM $_;
+for $sym (sort keys %interp) {
+ print EM multoff($sym);
+}
+
+print EM <<'END';
+
+/* Hide interpreter-specific symbols? */
+
+#ifdef EMBED
+
+END
+
+for $sym (sort keys %interp) {
+ print EM embed($sym) if $compat3{$sym};
}
-close(INT) || warn "Can't close interp.sym: $!\n";
print EM <<'END';
+/* Hide interpreter symbols that 5.003 revealed? */
+
+#ifndef BINCOMPAT3
+
+END
+
+for $sym (sort keys %interp) {
+ print EM embed($sym) unless $compat3{$sym};
+}
+
+print EM <<'END';
+
+#endif /* !BINCOMPAT3 */
+
+#endif /* EMBED */
+
#endif /* MULTIPLICITY */
END
diff --git a/gnu/usr.bin/perl/ext/DB_File/DB_File.pm b/gnu/usr.bin/perl/ext/DB_File/DB_File.pm
index 61ac26aafed..df1593fd657 100644
--- a/gnu/usr.bin/perl/ext/DB_File/DB_File.pm
+++ b/gnu/usr.bin/perl/ext/DB_File/DB_File.pm
@@ -1,181 +1,143 @@
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
-# last modified 14th November 1995
-# version 1.01
+# last modified 29th Jun 1997
+# version 1.15
+#
+# Copyright (c) 1995, 1996, 1997 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 vars qw(%elements);
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
{
- bless {} ;
+ my $pkg = shift ;
+
+ bless { VALID => { map {$_, 1}
+ qw( bsize ffactor nelem cachesize hash lorder)
+ },
+ GOT => {}
+ }, $pkg ;
}
-%elements = ( 'bsize' => 0,
- 'ffactor' => 0,
- 'nelem' => 0,
- 'cachesize' => 0,
- 'hash' => 0,
- 'lorder' => 0
- ) ;
sub FETCH
{
- return $_[0]{$_[1]} if defined $elements{$_[1]} ;
+ my $self = shift ;
+ my $key = shift ;
- croak "DB_File::HASHINFO::FETCH - Unknown element '$_[1]'" ;
+ return $self->{GOT}{$key} if exists $self->{VALID}{$key} ;
+
+ my $pkg = ref $self ;
+ croak "${pkg}::FETCH - Unknown element '$key'" ;
}
sub STORE
{
- if ( defined $elements{$_[1]} )
+ my $self = shift ;
+ my $key = shift ;
+ my $value = shift ;
+
+ if ( exists $self->{VALID}{$key} )
{
- $_[0]{$_[1]} = $_[2] ;
+ $self->{GOT}{$key} = $value ;
return ;
}
- croak "DB_File::HASHINFO::STORE - Unknown element '$_[1]'" ;
+ my $pkg = ref $self ;
+ croak "${pkg}::STORE - Unknown element '$key'" ;
}
sub DELETE
{
- if ( defined $elements{$_[1]} )
+ my $self = shift ;
+ my $key = shift ;
+
+ if ( exists $self->{VALID}{$key} )
{
- delete ${$_[0]}{$_[1]} ;
+ delete $self->{GOT}{$key} ;
return ;
}
- croak "DB_File::HASHINFO::DELETE - Unknown element '$_[1]'" ;
+ my $pkg = ref $self ;
+ croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ;
}
-
-sub DESTROY {undef %{$_[0]} }
-sub FIRSTKEY { croak "DB_File::HASHINFO::FIRSTKEY is not implemented" }
-sub NEXTKEY { croak "DB_File::HASHINFO::NEXTKEY is not implemented" }
-sub EXISTS { croak "DB_File::HASHINFO::EXISTS is not implemented" }
-sub CLEAR { croak "DB_File::HASHINFO::CLEAR is not implemented" }
-
-package DB_File::BTREEINFO ;
-
-use strict;
-use vars qw(%elements);
-use Carp;
-
-sub TIEHASH
+sub EXISTS
{
- bless {} ;
-}
+ my $self = shift ;
+ my $key = shift ;
-%elements = ( 'flags' => 0,
- 'cachesize' => 0,
- 'maxkeypage' => 0,
- 'minkeypage' => 0,
- 'psize' => 0,
- 'compare' => 0,
- 'prefix' => 0,
- 'lorder' => 0
- ) ;
-
-sub FETCH
-{
- return $_[0]{$_[1]} if defined $elements{$_[1]} ;
-
- croak "DB_File::BTREEINFO::FETCH - Unknown element '$_[1]'" ;
+ exists $self->{VALID}{$key} ;
}
-
-sub STORE
+sub NotHere
{
- if ( defined $elements{$_[1]} )
- {
- $_[0]{$_[1]} = $_[2] ;
- return ;
- }
-
- croak "DB_File::BTREEINFO::STORE - Unknown element '$_[1]'" ;
-}
+ my $self = shift ;
+ my $method = shift ;
-sub DELETE
-{
- if ( defined $elements{$_[1]} )
- {
- delete ${$_[0]}{$_[1]} ;
- return ;
- }
-
- croak "DB_File::BTREEINFO::DELETE - Unknown element '$_[1]'" ;
+ croak ref($self) . " does not define the method ${method}" ;
}
-
-sub DESTROY {undef %{$_[0]} }
-sub FIRSTKEY { croak "DB_File::BTREEINFO::FIRSTKEY is not implemented" }
-sub NEXTKEY { croak "DB_File::BTREEINFO::NEXTKEY is not implemented" }
-sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" }
-sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" }
+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;
-use vars qw(%elements);
-use Carp;
+use strict ;
+
+@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;
sub TIEHASH
{
- bless {} ;
-}
+ my $pkg = shift ;
-%elements = ( 'bval' => 0,
- 'cachesize' => 0,
- 'psize' => 0,
- 'flags' => 0,
- 'lorder' => 0,
- 'reclen' => 0,
- 'bfname' => 0
- ) ;
-sub FETCH
-{
- return $_[0]{$_[1]} if defined $elements{$_[1]} ;
-
- croak "DB_File::RECNOINFO::FETCH - Unknown element '$_[1]'" ;
+ bless { VALID => { map {$_, 1}
+ qw( bval cachesize psize flags lorder reclen bfname )
+ },
+ GOT => {},
+ }, $pkg ;
}
+package DB_File::BTREEINFO ;
-sub STORE
-{
- if ( defined $elements{$_[1]} )
- {
- $_[0]{$_[1]} = $_[2] ;
- return ;
- }
-
- croak "DB_File::RECNOINFO::STORE - Unknown element '$_[1]'" ;
-}
+use strict ;
-sub DELETE
+@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ;
+
+sub TIEHASH
{
- if ( defined $elements{$_[1]} )
- {
- delete ${$_[0]}{$_[1]} ;
- return ;
- }
-
- croak "DB_File::RECNOINFO::DELETE - Unknown element '$_[1]'" ;
+ my $pkg = shift ;
+
+ bless { VALID => { map {$_, 1}
+ qw( flags cachesize maxkeypage minkeypage psize
+ compare prefix lorder )
+ },
+ GOT => {},
+ }, $pkg ;
}
-sub DESTROY {undef %{$_[0]} }
-sub FIRSTKEY { croak "DB_File::RECNOINFO::FIRSTKEY is not implemented" }
-sub NEXTKEY { croak "DB_File::RECNOINFO::NEXTKEY is not implemented" }
-sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" }
-sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" }
-
-
-
package DB_File ;
use strict;
@@ -183,12 +145,12 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO) ;
use Carp;
-$VERSION = "1.01" ;
+$VERSION = "1.15" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
-$DB_BTREE = TIEHASH DB_File::BTREEINFO ;
-$DB_HASH = TIEHASH DB_File::HASHINFO ;
-$DB_RECNO = TIEHASH DB_File::RECNOINFO ;
+$DB_BTREE = new DB_File::BTREEINFO ;
+$DB_HASH = new DB_File::HASHINFO ;
+$DB_RECNO = new DB_File::RECNOINFO ;
require Tie::Hash;
require Exporter;
@@ -197,6 +159,7 @@ require DynaLoader;
@ISA = qw(Tie::Hash Exporter DynaLoader);
@EXPORT = qw(
$DB_BTREE $DB_HASH $DB_RECNO
+
BTREEMAGIC
BTREEVERSION
DB_LOCK
@@ -225,6 +188,7 @@ require DynaLoader;
R_SETCURSOR
R_SNAPSHOT
__R_UNUSED
+
);
sub AUTOLOAD {
@@ -246,16 +210,82 @@ sub AUTOLOAD {
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);
+};
+
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] } ;
+
+ DoTie_($tieHASH, @arg) ;
+}
+
+sub TIEHASH
+{
+ tie_hash_or_array(@_) ;
+}
+
+sub TIEARRAY
+{
+ tie_hash_or_array(@_) ;
+}
+
+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__
-=cut
-
=head1 NAME
DB_File - Perl5 access to Berkeley DB
@@ -263,18 +293,30 @@ DB_File - Perl5 access to Berkeley DB
=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 ;
-
+
+ [$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->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 ;
@@ -282,10 +324,14 @@ DB_File - Perl5 access to Berkeley DB
B<DB_File> is a module which allows Perl programs to make use of the
facilities provided by Berkeley DB. If you intend to use this
-module you should really have a copy of the Berkeley DB manualpage at
+module you should really have a copy of the Berkeley DB manual pages at
hand. The interface defined here mirrors the Berkeley DB interface
closely.
+Please note that this module will only work with version 1.x of
+Berkeley DB. Once Berkeley DB version 2 is released, B<DB_File> will be
+upgraded to work with it.
+
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.
@@ -294,9 +340,9 @@ The file types are:
=over 5
-=item DB_HASH
+=item B<DB_HASH>
-This database type allows arbitrary key/data pairs to be stored in data
+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
@@ -307,16 +353,16 @@ 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 DB_BTREE
+=item B<DB_BTREE>
-The btree format allows arbitrary key/data pairs to be stored in a
+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 DB_RECNO
+=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
@@ -325,7 +371,7 @@ number.
=back
-=head2 How does DB_File interface to Berkeley DB?
+=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
@@ -333,13 +379,14 @@ 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 use most of
-the functions provided in the Berkeley DB API.
+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 Differences with Berkeley DB
+=head2 Opening a Berkeley DB Database File
Berkeley DB uses the function dbopen() to open or create a database.
-Below is the C prototype for dbopen().
+Here is the C prototype for dbopen():
DB*
dbopen (const char * file, int flags, int mode,
@@ -352,35 +399,133 @@ 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>.
+an equivalent call using B<DB_File>:
- tie %array, DB_File, $filename, $flags, $mode, $DB_HASH ;
+ 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 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.
+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>.
+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
-To change one of these elements, just assign to it like this
+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:
- $DB_HASH->{cachesize} = 10000 ;
+ tie %A, "DB_File", "filename" ;
+is equivalent to:
-=head2 RECNO
+ 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:
-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.
+ 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
@@ -388,153 +533,751 @@ 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
+
+As you can see from the example above, the tied array interface is
+quite limited. To make the interface more useful, a number of methods
+are supplied with B<DB_File> to simulate the standard array operations
+that are not currently implemented in Perl's tied array interface. 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) ;>
-=head2 Using the Berkeley DB Interface Directly
+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 functions defined in the
+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.
-To do this you need to remember the return value from the tie.
-
- $db = tie %hash, DB_File, "filename"
+ $db = tie %hash, "DB_File", "filename" ;
Once you have done that, you can access the Berkeley DB API functions
-directly.
+as B<DB_File> methods directly like this:
$db->put($key, $value, R_NOOVERWRITE) ;
-All the functions defined in L<dbx(3X)> are available except for
-close() and dbopen() itself. The B<DB_File> interface to these
-functions have been implemented to mirror the the way Berkeley DB
-works. In particular note that all the functions return only a status
-value. Whenever a Berkeley DB function returns data via one of its
-parameters, the B<DB_File> equivalent does exactly the same.
+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.
-All the constants defined in L<dbopen> are also available.
+ use DB_File ;
+ $db = tie %hash, "DB_File", "filename"
+ or die "Cannot tie filename: $!" ;
+ ...
+ undef $db ;
+ untie %hash ;
-Below is a list of the functions available.
+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 get
+=item *
-Same as in C<recno> except that the flags parameter is optional.
-Remember the value associated with the key you request is returned in
-the $value parameter.
+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.
-=item put
+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.
-As usual the flags parameter is optional.
+=item *
-If you use either the R_IAFTER or R_IBEFORE flags, the key parameter
-will have the record number of the inserted key/value pair set.
+Whenever a Berkeley DB function returns data via one of its parameters,
+the equivalent B<DB_File> method does exactly the same.
+
+=item *
-=item del
+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:
-The flags parameter is optional.
+ $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE
+ or die "Cannot tie $filename: $!" ;
-=item fd
+ # Get the first key/value pair and set the cursor
+ $X->seq($key, $value, R_FIRST) ;
-As in I<recno>.
+ # this line will modify the cursor
+ $count = scalar keys %x ;
-=item seq
+ # Get the second key/value pair.
+ # oops, it didn't, it got the last key/value pair!
+ $X->seq($key, $value, R_NEXT) ;
-The flags parameter is optional.
+The code above can be rearranged to get around the problem, like this:
-Both the key and value parameters will be set.
+ $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE
+ or die "Cannot tie $filename: $!" ;
-=item sync
+ # this line will modify the cursor
+ $count = scalar keys %x ;
-The flags parameter is optional.
+ # 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
-=head1 EXAMPLES
+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.
-It is always a lot easier to understand something when you see a real
-example. So here are a few.
+Below is a list of the methods available.
-=head2 Using HASH
+=over 5
- use DB_File ;
- use Fcntl ;
-
- tie %h, "DB_File", "hashed", O_RDWR|O_CREAT, 0640, $DB_HASH ;
-
- # Add a key/value pair to the file
- $h{"apple"} = "orange" ;
-
- # Check for existence of a key
- print "Exists\n" if $h{"banana"} ;
-
- # Delete
- delete $h{"apple"} ;
-
- untie %h ;
+=item B<$status = $X-E<gt>get($key, $value [, $flags]) ;>
-=head2 Using BTREE
+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.
-Here is sample of code which used BTREE. Just to make life more
-interesting the default comparision function will not be used. Instead
-a Perl sub, C<Compare()>, will be used to do a case insensitive
-comparison.
+If the key does not exist the method returns 1.
- use DB_File ;
- use Fcntl ;
-
- sub Compare
- {
- my ($key1, $key2) = @_ ;
-
- "\L$key1" cmp "\L$key2" ;
- }
-
- $DB_BTREE->{compare} = 'Compare' ;
-
- tie %h, 'DB_File', "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE ;
-
- # 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 ;
+No flags are currently defined for this method.
-Here is the output from the code above.
+=item B<$status = $X-E<gt>put($key, $value [, $flags]) ;>
- mouse
- Smith
- Wall
+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.
-=head2 Using RECNO
+Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and
+R_SETCURSOR.
- use DB_File ;
- use Fcntl ;
-
- $DB_RECNO->{psize} = 3000 ;
-
- tie @h, DB_File, "text", O_RDWR|O_CREAT, 0640, $DB_RECNO ;
-
- # Add a key/value pair to the file
- $h[0] = "orange" ;
-
- # Check for existence of a key
- print "Exists\n" if $h[1] ;
-
- untie @h ;
+=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
@@ -545,7 +1288,6 @@ 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 Fcntl;
use DB_File;
use strict;
@@ -588,13 +1330,211 @@ in the background to watch the locks granted in proper order.
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
=over
@@ -631,14 +1571,112 @@ Fixed a core dump problem with SunOS.
The return value from TIEHASH wasn't set to NULL when dbopen returned
an error.
-=head1 WARNINGS
+=item 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
+C<sync> added. Without it the resultant database file was empty.
-If you happen find any other functions defined in the source for this
-module that have not been mentioned in this document -- beware. I may
-drop them at a moments notice.
+Added get_dup method.
-If you cannot find any, then either you didn't look very hard or the
-moment has passed and I have dropped them.
+=item 1.03
+
+Documentation update.
+
+B<DB_File> now imports the constants (O_RDWR, O_CREAT etc.) from Fcntl
+automatically.
+
+The standard hash function C<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.
+
+=item 1.04
+
+Minor documentation changes.
+
+Fixed a bug in hash_cb. Patches supplied by Dave Hammen,
+E<lt>hammen@gothamcity.jsc.nasa.govE<gt>.
+
+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 C<-w> clean.
+
+Reworked part of the test harness to be more locale friendly.
+
+=item 1.05
+
+Made all scripts in the documentation C<strict> and C<-w> clean.
+
+Added logic to F<DB_File.xs> to allow the module to be built after Perl
+is installed.
+
+=item 1.06
+
+Minor namespace cleanup: Localized C<PrintBtree>.
+
+=item 1.07
+
+Fixed bug with RECNO, where bval wasn't defaulting to "\n".
+
+=item 1.08
+
+Documented operation of bval.
+
+=item 1.09
+
+Minor bug fix in DB_File::HASHINFO, DB_File::RECNOINFO and
+DB_File::BTREEINFO.
+
+Changed default mode to 0666.
+
+=item 1.10
+
+Fixed fd method so that it still returns -1 for in-memory files when db
+1.86 is used.
+
+=item 1.11
+
+Documented the untie gotcha.
+
+=item 1.12
+
+Documented the incompatibility with version 2 of Berkeley DB.
+
+=item 1.13
+
+Minor changes to DB_FIle.xs and DB_File.pm
+
+=item 1.14
+
+Made it illegal to tie an associative array to a RECNO database and an
+ordinary array to a HASH or BTREE database.
+
+=item 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.
+
+=back
=head1 BUGS
@@ -651,23 +1689,50 @@ suggest any enhancements, I would welcome your comments.
=head1 AVAILABILITY
-Berkeley DB is available at your nearest CPAN archive (see
+B<DB_File> comes with the standard Perl source distribution. Look in
+the directory F<ext/DB_File>.
+
+This version of B<DB_File> will only work with version 1.x of Berkeley
+DB. It is I<not> yet compatible with version 2.
+
+Version 1 of Berkeley DB is available at your nearest CPAN archive (see
L<perlmod/"CPAN"> for a list) in F<src/misc/db.1.85.tar.gz>, or via the
-host F<ftp.cs.berkeley.edu> in F</ucb/4bsd/db.tar.gz>. It is I<not> under
-the GPL.
+host F<ftp.cs.berkeley.edu> in F</ucb/4bsd/db.tar.gz>. Alternatively,
+check out the Berkeley DB home page at F<http://www.bostic.com/db>. It
+is I<not> under the GPL.
+
+If you are running IRIX, then get Berkeley DB from
+F<http://reality.sgi.com/ariel>. It has the patches necessary to
+compile properly on IRIX 5.3.
+
+As of January 1997, version 1.86 of Berkeley DB is available from the
+Berkeley DB home page. Although this release does fix a number of bugs
+that were present in 1.85 you should be aware of the following
+information (taken from the Berkeley DB home page) before you consider
+using it:
+
+ DB version 1.86 includes a new implementation of the hash access
+ method that fixes a variety of hashing problems found in DB version
+ 1.85. We are making it available as an interim solution until DB
+ 2.0 is available.
+
+ PLEASE NOTE: the underlying file format for the hash access method
+ changed between version 1.85 and version 1.86, so you will have to
+ dump and reload all of your databases to convert from version 1.85
+ to version 1.86. If you do not absolutely require the fixes from
+ version 1.86, we strongly urge you to wait until DB 2.0 is released
+ before upgrading from 1.85.
+
=head1 SEE ALSO
L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>
-Berkeley DB is available from F<ftp.cs.berkeley.edu> in the directory
-F</ucb/4bsd>.
-
=head1 AUTHOR
The DB_File interface was written by Paul Marquess
-<pmarquess@bfsec.bt.co.uk>.
-Questions about the DB system itself may be addressed to Keith Bostic
-<bostic@cs.berkeley.edu>.
+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/gnu/usr.bin/perl/ext/DB_File/DB_File.xs b/gnu/usr.bin/perl/ext/DB_File/DB_File.xs
index dd9e03d0d09..d2c7e6c645b 100644
--- a/gnu/usr.bin/perl/ext/DB_File/DB_File.xs
+++ b/gnu/usr.bin/perl/ext/DB_File/DB_File.xs
@@ -3,11 +3,15 @@
DB_File.xs -- Perl 5 interface to Berkeley DB
written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
- last modified 14th November 1995
- version 1.01
+ last modified 29th Jun 1997
+ version 1.15
All comments/suggestions/problems are welcome
+ Copyright (c) 1995, 1996, 1997 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.
@@ -17,6 +21,31 @@
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.15 - Patch from Gisle Aas <gisle@aas.no> to suppress "use of
+ undefined value" warning with db_get and db_seq.
+
+
*/
#include "EXTERN.h"
@@ -24,28 +53,47 @@
#include "XSUB.h"
#include <db.h>
+/* #ifdef DB_VERSION_MAJOR */
+/* #include <db_185.h> */
+/* #endif */
#include <fcntl.h>
+#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
+
+union INFO {
+ HASHINFO hash ;
+ RECNOINFO recno ;
+ BTREEINFO btree ;
+ } ;
+
typedef struct {
DBTYPE type ;
DB * dbp ;
SV * compare ;
SV * prefix ;
SV * hash ;
+ int in_memory ;
+ union INFO info ;
} DB_File_type;
typedef DB_File_type * DB_File ;
typedef DBT DBTKEY ;
-union INFO {
- HASHINFO hash ;
- RECNOINFO recno ;
- BTREEINFO btree ;
- } ;
-
-/* #define TRACE */
+/* #define TRACE */
#define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
@@ -54,21 +102,27 @@ union INFO {
#define db_close(db) ((db->dbp)->close)(db->dbp)
#define db_del(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
-#define db_fd(db) ((db->dbp)->fd)(db->dbp)
+#define db_fd(db) (db->in_memory \
+ ? -1 \
+ : ((db->dbp)->fd)(db->dbp) )
#define db_put(db, key, value, flags) ((db->dbp)->put)(db->dbp, &key, &value, flags)
#define db_get(db, key, value, flags) ((db->dbp)->get)(db->dbp, &key, &value, flags)
#define db_seq(db, key, value, flags) ((db->dbp)->seq)(db->dbp, &key, &value, flags)
#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
-#define OutputValue(arg, name) \
- { if (RETVAL == 0) sv_setpvn(arg, name.data, name.size) ; }
+#define OutputValue(arg, name) \
+ { if (RETVAL == 0) { \
+ sv_setpvn(arg, name.data, name.size) ; \
+ } \
+ }
#define OutputKey(arg, name) \
{ if (RETVAL == 0) \
{ \
- if (db->type != DB_RECNO) \
+ if (db->type != DB_RECNO) { \
sv_setpvn(arg, name.data, name.size); \
+ } \
else \
sv_setiv(arg, (I32)*(I32*)name.data - 1); \
} \
@@ -117,7 +171,7 @@ const DBT * key2 ;
SPAGAIN ;
if (count != 1)
- croak ("DB_File btree_compare: expected 1 return value from %s, got %d\n", count) ;
+ croak ("DB_File btree_compare: expected 1 return value from compare sub, got %d\n", count) ;
retval = POPi ;
@@ -164,7 +218,7 @@ const DBT * key2 ;
SPAGAIN ;
if (count != 1)
- croak ("DB_File btree_prefix: expected 1 return value from %s, got %d\n", count) ;
+ croak ("DB_File btree_prefix: expected 1 return value from prefix sub, got %d\n", count) ;
retval = POPi ;
@@ -187,7 +241,12 @@ size_t size ;
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 ;
@@ -196,7 +255,7 @@ size_t size ;
SPAGAIN ;
if (count != 1)
- croak ("DB_File hash_cb: expected 1 return value from %s, got %d\n", count) ;
+ croak ("DB_File hash_cb: expected 1 return value from hash sub, got %d\n", count) ;
retval = POPi ;
@@ -212,44 +271,45 @@ size_t size ;
static void
PrintHash(hash)
-HASHINFO hash ;
+HASHINFO * hash ;
{
printf ("HASH Info\n") ;
- printf (" hash = %s\n", (hash.hash != NULL ? "redefined" : "default")) ;
- printf (" bsize = %d\n", hash.bsize) ;
- printf (" ffactor = %d\n", hash.ffactor) ;
- printf (" nelem = %d\n", hash.nelem) ;
- printf (" cachesize = %d\n", hash.cachesize) ;
- printf (" lorder = %d\n", hash.lorder) ;
+ printf (" hash = %s\n", (hash->hash != NULL ? "redefined" : "default")) ;
+ printf (" bsize = %d\n", hash->bsize) ;
+ printf (" ffactor = %d\n", hash->ffactor) ;
+ printf (" nelem = %d\n", hash->nelem) ;
+ printf (" cachesize = %d\n", hash->cachesize) ;
+ printf (" lorder = %d\n", hash->lorder) ;
}
static void
PrintRecno(recno)
-RECNOINFO recno ;
+RECNOINFO * recno ;
{
printf ("RECNO Info\n") ;
- printf (" flags = %d\n", recno.flags) ;
- printf (" cachesize = %d\n", recno.cachesize) ;
- printf (" psize = %d\n", recno.psize) ;
- printf (" lorder = %d\n", recno.lorder) ;
- printf (" reclen = %d\n", recno.reclen) ;
- printf (" bval = %d\n", recno.bval) ;
- printf (" bfname = %s\n", recno.bfname) ;
+ printf (" flags = %d\n", recno->flags) ;
+ printf (" cachesize = %d\n", recno->cachesize) ;
+ printf (" psize = %d\n", recno->psize) ;
+ printf (" lorder = %d\n", recno->lorder) ;
+ printf (" reclen = %lu\n", (unsigned long)recno->reclen) ;
+ printf (" bval = %d 0x%x\n", recno->bval, recno->bval) ;
+ printf (" bfname = %d [%s]\n", recno->bfname, recno->bfname) ;
}
+static void
PrintBtree(btree)
-BTREEINFO btree ;
+BTREEINFO * btree ;
{
printf ("BTREE Info\n") ;
- printf (" compare = %s\n", (btree.compare ? "redefined" : "default")) ;
- printf (" prefix = %s\n", (btree.prefix ? "redefined" : "default")) ;
- printf (" flags = %d\n", btree.flags) ;
- printf (" cachesize = %d\n", btree.cachesize) ;
- printf (" psize = %d\n", btree.psize) ;
- printf (" maxkeypage = %d\n", btree.maxkeypage) ;
- printf (" minkeypage = %d\n", btree.minkeypage) ;
- printf (" lorder = %d\n", btree.lorder) ;
+ printf (" compare = %s\n", (btree->compare ? "redefined" : "default")) ;
+ printf (" prefix = %s\n", (btree->prefix ? "redefined" : "default")) ;
+ printf (" flags = %d\n", btree->flags) ;
+ printf (" cachesize = %d\n", btree->cachesize) ;
+ printf (" psize = %d\n", btree->psize) ;
+ printf (" maxkeypage = %d\n", btree->maxkeypage) ;
+ printf (" minkeypage = %d\n", btree->minkeypage) ;
+ printf (" lorder = %d\n", btree->lorder) ;
}
#else
@@ -275,147 +335,194 @@ DB * db ;
else if (RETVAL == 1) /* No key means empty file */
RETVAL = 0 ;
- return (RETVAL) ;
+ 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->dbp) ;
+
+ /* 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(name, flags, mode, sv, string)
+ParseOpenInfo(isHASH, name, flags, mode, sv)
+int isHASH ;
char * name ;
int flags ;
int mode ;
SV * sv ;
-char * string ;
{
SV ** svp;
HV * action ;
- union INFO info ;
DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
void * openinfo = NULL ;
- /* DBTYPE type = DB_HASH ; */
+ union INFO * info = &RETVAL->info ;
+ /* 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") ;
- action = (HV*)SvRV(sv);
+ 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 ;
+ openinfo = (void*)info ;
svp = hv_fetch(action, "hash", 4, FALSE);
if (svp && SvOK(*svp))
{
- info.hash.hash = hash_cb ;
+ info->hash.hash = hash_cb ;
RETVAL->hash = newSVsv(*svp) ;
}
else
- info.hash.hash = NULL ;
+ info->hash.hash = NULL ;
svp = hv_fetch(action, "bsize", 5, FALSE);
- info.hash.bsize = svp ? SvIV(*svp) : 0;
+ info->hash.bsize = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "ffactor", 7, FALSE);
- info.hash.ffactor = svp ? SvIV(*svp) : 0;
+ info->hash.ffactor = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "nelem", 5, FALSE);
- info.hash.nelem = svp ? SvIV(*svp) : 0;
+ info->hash.nelem = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "cachesize", 9, FALSE);
- info.hash.cachesize = svp ? SvIV(*svp) : 0;
+ info->hash.cachesize = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "lorder", 6, FALSE);
- info.hash.lorder = svp ? SvIV(*svp) : 0;
+ info->hash.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 ;
+ openinfo = (void*)info ;
svp = hv_fetch(action, "compare", 7, FALSE);
if (svp && SvOK(*svp))
{
- info.btree.compare = btree_compare ;
+ info->btree.compare = btree_compare ;
RETVAL->compare = newSVsv(*svp) ;
}
else
- info.btree.compare = NULL ;
+ info->btree.compare = NULL ;
svp = hv_fetch(action, "prefix", 6, FALSE);
if (svp && SvOK(*svp))
{
- info.btree.prefix = btree_prefix ;
+ info->btree.prefix = btree_prefix ;
RETVAL->prefix = newSVsv(*svp) ;
}
else
- info.btree.prefix = NULL ;
+ info->btree.prefix = NULL ;
svp = hv_fetch(action, "flags", 5, FALSE);
- info.btree.flags = svp ? SvIV(*svp) : 0;
+ info->btree.flags = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "cachesize", 9, FALSE);
- info.btree.cachesize = svp ? SvIV(*svp) : 0;
+ info->btree.cachesize = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "minkeypage", 10, FALSE);
- info.btree.minkeypage = svp ? SvIV(*svp) : 0;
+ info->btree.minkeypage = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "maxkeypage", 10, FALSE);
- info.btree.maxkeypage = svp ? SvIV(*svp) : 0;
+ info->btree.maxkeypage = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "psize", 5, FALSE);
- info.btree.psize = svp ? SvIV(*svp) : 0;
+ info->btree.psize = svp ? SvIV(*svp) : 0;
svp = hv_fetch(action, "lorder", 6, FALSE);
- info.btree.lorder = svp ? SvIV(*svp) : 0;
+ info->btree.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 ;
+ openinfo = (void *)info ;
svp = hv_fetch(action, "flags", 5, FALSE);
- info.recno.flags = (u_long) svp ? SvIV(*svp) : 0;
+ info->recno.flags = (u_long) (svp ? SvIV(*svp) : 0);
svp = hv_fetch(action, "cachesize", 9, FALSE);
- info.recno.cachesize = (u_int) svp ? SvIV(*svp) : 0;
+ info->recno.cachesize = (u_int) (svp ? SvIV(*svp) : 0);
svp = hv_fetch(action, "psize", 5, FALSE);
- info.recno.psize = (int) svp ? SvIV(*svp) : 0;
+ info->recno.psize = (u_int) (svp ? SvIV(*svp) : 0);
svp = hv_fetch(action, "lorder", 6, FALSE);
- info.recno.lorder = (int) svp ? SvIV(*svp) : 0;
+ info->recno.lorder = (int) (svp ? SvIV(*svp) : 0);
svp = hv_fetch(action, "reclen", 6, FALSE);
- info.recno.reclen = (size_t) svp ? SvIV(*svp) : 0;
+ info->recno.reclen = (size_t) (svp ? SvIV(*svp) : 0);
svp = hv_fetch(action, "bval", 4, FALSE);
if (svp && SvOK(*svp))
{
if (SvPOK(*svp))
- info.recno.bval = (u_char)*SvPV(*svp, na) ;
+ info->recno.bval = (u_char)*SvPV(*svp, na) ;
else
- info.recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
+ info->recno.bval = (u_char)(unsigned long) SvIV(*svp) ;
}
else
{
- if (info.recno.flags & R_FIXEDLEN)
- info.recno.bval = (u_char) ' ' ;
+ if (info->recno.flags & R_FIXEDLEN)
+ info->recno.bval = (u_char) ' ' ;
else
- info.recno.bval = (u_char) '\n' ;
+ info->recno.bval = (u_char) '\n' ;
}
svp = hv_fetch(action, "bfname", 6, FALSE);
- info.recno.bfname = (char *) svp ? SvPV(*svp,na) : 0;
+ if (svp && SvOK(*svp)) {
+ char * ptr = SvPV(*svp,na) ;
+ info->recno.bfname = (char*) (na ? ptr : NULL) ;
+ }
+ else
+ info->recno.bfname = NULL ;
PrintRecno(info) ;
}
@@ -424,17 +531,14 @@ char * string ;
}
- RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
-
-#if 0
- /* kludge mode on: RETVAL->type for DB_RECNO is set to DB_BTREE
- so remember a DB_RECNO by saving the address
- of one of it's internal routines
- */
- if (RETVAL->dbp && type == DB_RECNO)
- DB_recno_close = RETVAL->dbp->close ;
-#endif
+ /* OS2 Specific Code */
+#ifdef OS2
+#ifdef __EMX__
+ flags |= O_BINARY;
+#endif /* __EMX__ */
+#endif /* OS2 */
+ RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
return (RETVAL) ;
}
@@ -695,7 +799,8 @@ constant(name,arg)
DB_File
-db_TIEHASH(dbtype, name=undef, flags=O_RDWR, mode=0640, type=DB_HASH)
+db_DoTie_(isHASH, dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
+ int isHASH
char * dbtype
int flags
int mode
@@ -704,22 +809,19 @@ db_TIEHASH(dbtype, name=undef, flags=O_RDWR, mode=0640, type=DB_HASH)
char * name = (char *) NULL ;
SV * sv = (SV *) NULL ;
- if (items >= 2 && SvOK(ST(1)))
- name = (char*) SvPV(ST(1), na) ;
+ if (items >= 3 && SvOK(ST(2)))
+ name = (char*) SvPV(ST(2), na) ;
- if (items == 5)
- sv = ST(4) ;
+ if (items == 6)
+ sv = ST(5) ;
- RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ;
+ RETVAL = ParseOpenInfo(isHASH, name, flags, mode, sv) ;
if (RETVAL->dbp == NULL)
RETVAL = NULL ;
}
OUTPUT:
RETVAL
-BOOT:
- newXS("DB_File::TIEARRAY", XS_DB_File_db_TIEHASH, file);
-
int
db_DESTROY(db)
DB_File db
@@ -743,6 +845,21 @@ db_DELETE(db, key, flags=0)
INIT:
CurrentDB = db ;
+
+int
+db_EXISTS(db, key)
+ DB_File db
+ DBTKEY key
+ CODE:
+ {
+ DBT value ;
+
+ CurrentDB = db ;
+ RETVAL = (((db->dbp)->get)(db->dbp, &key, &value, 0) == 0) ;
+ }
+ OUTPUT:
+ RETVAL
+
int
db_FETCH(db, key, flags=0)
DB_File db
@@ -783,7 +900,7 @@ db_FIRSTKEY(db)
ST(0) = sv_newmortal();
if (RETVAL == 0)
{
- if (Db->type != DB_RECNO)
+ if (db->type != DB_RECNO)
sv_setpvn(ST(0), key.data, key.size);
else
sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
@@ -804,7 +921,7 @@ db_NEXTKEY(db, key)
ST(0) = sv_newmortal();
if (RETVAL == 0)
{
- if (Db->type != DB_RECNO)
+ if (db->type != DB_RECNO)
sv_setpvn(ST(0), key.data, key.size);
else
sv_setiv(ST(0), (I32)*(I32*)key.data - 1);
@@ -859,9 +976,11 @@ pop(db)
/* Now delete it */
if (RETVAL == 0)
{
+ /* the call to del will trash value, so take a copy now */
+ sv_setpvn(ST(0), value.data, value.size);
RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
- if (RETVAL == 0)
- sv_setpvn(ST(0), value.data, value.size);
+ if (RETVAL != 0)
+ sv_setsv(ST(0), &sv_undef);
}
}
@@ -870,20 +989,22 @@ shift(db)
DB_File db
CODE:
{
- DBTKEY key ;
DBT value ;
+ DBTKEY key ;
DB * Db = db->dbp ;
CurrentDB = db ;
/* get the first value */
- RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
+ RETVAL = (Db->seq)(Db, &key, &value, R_FIRST) ;
ST(0) = sv_newmortal();
/* Now delete it */
if (RETVAL == 0)
{
- RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
- if (RETVAL == 0)
- sv_setpvn(ST(0), value.data, value.size);
+ /* the call to del will trash value, so take a copy now */
+ sv_setpvn(ST(0), value.data, value.size);
+ RETVAL = (Db->del)(Db, &key, R_CURSOR) ;
+ if (RETVAL != 0)
+ sv_setsv (ST(0), &sv_undef) ;
}
}
@@ -947,7 +1068,7 @@ int
db_get(db, key, value, flags=0)
DB_File db
DBTKEY key
- DBT value
+ DBT value = NO_INIT
u_int flags
INIT:
CurrentDB = db ;
@@ -983,10 +1104,11 @@ int
db_seq(db, key, value, flags)
DB_File db
DBTKEY key
- DBT value
+ DBT value = NO_INIT
u_int flags
INIT:
CurrentDB = db ;
OUTPUT:
key
value
+
diff --git a/gnu/usr.bin/perl/ext/DB_File/Makefile.PL b/gnu/usr.bin/perl/ext/DB_File/Makefile.PL
index 4cda63507d2..39b8bc70303 100644
--- a/gnu/usr.bin/perl/ext/DB_File/Makefile.PL
+++ b/gnu/usr.bin/perl/ext/DB_File/Makefile.PL
@@ -1,11 +1,16 @@
-use ExtUtils::MakeMaker;
+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' ;
WriteMakefile(
- NAME => 'DB_File',
- LIBS => ["-L/usr/local/lib -ldb"],
- MAN3PODS => ' ', # Pods will be built by installman.
- #INC => '-I/usr/local/include',
+ NAME => 'DB_File',
+ LIBS => ["-L/usr/local/lib -ldb"],
+ MAN3PODS => ' ', # Pods will be built by installman.
+ #INC => '-I/usr/local/include',
VERSION_FROM => 'DB_File.pm',
- XSPROTOARG => '-noprototypes', # XXX remove later?
-);
+ XSPROTOARG => '-noprototypes',
+ DEFINE => "$OS2",
+ );
diff --git a/gnu/usr.bin/perl/ext/DB_File/typemap b/gnu/usr.bin/perl/ext/DB_File/typemap
index 4acc65e0781..a6212243de2 100644
--- a/gnu/usr.bin/perl/ext/DB_File/typemap
+++ b/gnu/usr.bin/perl/ext/DB_File/typemap
@@ -1,8 +1,8 @@
# typemap for Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
-# last modified 23rd June 1994
-# version 0.1
+# last modified 28th June 1996
+# version 0.2
#
#################################### DB SECTION
#
@@ -15,15 +15,12 @@ DBTKEY T_dbtkeydatum
INPUT
T_dbtkeydatum
- if (db->type != DB_RECNO)
- {
+ if (db->type != DB_RECNO) {
$var.data = SvPV($arg, na);
$var.size = (int)na;
}
- else
- {
- Value = SvIV($arg) ;
- ++ Value ;
+ else {
+ Value = GetRecnoKey(db, SvIV($arg)) ;
$var.data = & Value;
$var.size = (int)sizeof(recno_t);
}
@@ -37,3 +34,5 @@ T_dbtkeydatum
OutputKey($arg, $var)
T_dbtdatum
OutputValue($arg, $var)
+T_PTROBJ
+ sv_setref_pv($arg, dbtype, (void*)$var);
diff --git a/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader.pm b/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader.pm
index 282d364372e..712d575e38b 100644
--- a/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader.pm
+++ b/gnu/usr.bin/perl/ext/DynaLoader/DynaLoader.pm
@@ -12,21 +12,39 @@ package DynaLoader;
#
# Tim.Bunce@ig.co.uk, August 1994
-use vars qw($VERSION @ISA) ;
+$VERSION = $VERSION = "1.03"; # avoid typo warning
-require Carp;
require Config;
-require AutoLoader;
-@ISA=qw(AutoLoader);
+require AutoLoader;
+*AUTOLOAD = \&AutoLoader::AUTOLOAD;
-$VERSION = "1.00" ;
+# The following require can't be removed during maintenance
+# releases, sadly, because of the risk of buggy code that does
+# require Carp; Carp::croak "..."; without brackets dying
+# if Carp hasn't been loaded in earlier compile time. :-(
+# We'll let those bugs get found on the development track.
+require Carp if $] < 5.00450;
-sub import { } # override import inherited from AutoLoader
# 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'};
@@ -39,6 +57,8 @@ $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";
@@ -67,6 +87,8 @@ if ($dl_debug) {
1; # End of main code
+sub croak { require Carp; Carp::croak(@_) }
+
# The bootstrap function cannot be autoloaded (without complications)
# so we define it here:
@@ -76,11 +98,14 @@ sub bootstrap {
local($module) = $args[0];
local(@dirs, $file);
- Carp::confess("Usage: DynaLoader::bootstrap(module)") unless $module;
+ 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.
- Carp::croak("Can't load module $module, dynamic loading not available in this perl.\n".
+ 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);
@@ -104,16 +129,17 @@ sub bootstrap {
next unless -d $dir; # skip over uninteresting directories
# check for common cases to avoid autoload of dl_findfile
- last if ($file=_check_file("$dir/$modfname.$dl_dlext"));
+ 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, "-L$dir");
+ push @dirs, $dir;
}
# last resort, let dl_findfile have a go in all known locations
- $file = dl_findfile(@dirs, map("-L$_",@INC), $modfname) unless $file;
+ $file = dl_findfile(map("-L$_",@dirs,@INC), $modfname) unless $file;
- Carp::croak("Can't find loadable object for module $module in \@INC (@INC)")
- 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;
@@ -137,29 +163,35 @@ sub bootstrap {
# in this perl code simply because this was the last perl code
# it executed.
- my $libref = dl_load_file($file) or
- Carp::croak("Can't load '$file' for module $module: ".dl_error()."\n");
+ 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();
- Carp::carp("Undefined symbols present after loading $file: @unresolved\n")
- if @unresolved;
+ if (@unresolved) {
+ require Carp;
+ Carp::carp("Undefined symbols present after loading $file: @unresolved\n");
+ }
my $boot_symbol_ref = dl_find_symbol($libref, $bootname) or
- Carp::croak("Can't find '$bootname' symbol in $file\n");
+ 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;
-}
+#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:
@@ -224,7 +256,8 @@ sub dl_findfile {
foreach $name (@names) {
my($file) = "$dir/$name";
print STDERR " checking in $dir for $name\n" if $dl_debug;
- $file = _check_file($file);
+ $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
@@ -260,6 +293,7 @@ sub dl_expandspec {
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;
@@ -268,12 +302,22 @@ sub dl_expandspec {
$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_undef_symbols(), dl_install_xsub(), boostrap() - routines used by DynaLoader modules
+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
@@ -282,6 +326,9 @@ dl_error(), dl_findfile(), dl_expandspec(), dl_load_file(), dl_find_symbol(), dl
@ISA = qw(... DynaLoader ...);
bootstrap YourPackage;
+ # optional method for 'global' loading
+ sub dl_load_flags { 0x01 }
+
=head1 DESCRIPTION
@@ -303,9 +350,9 @@ 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. It is anticipated that any
-glue that may be developed in the future will be implemented in a
-separate dynamically loaded module.
+library function or supplying arguments. A ExtUtils::DynaLib module
+is available from CPAN sites which performs that function for some
+common system types.
DynaLoader Interface Summary
@@ -313,11 +360,15 @@ DynaLoader Interface Summary
@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) C
+ $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
@@ -357,12 +408,13 @@ 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 to be told the location
-of the dependent library explicitly. Use @dl_resolve_using for this.
+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:
@@ -373,6 +425,17 @@ Example usage:
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:
@@ -452,19 +515,26 @@ more information.
Syntax:
- $libref = dl_load_file($filename)
+ $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 function that does the real work. It should use the current
-values of @dl_require_symbols and @dl_resolve_using if required.
+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)
@@ -472,6 +542,20 @@ values of @dl_require_symbols and @dl_resolve_using if required.
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()
@@ -495,6 +579,15 @@ be passed to, and understood by, dl_install_xsub().
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
@@ -523,7 +616,7 @@ the function if required by die(), caller() or the debugger. If
$filename is not defined then "DynaLoader" will be used.
-=item boostrap()
+=item bootstrap()
Syntax:
@@ -555,6 +648,10 @@ 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 *
@@ -590,4 +687,7 @@ 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
diff --git a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL
index 64ee4d02598..9323935880b 100644
--- a/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL
+++ b/gnu/usr.bin/perl/ext/DynaLoader/Makefile.PL
@@ -1,21 +1,21 @@
use ExtUtils::MakeMaker;
WriteMakefile(
- NAME => 'DynaLoader',
+ NAME => 'DynaLoader',
LINKTYPE => 'static',
- DEFINE => '-DLIBC="$(LIBC)"',
+ 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',
- clean => {FILES => 'DynaLoader.c'},
+ clean => {FILES => 'DynaLoader.c DynaLoader.xs'},
);
sub MY::postamble {
'
-DynaLoader.c: $(DLSRC)
- $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $(DLSRC) >tmp && mv tmp $@
+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.
diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs
index f8bace13146..746666636ae 100644
--- a/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs
+++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_aix.xs
@@ -29,6 +29,12 @@
#include <a.out.h>
#include <ldfcn.h>
+/* 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
@@ -389,7 +395,13 @@ static int readExports(ModulePtr mp)
;
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);
@@ -524,12 +536,15 @@ BOOT:
void *
-dl_load_file(filename)
- char * filename
+dl_load_file(filename, flags=0)
+ char * filename
+ int flags
CODE:
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
+ 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,fprintf(stderr," libref=%x\n", RETVAL));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL)
SaveError("%s",dlerror()) ;
@@ -542,10 +557,10 @@ dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
CODE:
- DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "dl_find_symbol(handle=%x, symbol=%s)\n",
libhandle, symbolname));
RETVAL = dlsym(libhandle, symbolname);
- DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref = %x\n", RETVAL));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL)
SaveError("%s",dlerror()) ;
@@ -567,7 +582,7 @@ dl_install_xsub(perl_name, symref, filename="$Package")
void * symref
char * filename
CODE:
- DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
+ 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)));
diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs
new file mode 100644
index 00000000000..2b7563764e1
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs
index a0028a1f7ad..44933ec92ca 100644
--- a/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs
+++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_dld.xs
@@ -62,7 +62,7 @@ dl_private_init()
if (dlderr) {
char *msg = dld_strerror(dlderr);
SaveError("dld_init(%s) failed: %s", origargv[0], msg);
- DLDEBUG(1,fprintf(stderr,"%s", LastError));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "%s", LastError));
}
#ifdef __linux__
}
@@ -77,18 +77,21 @@ BOOT:
char *
-dl_load_file(filename)
+dl_load_file(filename, flags=0)
char * filename
- CODE:
+ int flags
+ PREINIT:
int dlderr,x,max;
GV *gv;
+ CODE:
RETVAL = filename;
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s)\n", 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,fprintf(stderr, "dld_create_ref(%s)\n", sym));
+ 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));
@@ -96,7 +99,7 @@ dl_load_file(filename)
}
}
- DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", filename));
+ 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;
@@ -105,13 +108,13 @@ dl_load_file(filename)
max = AvFILL(dl_resolve_using);
for (x = 0; x <= max; x++) {
char *sym = SvPVX(*av_fetch(dl_resolve_using, x, 0));
- DLDEBUG(1,fprintf(stderr, "dld_link(%s)\n", sym));
+ 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,fprintf(stderr,"libref=%s\n", RETVAL));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "libref=%s\n", RETVAL));
haverror:
ST(0) = sv_newmortal() ;
if (dlderr == 0)
@@ -123,11 +126,11 @@ dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
CODE:
- DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
+ 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,fprintf(stderr," symbolref = %x\n", RETVAL));
+ 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) ;
@@ -157,7 +160,7 @@ dl_install_xsub(perl_name, symref, filename="$Package")
void * symref
char * filename
CODE:
- DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
+ 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)));
diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs
index 86643f6d3be..fef4530cfee 100644
--- a/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs
+++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_dlopen.xs
@@ -119,7 +119,7 @@
#endif
#ifndef HAS_DLERROR
-# if defined(__NetBSD__) || defined(__OpenBSD__)
+# ifdef __NetBSD__
# define dlerror() strerror(errno)
# else
# define dlerror() "Unknown error - dlerror() not implemented"
@@ -143,17 +143,25 @@ BOOT:
void *
-dl_load_file(filename)
- char * filename
- CODE:
+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
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
+ 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,fprintf(stderr," libref=%x\n", RETVAL));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%lx\n", (unsigned long) RETVAL));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL)
SaveError("%s",dlerror()) ;
@@ -167,13 +175,14 @@ dl_find_symbol(libhandle, symbolname)
char * symbolname
CODE:
#ifdef DLSYM_NEEDS_UNDERSCORE
- char symbolname_buf[1024];
- symbolname = dl_add_underscore(symbolname, symbolname_buf);
+ symbolname = form("_%s", symbolname);
#endif
- DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
- libhandle, symbolname));
+ DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+ "dl_find_symbol(handle=%lx, symbol=%s)\n",
+ (unsigned long) libhandle, symbolname));
RETVAL = dlsym(libhandle, symbolname);
- DLDEBUG(2,fprintf(stderr," symbolref = %x\n", RETVAL));
+ DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+ " symbolref = %lx\n", (unsigned long) RETVAL));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL)
SaveError("%s",dlerror()) ;
@@ -195,8 +204,8 @@ dl_install_xsub(perl_name, symref, filename="$Package")
void * symref
char * filename
CODE:
- DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
- perl_name, symref));
+ 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(*)())symref, filename)));
diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs
index 0e146830ef3..51d464e6dea 100644
--- a/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs
+++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_hpux.xs
@@ -3,6 +3,14 @@
* 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
@@ -38,31 +46,44 @@ BOOT:
void *
-dl_load_file(filename)
- char * filename
- CODE:
+dl_load_file(filename, flags=0)
+ char * filename
+ int flags
+ PREINIT:
shl_t obj = NULL;
int i, max, bind_type;
-
- if (dl_nonlazy)
- bind_type = BIND_IMMEDIATE;
- else
- bind_type = BIND_DEFERRED;
+ 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; */
+ }
+#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,fprintf(stderr, "dl_load_file(%s) (dependent)\n", sym));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s) (dependent)\n", sym));
obj = shl_load(sym, bind_type | BIND_NOSTART, 0L);
if (obj == NULL) {
goto end;
}
}
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s): ", filename));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s): ", filename));
obj = shl_load(filename, bind_type | BIND_NOSTART, 0L);
- DLDEBUG(2,fprintf(stderr," libref=%x\n", obj));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", obj));
end:
ST(0) = sv_newmortal() ;
if (obj == NULL)
@@ -80,20 +101,21 @@ dl_find_symbol(libhandle, symbolname)
void *symaddr = NULL;
int status;
#ifdef __hp9000s300
- char symbolname_buf[MAXPATHLEN];
- symbolname = dl_add_underscore(symbolname, symbolname_buf);
+ symbolname = form("_%s", symbolname);
#endif
- DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
- libhandle, symbolname));
+ 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,fprintf(stderr," symbolref(PROCEDURE) = %x\n", 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,fprintf(stderr," symbolref(DATA) = %x\n", symaddr));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " symbolref(DATA) = %x\n", symaddr));
}
if (status == -1) {
@@ -117,7 +139,7 @@ dl_install_xsub(perl_name, symref, filename="$Package")
void * symref
char * filename
CODE:
- DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
+ 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)));
diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs
index 33a41003eff..92d14bc81c2 100644
--- a/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs
+++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_next.xs
@@ -31,9 +31,12 @@ 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"
@@ -47,15 +50,102 @@ Anno Siegel
static char * dl_last_error = (char *) 0;
static AV *dl_resolve_using = Nullav;
-NXStream *
-OpenError()
+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);
}
-void
-TransferError( s)
-NXStream *s;
+static void TransferError(NXStream *s)
{
char *buffer;
int len, maxlen;
@@ -68,24 +158,14 @@ NXStream *s;
strcpy(dl_last_error, buffer);
}
-void
-CloseError( s)
-NXStream *s;
+static void CloseError(NXStream *s)
{
if ( s ) {
NXCloseMemory( s, NX_FREEBUFFER);
}
}
-char *dlerror()
-{
- return dl_last_error;
-}
-
-char *
-dlopen(path, mode)
-char * path;
-int mode; /* mode is ignored */
+static char *dlopen(char *path, int mode /* mode is ignored */)
{
int rld_success;
NXStream *nxerr;
@@ -120,30 +200,22 @@ int mode; /* mode is ignored */
return result;
}
-int
-dlclose(handle) /* stub only */
-void *handle;
-{
- return 0;
-}
-
void *
dlsym(handle, symbol)
void *handle;
char *symbol;
{
NXStream *nxerr = OpenError();
- char symbuf[1024];
unsigned long symref = 0;
- sprintf(symbuf, "_%s", symbol);
- if (!rld_lookup(nxerr, symbuf, &symref)) {
+ 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 ----- */
@@ -163,13 +235,17 @@ BOOT:
void *
-dl_load_file(filename)
+dl_load_file(filename, flags=0)
char * filename
- CODE:
+ int flags
+ PREINIT:
int mode = 1;
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
+ 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,fprintf(stderr," libref=%x\n", RETVAL));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), " libref=%x\n", RETVAL));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL)
SaveError("%s",dlerror()) ;
@@ -182,10 +258,15 @@ dl_find_symbol(libhandle, symbolname)
void * libhandle
char * symbolname
CODE:
- DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
- libhandle, symbolname));
+#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,fprintf(stderr," symbolref = %x\n", RETVAL));
+ DLDEBUG(2, PerlIO_printf(PerlIO_stderr(),
+ " symbolref = %lx\n", (unsigned long) RETVAL));
ST(0) = sv_newmortal() ;
if (RETVAL == NULL)
SaveError("%s",dlerror()) ;
@@ -207,7 +288,7 @@ dl_install_xsub(perl_name, symref, filename="$Package")
void * symref
char * filename
CODE:
- DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
+ 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)));
diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_os2.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_os2.xs
deleted file mode 100644
index 2c72be23ed8..00000000000
--- a/gnu/usr.bin/perl/ext/DynaLoader/dl_os2.xs
+++ /dev/null
@@ -1,188 +0,0 @@
-/* dl_os2.xs
- *
- * Platform: OS/2.
- * Author: Andreas Kaiser (ak@ananke.s.bawue.de)
- * Created: 08th December 1994
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-#define INCL_BASE
-#include <os2.h>
-
-#include "dlutils.c" /* SaveError() etc */
-
-static ULONG retcode;
-
-static void *
-dlopen(char *path, int mode)
-{
- HMODULE handle;
- char tmp[260], *beg, *dot;
- char fail[300];
- ULONG rc;
-
- if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0)
- return (void *)handle;
-
- retcode = rc;
-
- /* Not found. Check for non-FAT name and try truncated name. */
- /* Don't know if this helps though... */
- for (beg = dot = path + strlen(path);
- beg > path && !strchr(":/\\", *(beg-1));
- beg--)
- if (*beg == '.')
- dot = beg;
- if (dot - beg > 8) {
- int n = beg+8-path;
- memmove(tmp, path, n);
- memmove(tmp+n, dot, strlen(dot)+1);
- if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0)
- return (void *)handle;
- }
-
- return NULL;
-}
-
-static void *
-dlsym(void *handle, char *symbol)
-{
- ULONG rc, type;
- PFN addr;
-
- rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr);
- if (rc == 0) {
- rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type);
- if (rc == 0 && type == PT_32BIT)
- return (void *)addr;
- rc = ERROR_CALL_NOT_IMPLEMENTED;
- }
- retcode = rc;
- return NULL;
-}
-
-static char *
-dlerror(void)
-{
- static char buf[300];
- ULONG len;
-
- if (retcode == 0)
- return NULL;
- if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len))
- sprintf(buf, "OS/2 system error code %d", retcode);
- else
- buf[len] = '\0';
- retcode = 0;
- return buf;
-}
-
-
-static void
-dl_private_init()
-{
- (void)dl_generic_private_init();
-}
-
-static char *
-mod2fname(sv)
- SV *sv;
-{
- static char fname[9];
- int pos = 7;
- int len;
- AV *av;
- SV *svp;
- char *s;
-
- if (!SvROK(sv)) croak("Not a reference given to mod2fname");
- sv = SvRV(sv);
- if (SvTYPE(sv) != SVt_PVAV)
- croak("Not array reference given to mod2fname");
- if (av_len((AV*)sv) < 0)
- croak("Empty array reference given to mod2fname");
- s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na);
- strncpy(fname, s, 8);
- if ((len=strlen(s)) < 7) pos = len;
- fname[pos] = '_';
- fname[pos + 1] = '\0';
- return (char *)fname;
-}
-
-MODULE = DynaLoader PACKAGE = DynaLoader
-
-BOOT:
- (void)dl_private_init();
-
-
-void *
-dl_load_file(filename)
- char * filename
- CODE:
- int mode = 1; /* Solaris 1 */
-#ifdef RTLD_LAZY
- mode = RTLD_LAZY; /* Solaris 2 */
-#endif
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
- RETVAL = dlopen(filename, mode) ;
- DLDEBUG(2,fprintf(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:
-#ifdef DLSYM_NEEDS_UNDERSCORE
- char symbolname_buf[1024];
- symbolname = dl_add_underscore(symbolname, symbolname_buf);
-#endif
- DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
- libhandle, symbolname));
- RETVAL = dlsym(libhandle, symbolname);
- DLDEBUG(2,fprintf(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:
-
-char *
-mod2fname(sv)
- SV *sv;
-
-
-# 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/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs
index 3f46ffc9408..0329ebd9cbd 100644
--- a/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs
+++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_vms.xs
@@ -126,7 +126,7 @@ findsym_handler(void *sig, void *mech)
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,fprintf(stderr,"findsym_handler: received\n\t%s\n",LastError));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "findsym_handler: received\n\t%s\n",LastError));
return SS$_CONTINUE;
}
@@ -177,11 +177,11 @@ dl_expandspec(filespec)
dlfab.fab$b_fns = strlen(vmsspec);
dlfab.fab$l_dna = 0;
dlfab.fab$b_dns = 0;
- DLDEBUG(1,fprintf(stderr,"dl_expand_filespec(%s):\n",vmsspec));
+ 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,fprintf(stderr,"\tSYNCHK sys$parse = %d\n",sts));
+ 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) = &sv_undef;
@@ -194,7 +194,7 @@ dl_expandspec(filespec)
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,fprintf(stderr,"\tsplit filespec: name = %.*s, default = %.*s\n",
+ 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;
@@ -202,7 +202,7 @@ dl_expandspec(filespec)
dlfab.fab$b_dns = deflen;
dlfab.fab$b_fns = dlnam.nam$b_name;
sts = sys$parse(&dlfab);
- DLDEBUG(2,fprintf(stderr,"\tname/default sys$parse = %d\n",sts));
+ 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) = &sv_undef;
@@ -210,23 +210,24 @@ dl_expandspec(filespec)
else {
/* Now find the actual file */
sts = sys$search(&dlfab);
- DLDEBUG(2,fprintf(stderr,"\tsys$search = %d\n",sts));
+ 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) = &sv_undef;
}
else {
ST(0) = sv_2mortal(newSVpv(dlnam.nam$l_rsa,dlnam.nam$b_rsl));
- DLDEBUG(1,fprintf(stderr,"\tresult = \\%.*s\\\n",
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "\tresult = \\%.*s\\\n",
dlnam.nam$b_rsl,dlnam.nam$l_rsa));
}
}
}
void
-dl_load_file(filespec)
+dl_load_file(filespec, flags)
char * filespec
- CODE:
+ int flags
+ PREINIT:
char vmsspec[NAM$C_MAXRSS];
SV *reqSV, **reqSVhndl;
STRLEN deflen;
@@ -241,17 +242,18 @@ dl_load_file(filespec)
struct libref *dlptr;
vmssts sts, failed = 0;
void (*entry)();
+ CODE:
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n",filespec));
+ 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,fprintf(stderr,"\tVMS-ified filespec is %s\n",
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tVMS-ified filespec is %s\n",
specdsc.dsc$a_pointer));
- New(7901,dlptr,1,struct libref);
+ 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,fprintf(stderr,"\tsys$filescan: returns %d, name is %.*s\n",
+ 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;
@@ -267,21 +269,21 @@ dl_load_file(filespec)
memcpy(dlptr->defspec.dsc$a_pointer + deflen,
namlst[0].string + namlst[0].len,
dlptr->defspec.dsc$w_length - deflen);
- DLDEBUG(2,fprintf(stderr,"\tlibref = name: %s, defspec: %.*s\n",
+ 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,fprintf(stderr,"\t@dl_require_symbols empty, returning untested libref\n"));
+ 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,fprintf(stderr,"\t$dl_require_symbols[0] = %.*s\n",
+ 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,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "\tlib$find_image_symbol returns %d\n",sts));
if (!(sts&1)) {
failed = 1;
dl_set_error(sts,0);
@@ -311,13 +313,13 @@ dl_find_symbol(librefptr,symname)
void (*entry)();
vmssts sts;
- DLDEBUG(1,fprintf(stderr,"dl_find_dymbol(%.*s,%.*s):\n",
+ 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,fprintf(stderr,"\tlib$find_image_symbol returns %d\n",sts));
- DLDEBUG(2,fprintf(stderr,"\tentry point is %d\n",
+ 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 */
@@ -339,7 +341,7 @@ dl_install_xsub(perl_name, symref, filename="$Package")
void * symref
char * filename
CODE:
- DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
+ 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)));
diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c b/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c
index 67dea787cc7..58006789ef6 100644
--- a/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c
+++ b/gnu/usr.bin/perl/ext/DynaLoader/dlutils.c
@@ -35,7 +35,7 @@ dl_generic_private_init() /* called by dl_*.xs dl_private_init() */
if ( (perl_dl_nonlazy = getenv("PERL_DL_NONLAZY")) != NULL )
dl_nonlazy = atoi(perl_dl_nonlazy);
if (dl_nonlazy)
- DLDEBUG(1,fprintf(stderr,"DynaLoader bind mode is 'non-lazy'\n"));
+ 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 */
@@ -75,22 +75,10 @@ SaveError(pat, va_alist)
if (LastError)
LastError = (char*)saferealloc(LastError, len) ;
else
- LastError = safemalloc(len) ;
+ LastError = (char *) safemalloc(len) ;
/* Copy message into LastError (including terminating null char) */
strncpy(LastError, message, len) ;
- DLDEBUG(2,fprintf(stderr,"DynaLoader: stored error msg '%s'\n",LastError));
-}
-
-
-/* prepend underscore to s. write into buf. return buf. */
-char *
-dl_add_underscore(s, buf)
-char *s;
-char *buf;
-{
- *buf = '_';
- (void)strcpy(buf + 1, s);
- return buf;
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "DynaLoader: stored error msg '%s'\n",LastError));
}
diff --git a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm
index 32a31943269..6214323c31c 100644
--- a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm
+++ b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.pm
@@ -7,6 +7,7 @@ Fcntl - load the C Fcntl.h defines
=head1 SYNOPSIS
use Fcntl;
+ use Fcntl qw(:DEFAULT :flock);
=head1 DESCRIPTION
@@ -21,28 +22,57 @@ far more likely chance of getting the numbers right.
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 $AUTOLOAD);
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD);
require Exporter;
-use AutoLoader;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
-$VERSION = "1.00";
+$VERSION = "1.03";
# Items to export into callers namespace by default
# (move infrequently used names to @EXPORT_OK below)
@EXPORT =
qw(
F_DUPFD F_GETFD F_GETLK F_SETFD F_GETFL F_SETFL F_SETLK F_SETLKW
- FD_CLOEXEC F_RDLCK F_UNLCK F_WRLCK
+ FD_CLOEXEC F_RDLCK F_UNLCK F_WRLCK F_POSIX
O_CREAT O_EXCL O_NOCTTY O_TRUNC
O_APPEND O_NONBLOCK
- O_NDELAY
+ O_NDELAY O_DEFER
O_RDONLY O_RDWR O_WRONLY
+ O_BINARY O_TEXT
+ O_EXLOCK O_SHLOCK O_ASYNC O_DSYNC O_RSYNC O_SYNC
+ F_SETOWN F_GETOWN
);
+
# Other items we are prepared to export if requested
@EXPORT_OK = qw(
+ LOCK_SH LOCK_EX LOCK_NB LOCK_UN
+ FAPPEND FASYNC FCREAT FDEFER FEXCL FNDELAY FNONBLOCK FSYNC FTRUNC
+);
+# 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 {
@@ -66,8 +96,4 @@ sub AUTOLOAD {
bootstrap Fcntl $VERSION;
-# Preloaded methods go here. Autoload methods go after __END__, and are
-# processed by the autosplit program.
-package Fcntl; # return to package Fcntl so AutoSplit is happy
1;
-__END__
diff --git a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs
index 90f3af5028c..9034031c9ca 100644
--- a/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs
+++ b/gnu/usr.bin/perl/ext/Fcntl/Fcntl.xs
@@ -57,6 +57,12 @@ int arg;
#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_SETFD"))
#ifdef F_SETFD
return F_SETFD;
@@ -69,6 +75,12 @@ int arg;
#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_SETFL"))
#ifdef F_SETFL
return F_SETFL;
@@ -87,6 +99,12 @@ int arg;
#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_RDLCK"))
#ifdef F_RDLCK
return F_RDLCK;
@@ -107,14 +125,93 @@ int arg;
#endif
errno = EINVAL;
return 0;
- } else
- if (strEQ(name, "FD_CLOEXEC"))
+ }
+ 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, "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_CREAT"))
@@ -183,6 +280,48 @@ int arg;
#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_SHLOCK"))
+#ifdef O_SHLOCK
+ return O_SHLOCK;
+#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_DSYNC"))
+#ifdef O_DSYNC
+ return O_DSYNC;
+#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_SYNC"))
+#ifdef O_SYNC
+ return O_SYNC;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "O_DEFER"))
+#ifdef O_DEFER
+ return O_DEFER;
+#else
+ goto not_there;
+#endif
} else
goto not_there;
break;
diff --git a/gnu/usr.bin/perl/ext/FileHandle/FileHandle.pm b/gnu/usr.bin/perl/ext/FileHandle/FileHandle.pm
deleted file mode 100644
index 2770b91c7fb..00000000000
--- a/gnu/usr.bin/perl/ext/FileHandle/FileHandle.pm
+++ /dev/null
@@ -1,467 +0,0 @@
-package FileHandle;
-
-=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
-
-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 in either Perl form (">", "+<", etc.) or POSIX form
-("w", "r+", etc.).
-
-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
-
-=head1 SEE ALSO
-
-L<perlfunc>,
-L<perlop/"I/O Operators">,
-L<POSIX/"FileHandle">
-
-=head1 BUGS
-
-Due to backwards compatibility, all filehandles resemble objects
-of class C<FileHandle>, or actually classes derived from that class.
-They actually aren't. Which means you can't derive your own
-class from C<FileHandle> and inherit those methods.
-
-=cut
-
-require 5.000;
-use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD);
-use Carp;
-use Symbol;
-use SelectSaver;
-
-require Exporter;
-require DynaLoader;
-@ISA = qw(Exporter DynaLoader);
-
-$VERSION = "1.00" ;
-
-@EXPORT = qw(_IOFBF _IOLBF _IONBF);
-
-@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
-
- print
- printf
- getline
- getlines
-);
-
-
-################################################
-## If the Fcntl extension is available,
-## export its constants.
-##
-
-sub import {
- my $pkg = shift;
- my $callpkg = caller;
- Exporter::export $pkg, $callpkg;
- eval {
- require Fcntl;
- Exporter::export 'Fcntl', $callpkg;
- };
-};
-
-
-################################################
-## Interaction with the XS.
-##
-
-eval {
- bootstrap FileHandle;
-};
-if ($@) {
- *constant = sub { undef };
-}
-
-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 FileHandle macro";
- *$AUTOLOAD = sub { $val };
- goto &$AUTOLOAD;
-}
-
-
-################################################
-## Constructors, destructors.
-##
-
-sub new {
- @_ >= 1 && @_ <= 3 or croak 'usage: new FileHandle [FILENAME [,MODE]]';
- my $class = shift;
- my $fh = gensym;
- if (@_) {
- FileHandle::open($fh, @_)
- or return undef;
- }
- bless $fh, $class;
-}
-
-sub new_from_fd {
- @_ == 3 or croak 'usage: new_from_fd FileHandle FD, MODE';
- my $class = shift;
- my $fh = gensym;
- FileHandle::fdopen($fh, @_)
- or return undef;
- bless $fh, $class;
-}
-
-sub DESTROY {
- my ($fh) = @_;
- close($fh);
-}
-
-################################################
-## Open and close.
-##
-
-sub pipe {
- @_ and croak 'usage: FileHandle::pipe()';
- my $readfh = new FileHandle;
- my $writefh = new FileHandle;
- pipe($readfh, $writefh)
- or return undef;
- ($readfh, $writefh);
-}
-
-sub _open_mode_string {
- my ($mode) = @_;
- $mode =~ /^\+?(<|>>?)$/
- or $mode =~ s/^r(\+?)$/$1</
- or $mode =~ s/^w(\+?)$/$1>/
- or $mode =~ s/^a(\+?)$/$1>>/
- or croak "FileHandle: bad open mode: $mode";
- $mode;
-}
-
-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 unless $file =~ m#^/#;
- $file = _open_mode_string($mode) . " $file\0";
- }
- open($fh, $file);
-}
-
-sub fdopen {
- @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
- my ($fh, $fd, $mode) = @_;
- if (ref($fd) =~ /GLOB\(/) {
- # It's a glob reference; remove the star from its name.
- ($fd = "".$$fd) =~ s/^\*//;
- } elsif ($fd =~ m#^\d+$#) {
- # It's an FD number; prefix with "=".
- $fd = "=$fd";
- }
- open($fh, _open_mode_string($mode) . '&' . $fd);
-}
-
-sub close {
- @_ == 1 or croak 'usage: $fh->close()';
- close($_[0]);
-}
-
-################################################
-## Normal I/O functions.
-##
-
-sub fileno {
- @_ == 1 or croak 'usage: $fh->fileno()';
- fileno($_[0]);
-}
-
-sub getc {
- @_ == 1 or croak 'usage: $fh->getc()';
- getc($_[0]);
-}
-
-sub gets {
- @_ == 1 or croak 'usage: $fh->gets()';
- my ($handle) = @_;
- scalar <$handle>;
-}
-
-sub eof {
- @_ == 1 or croak 'usage: $fh->eof()';
- eof($_[0]);
-}
-
-sub clearerr {
- @_ == 1 or croak 'usage: $fh->clearerr()';
- seek($_[0], 0, 1);
-}
-
-sub seek {
- @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
- seek($_[0], $_[1], $_[2]);
-}
-
-sub tell {
- @_ == 1 or croak 'usage: $fh->tell()';
- tell($_[0]);
-}
-
-sub print {
- @_ or croak 'usage: $fh->print([ARGS])';
- my $this = shift;
- print $this @_;
-}
-
-sub printf {
- @_ or croak 'usage: $fh->printf([ARGS])';
- my $this = shift;
- printf $this @_;
-}
-
-sub getline {
- @_ == 1 or croak 'usage: $fh->getline';
- my $this = shift;
- return scalar <$this>;
-}
-
-sub getlines {
- @_ == 1 or croak 'usage: $fh->getline()';
- my $this = shift;
- wantarray or croak "Can't call FileHandle::getlines in a scalar context";
- return <$this>;
-}
-
-################################################
-## State modification functions.
-##
-
-sub autoflush {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $|;
- $| = @_ > 1 ? $_[1] : 1;
- $prev;
-}
-
-sub output_field_separator {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $,;
- $, = $_[1] if @_ > 1;
- $prev;
-}
-
-sub output_record_separator {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $\;
- $\ = $_[1] if @_ > 1;
- $prev;
-}
-
-sub input_record_separator {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $/;
- $/ = $_[1] if @_ > 1;
- $prev;
-}
-
-sub input_line_number {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $.;
- $. = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_page_number {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $%;
- $% = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_lines_per_page {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $=;
- $= = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_lines_left {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $-;
- $- = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_name {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $~;
- $~ = qualify($_[1], caller) if @_ > 1;
- $prev;
-}
-
-sub format_top_name {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $^;
- $^ = qualify($_[1], caller) if @_ > 1;
- $prev;
-}
-
-sub format_line_break_characters {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $:;
- $: = $_[1] if @_ > 1;
- $prev;
-}
-
-sub format_formfeed {
- my $old = new SelectSaver qualify($_[0], caller);
- my $prev = $^L;
- $^L = $_[1] if @_ > 1;
- $prev;
-}
-
-1;
diff --git a/gnu/usr.bin/perl/ext/FileHandle/FileHandle.xs b/gnu/usr.bin/perl/ext/FileHandle/FileHandle.xs
deleted file mode 100644
index 3a99cf1dc88..00000000000
--- a/gnu/usr.bin/perl/ext/FileHandle/FileHandle.xs
+++ /dev/null
@@ -1,177 +0,0 @@
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-#include <stdio.h>
-
-typedef int SysRet;
-typedef FILE * InputStream;
-typedef FILE * OutputStream;
-
-static int
-not_here(s)
-char *s;
-{
- croak("FileHandle::%s not implemented on this architecture", s);
- return -1;
-}
-
-static bool
-constant(name, pval)
-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;
- }
-
- return FALSE;
-}
-
-
-MODULE = FileHandle PACKAGE = FileHandle PREFIX = f
-
-SV *
-constant(name)
- char * name
- CODE:
- IV i;
- if (constant(name, &i))
- RETVAL = newSViv(i);
- else
- RETVAL = &sv_undef;
- OUTPUT:
- RETVAL
-
-SV *
-fgetpos(handle)
- InputStream handle
- CODE:
-#ifdef HAS_FGETPOS
- if (handle) {
- Fpos_t pos;
- fgetpos(handle, &pos);
- ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
- }
- else {
- ST(0) = &sv_undef;
- errno = EINVAL;
- }
-#else
- ST(0) = (SV *) not_here("fgetpos");
-#endif
-
-SysRet
-fsetpos(handle, pos)
- InputStream handle
- SV * pos
- CODE:
-#ifdef HAS_FSETPOS
- if (handle)
- RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos));
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
-#else
- RETVAL = (SysRet) not_here("fsetpos");
-#endif
- OUTPUT:
- RETVAL
-
-int
-ungetc(handle, c)
- InputStream handle
- int c
- CODE:
- if (handle)
- RETVAL = ungetc(c, handle);
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
- OUTPUT:
- RETVAL
-
-OutputStream
-new_tmpfile(packname = "FileHandle")
- char * packname
- CODE:
- RETVAL = tmpfile();
- OUTPUT:
- RETVAL
-
-int
-ferror(handle)
- InputStream handle
- CODE:
- if (handle)
- RETVAL = ferror(handle);
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
- OUTPUT:
- RETVAL
-
-SysRet
-fflush(handle)
- OutputStream handle
- CODE:
- if (handle)
- RETVAL = fflush(handle);
- 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)
- setbuf(handle, buf);
-
-
-
-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:
-#ifdef _IOFBF /* Should be HAS_SETVBUF once Configure tests for that */
- if (handle)
- RETVAL = setvbuf(handle, buf, type, size);
- else {
- RETVAL = -1;
- errno = EINVAL;
- }
-#else
- RETVAL = (SysRet) not_here("setvbuf");
-#endif /* _IOFBF */
- OUTPUT:
- RETVAL
-
diff --git a/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm b/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm
index 3f1d83e0049..9c7ae066b79 100644
--- a/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm
+++ b/gnu/usr.bin/perl/ext/GDBM_File/GDBM_File.pm
@@ -7,7 +7,7 @@ GDBM_File - Perl5 access to the gdbm library.
=head1 SYNOPSIS
use GDBM_File ;
- tie %hash, GDBM_File, $filename, &GDBM_WRCREAT, 0640);
+ tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640);
# Use the %hash array.
untie %hash ;
diff --git a/gnu/usr.bin/perl/ext/GDBM_File/typemap b/gnu/usr.bin/perl/ext/GDBM_File/typemap
index a6b0e5faa86..a9b73d8b811 100644
--- a/gnu/usr.bin/perl/ext/GDBM_File/typemap
+++ b/gnu/usr.bin/perl/ext/GDBM_File/typemap
@@ -23,3 +23,5 @@ 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/gnu/usr.bin/perl/ext/IO/IO.pm b/gnu/usr.bin/perl/ext/IO/IO.pm
new file mode 100644
index 00000000000..1ba05ca9165
--- /dev/null
+++ b/gnu/usr.bin/perl/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 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.
+
+=cut
+
+use IO::Handle;
+use IO::Seekable;
+use IO::File;
+use IO::Pipe;
+use IO::Socket;
+
+1;
+
diff --git a/gnu/usr.bin/perl/ext/IO/IO.xs b/gnu/usr.bin/perl/ext/IO/IO.xs
new file mode 100644
index 00000000000..e558d5c4e0a
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/IO.xs
@@ -0,0 +1,288 @@
+#include "EXTERN.h"
+#define PERLIO_NOT_STDIO 1
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef I_UNISTD
+# include <unistd.h>
+#endif
+#ifdef I_FCNTL
+# include <fcntl.h>
+#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(s)
+char *s;
+{
+ croak("%s not implemented on this architecture", s);
+ return -1;
+}
+
+static bool
+constant(name, pval)
+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) = &sv_undef;
+ errno = EINVAL;
+ }
+
+SysRet
+fsetpos(handle, pos)
+ InputStream handle
+ SV * pos
+ CODE:
+ char *p;
+ if (handle && (p = SvPVx(pos, na)) && 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) = &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) = &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/gnu/usr.bin/perl/ext/FileHandle/Makefile.PL b/gnu/usr.bin/perl/ext/IO/Makefile.PL
index 7efd382043f..4a34be61fbb 100644
--- a/gnu/usr.bin/perl/ext/FileHandle/Makefile.PL
+++ b/gnu/usr.bin/perl/ext/IO/Makefile.PL
@@ -1,7 +1,8 @@
use ExtUtils::MakeMaker;
WriteMakefile(
- NAME => 'FileHandle',
+ NAME => 'IO',
MAN3PODS => ' ', # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
- VERSION_FROM => 'FileHandle.pm',
+ VERSION_FROM => 'lib/IO/Handle.pm',
+ XS_VERSION => 1.15
);
diff --git a/gnu/usr.bin/perl/ext/IO/README b/gnu/usr.bin/perl/ext/IO/README
new file mode 100644
index 00000000000..e855afade40
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm
new file mode 100644
index 00000000000..de7fabc6f25
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm
new file mode 100644
index 00000000000..39e32f05abb
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm
@@ -0,0 +1,544 @@
+
+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.1504";
+$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);
+ my $prev = $|;
+ $| = @_ > 1 ? $_[1] : 1;
+ $prev;
+}
+
+sub output_field_separator {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $,;
+ $, = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub output_record_separator {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $\;
+ $\ = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub input_record_separator {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $/;
+ $/ = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub input_line_number {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $.;
+ $. = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_page_number {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $%;
+ $% = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_lines_per_page {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $=;
+ $= = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_lines_left {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $-;
+ $- = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_name {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $~;
+ $~ = qualify($_[1], caller) if @_ > 1;
+ $prev;
+}
+
+sub format_top_name {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $^;
+ $^ = qualify($_[1], caller) if @_ > 1;
+ $prev;
+}
+
+sub format_line_break_characters {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $:;
+ $: = $_[1] if @_ > 1;
+ $prev;
+}
+
+sub format_formfeed {
+ my $old = new SelectSaver qualify($_[0], caller);
+ 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);
+ write($fh);
+ $fh->format_name($oldfmt);
+ } else {
+ 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/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm
new file mode 100644
index 00000000000..ae6d9a547e2
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm
new file mode 100644
index 00000000000..91c381a61e9
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm
new file mode 100644
index 00000000000..dea684a62ed
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm
new file mode 100644
index 00000000000..aadb502f193
--- /dev/null
+++ b/gnu/usr.bin/perl/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,$fh1,$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/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm b/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm
index 6072e651fcc..47b1f5aa3c2 100644
--- a/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm
+++ b/gnu/usr.bin/perl/ext/NDBM_File/NDBM_File.pm
@@ -28,7 +28,7 @@ NDBM_File - Tied access to ndbm files
use NDBM_File;
- tie(%h,NDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640);
+ tie(%h, 'NDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640);
untie %h;
diff --git a/gnu/usr.bin/perl/ext/NDBM_File/hints/dec_osf.pl b/gnu/usr.bin/perl/ext/NDBM_File/hints/dec_osf.pl
new file mode 100644
index 00000000000..e96d907e10a
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/NDBM_File/hints/dec_osf.pl
@@ -0,0 +1,2 @@
+# Spider Boardman <spider@Orb.Nashua.NH.US>
+$self->{LIBS} = [''];
diff --git a/gnu/usr.bin/perl/ext/NDBM_File/hints/dynixptx.pl b/gnu/usr.bin/perl/ext/NDBM_File/hints/dynixptx.pl
new file mode 100644
index 00000000000..d402c179014
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/ext/NDBM_File/typemap b/gnu/usr.bin/perl/ext/NDBM_File/typemap
index a6b0e5faa86..a9b73d8b811 100644
--- a/gnu/usr.bin/perl/ext/NDBM_File/typemap
+++ b/gnu/usr.bin/perl/ext/NDBM_File/typemap
@@ -23,3 +23,5 @@ 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/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm
index e5386e853b7..923640ff348 100644
--- a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm
+++ b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.pm
@@ -24,7 +24,7 @@ ODBM_File - Tied access to odbm files
use ODBM_File;
- tie(%h,ODBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640);
+ tie(%h, 'ODBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640);
untie %h;
diff --git a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs
index c1b405ff89b..b57e560bd39 100644
--- a/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs
+++ b/gnu/usr.bin/perl/ext/ODBM_File/ODBM_File.xs
@@ -13,6 +13,21 @@
# 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;
@@ -39,9 +54,11 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
int mode
CODE:
{
- char tmpbuf[1025];
+ 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, &statbuf) < 0) {
if (flags & O_CREAT) {
@@ -56,7 +73,7 @@ odbm_TIEHASH(dbtype, filename, flags, mode)
}
RETVAL = (void*)(dbminit(filename) >= 0 ? &dbmrefcnt : 0);
ST(0) = sv_mortalcopy(&sv_undef);
- sv_setptrobj(ST(0), RETVAL, "ODBM_File");
+ sv_setptrobj(ST(0), RETVAL, dbtype);
}
void
diff --git a/gnu/usr.bin/perl/ext/ODBM_File/hints/dec_osf.pl b/gnu/usr.bin/perl/ext/ODBM_File/hints/dec_osf.pl
index f041bf96c00..febb7cdb21a 100644
--- a/gnu/usr.bin/perl/ext/ODBM_File/hints/dec_osf.pl
+++ b/gnu/usr.bin/perl/ext/ODBM_File/hints/dec_osf.pl
@@ -3,3 +3,7 @@
# 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/gnu/usr.bin/perl/ext/ODBM_File/hints/hpux.pl b/gnu/usr.bin/perl/ext/ODBM_File/hints/hpux.pl
new file mode 100644
index 00000000000..31f9d24bcae
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/ext/ODBM_File/hints/ultrix.pl b/gnu/usr.bin/perl/ext/ODBM_File/hints/ultrix.pl
new file mode 100644
index 00000000000..31f9d24bcae
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/ext/Opcode/Makefile.PL b/gnu/usr.bin/perl/ext/Opcode/Makefile.PL
new file mode 100644
index 00000000000..7fdcdf6ac13
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Opcode/Makefile.PL
@@ -0,0 +1,7 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+ NAME => 'Opcode',
+ MAN3PODS => ' ',
+ VERSION_FROM => 'Opcode.pm',
+ XS_VERSION => '1.02'
+);
diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.pm b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm
new file mode 100644
index 00000000000..a35ad1b47b4
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm
@@ -0,0 +1,569 @@
+package Opcode;
+
+require 5.002;
+
+use vars qw($VERSION $XS_VERSION @ISA @EXPORT_OK);
+
+$VERSION = "1.04";
+$XS_VERSION = "1.02";
+
+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 being 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
+
+ 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 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 :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
+
+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 E<lt>F<Tim.Bunce@ig.co.uk>E<gt>.
+
+=cut
+
diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.xs b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs
new file mode 100644
index 00000000000..9d4b726536a
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs
@@ -0,0 +1,472 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/* maxo shouldn't differ from MAXO but leave room anyway (see BOOT:) */
+#define OP_MASK_BUF_SIZE (MAXO + 100)
+
+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__
+ */
+
+static void
+op_names_init()
+{
+ int i;
+ STRLEN len;
+ char *opname;
+ char *bitmap;
+
+ op_named_bits = newHV();
+ for(i=0; i < maxo; ++i) {
+ hv_store(op_named_bits, op_name[i],strlen(op_name[i]),
+ Sv=newSViv(i), 0);
+ SvREADONLY_on(Sv);
+ }
+
+ 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] = (maxo & 0x07) ? ~(0xFF << (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(optag, len, mask)
+ 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(opname, len, fatal)
+ 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(old_opset)
+ SV *old_opset;
+{
+ SV *opset;
+ if (old_opset) {
+ verify_opset(old_opset,1);
+ opset = newSVsv(old_opset);
+ }
+ else {
+ opset = newSV(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(opset, fatal)
+ 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(bitmap, bitspec, on, opname)
+ 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 >= 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(opset) /* THE ONLY FUNCTION TO EDIT op_mask ITSELF */
+ SV *opset;
+{
+ int i,j;
+ char *bitmask;
+ STRLEN len;
+ int myopcode = 0;
+
+ verify_opset(opset,1); /* croaks on bad opset */
+
+ if (!op_mask) /* caller must ensure op_mask exists */
+ croak("Can't add to uninitialised 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 < maxo; )
+ op_mask[myopcode++] |= bits & (1 << j++);
+ }
+}
+
+static void
+opmask_addlocal(opset, op_mask_buf) /* Localise op_mask then opmask_add() */
+ SV *opset;
+ char *op_mask_buf;
+{
+ char *orig_op_mask = op_mask;
+ SAVEPPTR(op_mask);
+ if (opcode_debug >= 2)
+ SAVEDESTRUCTOR((void(*)_((void*)))warn,"op_mask restored");
+ op_mask = &op_mask_buf[0];
+ if (orig_op_mask)
+ Copy(orig_op_mask, op_mask, maxo, char);
+ else
+ Zero(op_mask, maxo, char);
+ opmask_add(opset);
+}
+
+
+
+MODULE = Opcode PACKAGE = Opcode
+
+PROTOTYPES: ENABLE
+
+BOOT:
+ assert(maxo < OP_MASK_BUF_SIZE);
+ opset_len = (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(&endav);
+ endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */
+
+ save_hptr(&defstash); /* save current default stack */
+ /* the assignment to global defstash changes our sense of 'main' */
+ 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(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 = new_opset(opset); /* verify and clone opset */
+ bitmap = SvPVX(opset);
+ while(len-- > 0)
+ bitmap[len] = ~bitmap[len];
+ /* take care of extra bits beyond maxo in last byte */
+ if (maxo & 07)
+ bitmap[opset_len-1] &= ~(0xFF << (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) ? op_desc : op_name;
+ verify_opset(opset,1);
+ for (myopcode=0, i=0; i < opset_len; i++) {
+ U16 bits = bitmap[i];
+ for (j=0; j < 8 && myopcode < 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 = 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, 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) = &sv_yes;
+
+
+
+void
+opdesc(...)
+ PPCODE:
+ int i, myopcode;
+ STRLEN len;
+ SV **args;
+ /* 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 >= 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,na);
+ myopcode = 0;
+ for (b=0; b < opset_len; b++) {
+ U16 bits = bitmap[b];
+ for (j=0; j < 8 && myopcode < 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) = &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 (!op_mask)
+ Newz(0, op_mask, maxo, char);
+
+void
+opcodes()
+ PPCODE:
+ if (GIMME == G_ARRAY) {
+ croak("opcodes in list context not yet implemented"); /* XXX */
+ }
+ else {
+ XPUSHs(sv_2mortal(newSViv(maxo)));
+ }
+
+void
+opmask()
+ CODE:
+ ST(0) = sv_2mortal(new_opset(Nullsv));
+ if (op_mask) {
+ char *bitmap = SvPVX(ST(0));
+ int myopcode;
+ for(myopcode=0; myopcode < maxo; ++myopcode) {
+ if (op_mask[myopcode])
+ bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07);
+ }
+ }
+
diff --git a/gnu/usr.bin/perl/ext/Opcode/Safe.pm b/gnu/usr.bin/perl/ext/Opcode/Safe.pm
new file mode 100644
index 00000000000..c9d741647ec
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Opcode/Safe.pm
@@ -0,0 +1,555 @@
+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 if $obj->{Erase};
+}
+
+sub erase {
+ my $obj= shift;
+ 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\::"};
+
+ $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/gnu/usr.bin/perl/ext/Opcode/ops.pm b/gnu/usr.bin/perl/ext/Opcode/ops.pm
new file mode 100644
index 00000000000..b9ea36cef39
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/ext/POSIX/POSIX.pm b/gnu/usr.bin/perl/ext/POSIX/POSIX.pm
index 66b55c15651..2885c0d84c8 100644
--- a/gnu/usr.bin/perl/ext/POSIX/POSIX.pm
+++ b/gnu/usr.bin/perl/ext/POSIX/POSIX.pm
@@ -11,7 +11,7 @@ require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
-$VERSION = "1.00" ;
+$VERSION = "1.02" ;
%EXPORT_TAGS = (
@@ -22,11 +22,19 @@ $VERSION = "1.00" ;
dirent_h => [qw()],
- errno_h => [qw(E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM
- EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE
- EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK
- ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO
- EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV errno)],
+ 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
@@ -72,12 +80,13 @@ $VERSION = "1.00" ;
setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)],
- signal_h => [qw(SA_NOCLDSTOP 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)],
+ 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()],
@@ -96,7 +105,7 @@ $VERSION = "1.00" ;
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 stroul wcstombs wctomb)],
+ qsort realloc strtod strtol strtoul wcstombs wctomb)],
string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat
strchr strcmp strcoll strcpy strcspn strerror strlen
@@ -194,7 +203,7 @@ sub AUTOLOAD {
local $! = 0;
my $constname = $AUTOLOAD;
$constname =~ s/.*:://;
- my $val = constant($constname, $_[0]);
+ my $val = constant($constname, @_ ? $_[0] : 0);
if ($! == 0) {
*$AUTOLOAD = sub { $val };
}
@@ -231,7 +240,7 @@ sub unimpl {
package POSIX::SigAction;
sub new {
- bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3]};
+ bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0}, $_[0];
}
############################
@@ -377,7 +386,7 @@ sub kill {
sub raise {
usage "raise(sig)" if @_ != 1;
- kill $$, $_[0]; # Is this good enough?
+ kill $_[0], $$; # Is this good enough?
}
sub offsetof {
@@ -385,35 +394,35 @@ sub offsetof {
}
sub clearerr {
- redef "FileHandle::clearerr()";
+ redef "IO::Handle::clearerr()";
}
sub fclose {
- redef "FileHandle::close()";
+ redef "IO::Handle::close()";
}
sub fdopen {
- redef "FileHandle::new_from_fd()";
+ redef "IO::Handle::new_from_fd()";
}
sub feof {
- redef "FileHandle::eof()";
+ redef "IO::Handle::eof()";
}
sub fgetc {
- redef "FileHandle::getc()";
+ redef "IO::Handle::getc()";
}
sub fgets {
- redef "FileHandle::gets()";
+ redef "IO::Handle::gets()";
}
sub fileno {
- redef "FileHandle::fileno()";
+ redef "IO::Handle::fileno()";
}
sub fopen {
- redef "FileHandle::open()";
+ redef "IO::File::open()";
}
sub fprintf {
@@ -441,27 +450,27 @@ sub fscanf {
}
sub fseek {
- redef "FileHandle::seek()";
+ redef "IO::Seekable::seek()";
}
sub ferror {
- redef "FileHandle::error()";
+ redef "IO::Handle::error()";
}
sub fflush {
- redef "FileHandle::flush()";
+ redef "IO::Handle::flush()";
}
sub fgetpos {
- redef "FileHandle::getpos()";
+ redef "IO::Seekable::getpos()";
}
sub fsetpos {
- redef "FileHandle::setpos()";
+ redef "IO::Seekable::setpos()";
}
sub ftell {
- redef "FileHandle::tell()";
+ redef "IO::Seekable::tell()";
}
sub fwrite {
@@ -534,11 +543,11 @@ sub sscanf {
}
sub tmpfile {
- redef "FileHandle::new_tmpfile()";
+ redef "IO::File::new_tmpfile()";
}
sub ungetc {
- redef "FileHandle::ungetc()";
+ redef "IO::Handle::ungetc()";
}
sub vfprintf {
@@ -628,18 +637,6 @@ sub srand {
unimpl "srand()";
}
-sub strtod {
- unimpl "strtod() is C-specific, stopped";
-}
-
-sub strtol {
- unimpl "strtol() is C-specific, stopped";
-}
-
-sub stroul {
- unimpl "stroul() is C-specific, stopped";
-}
-
sub system {
usage "system(command)" if @_ != 1;
system($_[0]);
diff --git a/gnu/usr.bin/perl/ext/POSIX/POSIX.pod b/gnu/usr.bin/perl/ext/POSIX/POSIX.pod
index 4b7585117c6..c781765a146 100644
--- a/gnu/usr.bin/perl/ext/POSIX/POSIX.pod
+++ b/gnu/usr.bin/perl/ext/POSIX/POSIX.pod
@@ -155,7 +155,7 @@ This is identical to Perl's builtin C<chown()> function.
=item clearerr
-Use method C<FileHandle::clearerr()> instead.
+Use method C<IO::Handle::clearerr()> instead.
=item clock
@@ -277,7 +277,7 @@ This is identical to Perl's builtin C<abs()> function.
=item fclose
-Use method C<FileHandle::close()> instead.
+Use method C<IO::Handle::close()> instead.
=item fcntl
@@ -285,35 +285,35 @@ This is identical to Perl's builtin C<fcntl()> function.
=item fdopen
-Use method C<FileHandle::new_from_fd()> instead.
+Use method C<IO::Handle::new_from_fd()> instead.
=item feof
-Use method C<FileHandle::eof()> instead.
+Use method C<IO::Handle::eof()> instead.
=item ferror
-Use method C<FileHandle::error()> instead.
+Use method C<IO::Handle::error()> instead.
=item fflush
-Use method C<FileHandle::flush()> instead.
+Use method C<IO::Handle::flush()> instead.
=item fgetc
-Use method C<FileHandle::getc()> instead.
+Use method C<IO::Handle::getc()> instead.
=item fgetpos
-Use method C<FileHandle::getpos()> instead.
+Use method C<IO::Seekable::getpos()> instead.
=item fgets
-Use method C<FileHandle::gets()> instead.
+Use method C<IO::Handle::gets()> instead.
=item fileno
-Use method C<FileHandle::fileno()> instead.
+Use method C<IO::Handle::fileno()> instead.
=item floor
@@ -325,7 +325,7 @@ This is identical to the C function C<fmod()>.
=item fopen
-Use method C<FileHandle::open()> instead.
+Use method C<IO::File::open()> instead.
=item fork
@@ -380,11 +380,11 @@ fscanf() is C-specific--use <> and regular expressions instead.
=item fseek
-Use method C<FileHandle::seek()> instead.
+Use method C<IO::Seekable::seek()> instead.
=item fsetpos
-Use method C<FileHandle::setpos()> instead.
+Use method C<IO::Seekable::setpos()> instead.
=item fstat
@@ -397,7 +397,7 @@ Perl's builtin C<stat> function.
=item ftell
-Use method C<FileHandle::tell()> instead.
+Use method C<IO::Seekable::tell()> instead.
=item fwrite
@@ -606,7 +606,7 @@ longjmp() is C-specific: use die instead.
=item lseek
-Move the read/write file pointer. This uses file descriptors such as
+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 );
@@ -849,10 +849,30 @@ setjmp() is C-specific: use eval {} instead.
Modifies and queries program's locale.
-The following will set the traditional UNIX system locale behavior.
+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()>.
@@ -1040,7 +1060,26 @@ This is identical to Perl's builtin C<index()> function.
=item strtod
-strtod() is C-specific.
+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
@@ -1048,7 +1087,42 @@ strtok() is C-specific.
=item strtol
-strtol() is C-specific.
+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
@@ -1130,7 +1204,7 @@ seconds.
=item tmpfile
-Use method C<FileHandle::new_tmpfile()> instead.
+Use method C<IO::File::new_tmpfile()> instead.
=item tmpnam
@@ -1173,7 +1247,7 @@ Get name of current operating system.
=item ungetc
-Use method C<FileHandle::ungetc()> instead.
+Use method C<IO::Handle::ungetc()> instead.
=item unlink
@@ -1240,9 +1314,10 @@ 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. The third parameter contains the C<sa_flags>.
+object, it defaults to the empty set. The third parameter contains the
+C<sa_flags>, it defaults to 0.
- $sigset = POSIX::SigSet->new;
+ $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()>
@@ -1393,7 +1468,7 @@ Returns C<undef> on failure.
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( 1, &POSIX::VEOF );
+ $termios->setcc( &POSIX::VEOF, 1 );
=item setcflag
@@ -1501,7 +1576,16 @@ _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_M
=item Constants
-E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV
+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
@@ -1561,7 +1645,11 @@ HUGE_VAL
=item Constants
-SA_NOCLDSTOP 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
+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
diff --git a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs b/gnu/usr.bin/perl/ext/POSIX/POSIX.xs
index 3ba3c5b4269..a09eafe37af 100644
--- a/gnu/usr.bin/perl/ext/POSIX/POSIX.xs
+++ b/gnu/usr.bin/perl/ext/POSIX/POSIX.xs
@@ -1,4 +1,5 @@
#include "EXTERN.h"
+#define PERLIO_NOT_STDIO 1
#include "perl.h"
#include "XSUB.h"
#include <ctype.h>
@@ -32,7 +33,6 @@
#if defined(I_TERMIOS)
#include <termios.h>
#endif
-#include <stdio.h>
#ifdef I_STDLIB
#include <stdlib.h>
#endif
@@ -40,60 +40,68 @@
#include <sys/stat.h>
#include <sys/types.h>
#include <time.h>
-#include <unistd.h>
+#include <unistd.h> /* see hints/sunos_4_1.sh */
+#include <fcntl.h>
+
#if defined(__VMS) && !defined(__POSIX_SOURCE)
-# include <file.h> /* == fcntl.h for DECC; no fcntl.h for VAXC */
# 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 /* #defined in perl.h */
# define mkfifo(a,b) (not_here("mkfifo"),-1)
# define tzset() not_here("tzset")
- /* The default VMS emulation of Unix signals isn't very POSIXish */
- typedef int sigset_t;
-# define sigpending(a) (not_here("sigpending"),0)
+#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>
+#else
+ /* The default VMS emulation of Unix signals isn't very POSIXish */
+ typedef int sigset_t;
+# define sigpending(a) (not_here("sigpending"),0)
- /* sigset_t is atomic under VMS, so these routines are easy */
- int sigemptyset(sigset_t *set) {
+ /* sigset_t is atomic under VMS, so these routines are easy */
+ int sigemptyset(sigset_t *set) {
if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
*set = 0; return 0;
- }
- int sigfillset(sigset_t *set) {
+ }
+ int sigfillset(sigset_t *set) {
int i;
if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
for (i = 0; i < NSIG; i++) *set |= (1 << i);
return 0;
- }
- int sigaddset(sigset_t *set, int sig) {
+ }
+ int sigaddset(sigset_t *set, int sig) {
if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
*set |= (1 << (sig - 1));
return 0;
- }
- int sigdelset(sigset_t *set, int sig) {
+ }
+ int sigdelset(sigset_t *set, int sig) {
if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
*set &= ~(1 << (sig - 1));
return 0;
- }
- int sigismember(sigset_t *set, int sig) {
+ }
+ int sigismember(sigset_t *set, int sig) {
if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
*set & (1 << (sig - 1));
- }
- /* The tools for sigprocmask() are there, just not the routine itself */
-# ifndef SIG_UNBLOCK
-# define SIG_UNBLOCK 1
-# endif
-# ifndef SIG_BLOCK
-# define SIG_BLOCK 2
-# endif
-# ifndef SIG_SETMASK
-# define SIG_SETMASK 3
-# endif
- int sigprocmask(int how, sigset_t *set, sigset_t *oset) {
+ }
+ /* The tools for sigprocmask() are there, just not the routine itself */
+# ifndef SIG_UNBLOCK
+# define SIG_UNBLOCK 1
+# endif
+# ifndef SIG_BLOCK
+# define SIG_BLOCK 2
+# endif
+# ifndef SIG_SETMASK
+# define SIG_SETMASK 3
+# endif
+ int sigprocmask(int how, sigset_t *set, sigset_t *oset) {
if (!set || !oset) {
set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
return -1;
@@ -114,12 +122,13 @@
return -1;
}
return 0;
- }
-# define sigaction sigvec
-# define sa_flags sv_onstack
-# define sa_handler sv_handler
-# define sa_mask sv_mask
-# define sigsuspend(set) sigpause(*set)
+ }
+# define sigaction sigvec
+# define sa_flags sv_onstack
+# define sa_handler sv_handler
+# define sa_mask sv_mask
+# define sigsuspend(set) sigpause(*set)
+# 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];
@@ -152,7 +161,6 @@
}
# define times(t) vms_times(t)
#else
-# include <fcntl.h>
# include <grp.h>
# include <sys/times.h>
# ifdef HAS_UNAME
@@ -190,6 +198,9 @@ typedef struct termios* POSIX__Termios;
/* 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")
@@ -226,6 +237,15 @@ char *cuserid _((char *));
#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
@@ -245,13 +265,6 @@ char *cuserid _((char *));
#define waitpid(a,b,c) not_here("waitpid")
#endif
-#ifndef HAS_FGETPOS
-#define fgetpos(a,b) not_here("fgetpos")
-#endif
-#ifndef HAS_FSETPOS
-#define fsetpos(a,b) not_here("fsetpos")
-#endif
-
#ifndef HAS_MBLEN
#ifndef mblen
#define mblen(a,b) not_here("mblen")
@@ -615,12 +628,36 @@ int arg;
#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"))
@@ -667,6 +704,24 @@ int arg;
#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"))
@@ -675,12 +730,24 @@ int arg;
#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"))
@@ -704,7 +771,27 @@ int arg;
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;
@@ -723,12 +810,24 @@ int arg;
#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
+ if (strEQ(name, "ELOOP"))
+#ifdef ELOOP
+ return ELOOP;
+#else
+ goto not_there;
+#endif
break;
case 'M':
if (strEQ(name, "EMFILE"))
@@ -743,29 +842,71 @@ int arg;
#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, "ENOEXEC"))
-#ifdef ENOEXEC
- return ENOEXEC;
+ if (strEQ(name, "ENOTBLK"))
+#ifdef ENOTBLK
+ return ENOTBLK;
#else
goto not_there;
#endif
- if (strEQ(name, "ENOTTY"))
-#ifdef ENOTTY
- return ENOTTY;
+ if (strEQ(name, "ENOTCONN"))
+#ifdef ENOTCONN
+ return ENOTCONN;
#else
goto not_there;
#endif
@@ -781,6 +922,18 @@ int arg;
#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;
@@ -831,6 +984,12 @@ int arg;
#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"))
@@ -839,12 +998,36 @@ int arg;
#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"))
@@ -853,6 +1036,18 @@ int arg;
#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;
@@ -861,6 +1056,18 @@ int arg;
#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;
@@ -873,7 +1080,49 @@ int arg;
#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
@@ -1483,13 +1732,13 @@ int arg;
goto not_there;
#endif
#ifdef SIG_DFL
- if (strEQ(name, "SIG_DFL")) return (int)SIG_DFL;
+ if (strEQ(name, "SIG_DFL")) return (IV)SIG_DFL;
#endif
#ifdef SIG_ERR
- if (strEQ(name, "SIG_ERR")) return (int)SIG_ERR;
+ if (strEQ(name, "SIG_ERR")) return (IV)SIG_ERR;
#endif
#ifdef SIG_IGN
- if (strEQ(name, "SIG_IGN")) return (int)SIG_IGN;
+ if (strEQ(name, "SIG_IGN")) return (IV)SIG_IGN;
#endif
if (strEQ(name, "SIG_SETMASK"))
#ifdef SIG_SETMASK
@@ -1760,12 +2009,51 @@ int arg;
#else
goto not_there;
#endif
- if (strEQ(name, "SA_NOCLDSTOP"))
+ if (strnEQ(name, "SA_", 3)) {
+ if (strEQ(name, "SA_NOCLDSTOP"))
#ifdef SA_NOCLDSTOP
- return SA_NOCLDSTOP;
+ return SA_NOCLDSTOP;
#else
- goto not_there;
+ 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;
@@ -2511,11 +2799,11 @@ constant(name,arg)
int
isalnum(charstring)
- char * charstring
+ unsigned char * charstring
CODE:
- char *s;
- RETVAL = 1;
- for (s = charstring; *s && RETVAL; s++)
+ unsigned char *s = charstring;
+ unsigned char *e = s + na; /* "na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
if (!isalnum(*s))
RETVAL = 0;
OUTPUT:
@@ -2523,11 +2811,11 @@ isalnum(charstring)
int
isalpha(charstring)
- char * charstring
+ unsigned char * charstring
CODE:
- char *s;
- RETVAL = 1;
- for (s = charstring; *s && RETVAL; s++)
+ unsigned char *s = charstring;
+ unsigned char *e = s + na; /* "na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
if (!isalpha(*s))
RETVAL = 0;
OUTPUT:
@@ -2535,11 +2823,11 @@ isalpha(charstring)
int
iscntrl(charstring)
- char * charstring
+ unsigned char * charstring
CODE:
- char *s;
- RETVAL = 1;
- for (s = charstring; *s && RETVAL; s++)
+ unsigned char *s = charstring;
+ unsigned char *e = s + na; /* "na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
if (!iscntrl(*s))
RETVAL = 0;
OUTPUT:
@@ -2547,11 +2835,11 @@ iscntrl(charstring)
int
isdigit(charstring)
- char * charstring
+ unsigned char * charstring
CODE:
- char *s;
- RETVAL = 1;
- for (s = charstring; *s && RETVAL; s++)
+ unsigned char *s = charstring;
+ unsigned char *e = s + na; /* "na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
if (!isdigit(*s))
RETVAL = 0;
OUTPUT:
@@ -2559,11 +2847,11 @@ isdigit(charstring)
int
isgraph(charstring)
- char * charstring
+ unsigned char * charstring
CODE:
- char *s;
- RETVAL = 1;
- for (s = charstring; *s && RETVAL; s++)
+ unsigned char *s = charstring;
+ unsigned char *e = s + na; /* "na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
if (!isgraph(*s))
RETVAL = 0;
OUTPUT:
@@ -2571,11 +2859,11 @@ isgraph(charstring)
int
islower(charstring)
- char * charstring
+ unsigned char * charstring
CODE:
- char *s;
- RETVAL = 1;
- for (s = charstring; *s && RETVAL; s++)
+ unsigned char *s = charstring;
+ unsigned char *e = s + na; /* "na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
if (!islower(*s))
RETVAL = 0;
OUTPUT:
@@ -2583,11 +2871,11 @@ islower(charstring)
int
isprint(charstring)
- char * charstring
+ unsigned char * charstring
CODE:
- char *s;
- RETVAL = 1;
- for (s = charstring; *s && RETVAL; s++)
+ unsigned char *s = charstring;
+ unsigned char *e = s + na; /* "na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
if (!isprint(*s))
RETVAL = 0;
OUTPUT:
@@ -2595,11 +2883,11 @@ isprint(charstring)
int
ispunct(charstring)
- char * charstring
+ unsigned char * charstring
CODE:
- char *s;
- RETVAL = 1;
- for (s = charstring; *s && RETVAL; s++)
+ unsigned char *s = charstring;
+ unsigned char *e = s + na; /* "na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
if (!ispunct(*s))
RETVAL = 0;
OUTPUT:
@@ -2607,11 +2895,11 @@ ispunct(charstring)
int
isspace(charstring)
- char * charstring
+ unsigned char * charstring
CODE:
- char *s;
- RETVAL = 1;
- for (s = charstring; *s && RETVAL; s++)
+ unsigned char *s = charstring;
+ unsigned char *e = s + na; /* "na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
if (!isspace(*s))
RETVAL = 0;
OUTPUT:
@@ -2619,11 +2907,11 @@ isspace(charstring)
int
isupper(charstring)
- char * charstring
+ unsigned char * charstring
CODE:
- char *s;
- RETVAL = 1;
- for (s = charstring; *s && RETVAL; s++)
+ unsigned char *s = charstring;
+ unsigned char *e = s + na; /* "na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
if (!isupper(*s))
RETVAL = 0;
OUTPUT:
@@ -2631,11 +2919,11 @@ isupper(charstring)
int
isxdigit(charstring)
- char * charstring
+ unsigned char * charstring
CODE:
- char *s;
- RETVAL = 1;
- for (s = charstring; *s && RETVAL; s++)
+ unsigned char *s = charstring;
+ unsigned char *e = s + na; /* "na" set by typemap side effect */
+ for (RETVAL = 1; RETVAL && s < e; s++)
if (!isxdigit(*s))
RETVAL = 0;
OUTPUT:
@@ -2660,6 +2948,7 @@ localeconv()
#ifdef HAS_LOCALECONV
struct lconv *lcbuf;
RETVAL = newHV();
+ SET_NUMERIC_LOCAL();
if (lcbuf = localeconv()) {
/* the strings */
if (lcbuf->decimal_point && *lcbuf->decimal_point)
@@ -2725,9 +3014,67 @@ localeconv()
RETVAL
char *
-setlocale(category, locale)
+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)
@@ -2949,8 +3296,7 @@ read(fd, buffer, nbytes)
SvCUR(sv_buffer) = RETVAL;
SvPOK_only(sv_buffer);
*SvEND(sv_buffer) = '\0';
- if (tainting)
- sv_magic(sv_buffer, 0, 't', 0, 0);
+ SvTAINTED_on(sv_buffer);
}
SysRet
@@ -3033,6 +3379,66 @@ 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(&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(&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(&sv_undef);
+ }
+
SV *
strxfrm(src)
SV * src
@@ -3128,11 +3534,11 @@ times()
clock_t realtime;
realtime = times( &tms );
EXTEND(sp,5);
- PUSHs( sv_2mortal( newSVnv( realtime ) ) );
- PUSHs( sv_2mortal( newSVnv( tms.tms_utime ) ) );
- PUSHs( sv_2mortal( newSVnv( tms.tms_stime ) ) );
- PUSHs( sv_2mortal( newSVnv( tms.tms_cutime ) ) );
- PUSHs( sv_2mortal( newSVnv( tms.tms_cstime ) ) );
+ 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)
diff --git a/gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl b/gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl
new file mode 100644
index 00000000000..d90778398b2
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL b/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL
index 8fc9411768a..02dfd7d84ff 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL
+++ b/gnu/usr.bin/perl/ext/SDBM_File/Makefile.PL
@@ -5,19 +5,22 @@ use ExtUtils::MakeMaker;
# config, all, clean, realclean and sdbm/Makefile
# which perform the corresponding actions in the subdirectory.
+$define = ($^O eq 'MSWin32') ? '-DMSDOS' : '';
+
WriteMakefile(
NAME => 'SDBM_File',
- MYEXTLIB => 'sdbm/libsdbm$(LIB_EXT)',
+ MYEXTLIB => 'sdbm'.($^O eq 'MSWin32' ? '\\' : '/').'libsdbm$(LIB_EXT)',
MAN3PODS => ' ', # Pods will be built by installman.
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'SDBM_File.pm',
+ DEFINE => $define,
);
sub MY::postamble {
'
$(MYEXTLIB): sdbm/Makefile
- cd sdbm; $(MAKE) all
+ cd sdbm && $(MAKE) all
';
}
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm
index 9b7acc1e091..a2d4df85587 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm
+++ b/gnu/usr.bin/perl/ext/SDBM_File/SDBM_File.pm
@@ -24,7 +24,7 @@ SDBM_File - Tied access to sdbm files
use SDBM_File;
- tie(%h,SDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640);
+ tie(%h, 'SDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640);
untie %h;
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL
index b4bd6f9549f..50fd83eb253 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Makefile.PL
@@ -1,28 +1,32 @@
use ExtUtils::MakeMaker;
+
+$define = '-DSDBM -DDUFF';
+$define .= ' -DWIN32' if ($^O eq 'MSWin32');
+
WriteMakefile(
- 'NAME' => 'SDBM_File',
- 'LINKTYPE' => 'static',
- 'DEFINE' => '-DSDBM -DDUFF',
- 'SKIP' => [qw(static static_lib dynamic dynamic_lib)],
- '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)]
+ 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
+ SKIP => [qw(dynamic dynamic_lib)],
+ 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::post_constants {
+'
+INST_STATIC = libsdbm$(LIB_EXT)
+'
+}
sub MY::top_targets {
'
all :: static
-static :: libsdbm$(LIB_EXT)
-
config ::
-libsdbm$(LIB_EXT): $(O_FILES)
- $(AR) cr libsdbm$(LIB_EXT) $(O_FILES)
- $(RANLIB) libsdbm$(LIB_EXT)
-
lint:
lint -abchx $(LIBSRCS)
';
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c
index a02c73f28f6..23bbfe9a67c 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.c
@@ -231,7 +231,7 @@ register int siz;
for (i = 1; i < n; i += 2) {
if (siz == off - ino[i] &&
- memcmp(key, pag + ino[i], siz) == 0)
+ memEQ(key, pag + ino[i], siz))
return i;
off = ino[i + 1];
}
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h
index bd66d02fd24..8a675b90659 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/pair.h
@@ -1,3 +1,13 @@
+/* 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));
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ps b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ps
deleted file mode 100644
index da17e614383..00000000000
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/readme.ps
+++ /dev/null
@@ -1,2225 +0,0 @@
-%!PS-Adobe-1.0
-%%Creator: yetti:oz (Ozan Yigit)
-%%Title: stdin (ditroff)
-%%CreationDate: Thu Dec 13 15:56:08 1990
-%%EndComments
-% lib/psdit.pro -- prolog for psdit (ditroff) files
-% Copyright (c) 1984, 1985 Adobe Systems Incorporated. All Rights Reserved.
-% last edit: shore Sat Nov 23 20:28:03 1985
-% RCSID: $Header: /home/cvs/src/gnu/usr.bin/perl/ext/SDBM_File/sdbm/Attic/readme.ps,v 1.1.1.1 1996/08/19 10:12:13 downsj Exp $
-
-/$DITroff 140 dict def $DITroff begin
-/fontnum 1 def /fontsize 10 def /fontheight 10 def /fontslant 0 def
-/xi {0 72 11 mul translate 72 resolution div dup neg scale 0 0 moveto
- /fontnum 1 def /fontsize 10 def /fontheight 10 def /fontslant 0 def F
- /pagesave save def}def
-/PB{save /psv exch def currentpoint translate
- resolution 72 div dup neg scale 0 0 moveto}def
-/PE{psv restore}def
-/arctoobig 90 def /arctoosmall .05 def
-/m1 matrix def /m2 matrix def /m3 matrix def /oldmat matrix def
-/tan{dup sin exch cos div}def
-/point{resolution 72 div mul}def
-/dround {transform round exch round exch itransform}def
-/xT{/devname exch def}def
-/xr{/mh exch def /my exch def /resolution exch def}def
-/xp{}def
-/xs{docsave restore end}def
-/xt{}def
-/xf{/fontname exch def /slotno exch def fontnames slotno get fontname eq not
- {fonts slotno fontname findfont put fontnames slotno fontname put}if}def
-/xH{/fontheight exch def F}def
-/xS{/fontslant exch def F}def
-/s{/fontsize exch def /fontheight fontsize def F}def
-/f{/fontnum exch def F}def
-/F{fontheight 0 le {/fontheight fontsize def}if
- fonts fontnum get fontsize point 0 0 fontheight point neg 0 0 m1 astore
- fontslant 0 ne{1 0 fontslant tan 1 0 0 m2 astore m3 concatmatrix}if
- makefont setfont .04 fontsize point mul 0 dround pop setlinewidth}def
-/X{exch currentpoint exch pop moveto show}def
-/N{3 1 roll moveto show}def
-/Y{exch currentpoint pop exch moveto show}def
-/S{show}def
-/ditpush{}def/ditpop{}def
-/AX{3 -1 roll currentpoint exch pop moveto 0 exch ashow}def
-/AN{4 2 roll moveto 0 exch ashow}def
-/AY{3 -1 roll currentpoint pop exch moveto 0 exch ashow}def
-/AS{0 exch ashow}def
-/MX{currentpoint exch pop moveto}def
-/MY{currentpoint pop exch moveto}def
-/MXY{moveto}def
-/cb{pop}def % action on unknown char -- nothing for now
-/n{}def/w{}def
-/p{pop showpage pagesave restore /pagesave save def}def
-/abspoint{currentpoint exch pop add exch currentpoint pop add exch}def
-/distance{dup mul exch dup mul add sqrt}def
-/dstroke{currentpoint stroke moveto}def
-/Dl{2 copy gsave rlineto stroke grestore rmoveto}def
-/arcellipse{/diamv exch def /diamh exch def oldmat currentmatrix pop
- currentpoint translate 1 diamv diamh div scale /rad diamh 2 div def
- currentpoint exch rad add exch rad -180 180 arc oldmat setmatrix}def
-/Dc{dup arcellipse dstroke}def
-/De{arcellipse dstroke}def
-/Da{/endv exch def /endh exch def /centerv exch def /centerh exch def
- /cradius centerv centerv mul centerh centerh mul add sqrt def
- /eradius endv endv mul endh endh mul add sqrt def
- /endang endv endh atan def
- /startang centerv neg centerh neg atan def
- /sweep startang endang sub dup 0 lt{360 add}if def
- sweep arctoobig gt
- {/midang startang sweep 2 div sub def /midrad cradius eradius add 2 div def
- /midh midang cos midrad mul def /midv midang sin midrad mul def
- midh neg midv neg endh endv centerh centerv midh midv Da
- currentpoint moveto Da}
- {sweep arctoosmall ge
- {/controldelt 1 sweep 2 div cos sub 3 sweep 2 div sin mul div 4 mul def
- centerv neg controldelt mul centerh controldelt mul
- endv neg controldelt mul centerh add endh add
- endh controldelt mul centerv add endv add
- centerh endh add centerv endv add rcurveto dstroke}
- {centerh endh add centerv endv add rlineto dstroke}ifelse}ifelse}def
-
-/Barray 200 array def % 200 values in a wiggle
-/D~{mark}def
-/D~~{counttomark Barray exch 0 exch getinterval astore /Bcontrol exch def pop
- /Blen Bcontrol length def Blen 4 ge Blen 2 mod 0 eq and
- {Bcontrol 0 get Bcontrol 1 get abspoint /Ycont exch def /Xcont exch def
- Bcontrol 0 2 copy get 2 mul put Bcontrol 1 2 copy get 2 mul put
- Bcontrol Blen 2 sub 2 copy get 2 mul put
- Bcontrol Blen 1 sub 2 copy get 2 mul put
- /Ybi /Xbi currentpoint 3 1 roll def def 0 2 Blen 4 sub
- {/i exch def
- Bcontrol i get 3 div Bcontrol i 1 add get 3 div
- Bcontrol i get 3 mul Bcontrol i 2 add get add 6 div
- Bcontrol i 1 add get 3 mul Bcontrol i 3 add get add 6 div
- /Xbi Xcont Bcontrol i 2 add get 2 div add def
- /Ybi Ycont Bcontrol i 3 add get 2 div add def
- /Xcont Xcont Bcontrol i 2 add get add def
- /Ycont Ycont Bcontrol i 3 add get add def
- Xbi currentpoint pop sub Ybi currentpoint exch pop sub rcurveto
- }for dstroke}if}def
-end
-/ditstart{$DITroff begin
- /nfonts 60 def % NFONTS makedev/ditroff dependent!
- /fonts[nfonts{0}repeat]def
- /fontnames[nfonts{()}repeat]def
-/docsave save def
-}def
-
-% character outcalls
-/oc {/pswid exch def /cc exch def /name exch def
- /ditwid pswid fontsize mul resolution mul 72000 div def
- /ditsiz fontsize resolution mul 72 div def
- ocprocs name known{ocprocs name get exec}{name cb}
- ifelse}def
-/fractm [.65 0 0 .6 0 0] def
-/fraction
- {/fden exch def /fnum exch def gsave /cf currentfont def
- cf fractm makefont setfont 0 .3 dm 2 copy neg rmoveto
- fnum show rmoveto currentfont cf setfont(\244)show setfont fden show
- grestore ditwid 0 rmoveto} def
-/oce {grestore ditwid 0 rmoveto}def
-/dm {ditsiz mul}def
-/ocprocs 50 dict def ocprocs begin
-(14){(1)(4)fraction}def
-(12){(1)(2)fraction}def
-(34){(3)(4)fraction}def
-(13){(1)(3)fraction}def
-(23){(2)(3)fraction}def
-(18){(1)(8)fraction}def
-(38){(3)(8)fraction}def
-(58){(5)(8)fraction}def
-(78){(7)(8)fraction}def
-(sr){gsave 0 .06 dm rmoveto(\326)show oce}def
-(is){gsave 0 .15 dm rmoveto(\362)show oce}def
-(->){gsave 0 .02 dm rmoveto(\256)show oce}def
-(<-){gsave 0 .02 dm rmoveto(\254)show oce}def
-(==){gsave 0 .05 dm rmoveto(\272)show oce}def
-end
-
-% an attempt at a PostScript FONT to implement ditroff special chars
-% this will enable us to
-% cache the little buggers
-% generate faster, more compact PS out of psdit
-% confuse everyone (including myself)!
-50 dict dup begin
-/FontType 3 def
-/FontName /DIThacks def
-/FontMatrix [.001 0 0 .001 0 0] def
-/FontBBox [-260 -260 900 900] def% a lie but ...
-/Encoding 256 array def
-0 1 255{Encoding exch /.notdef put}for
-Encoding
- dup 8#040/space put %space
- dup 8#110/rc put %right ceil
- dup 8#111/lt put %left top curl
- dup 8#112/bv put %bold vert
- dup 8#113/lk put %left mid curl
- dup 8#114/lb put %left bot curl
- dup 8#115/rt put %right top curl
- dup 8#116/rk put %right mid curl
- dup 8#117/rb put %right bot curl
- dup 8#120/rf put %right floor
- dup 8#121/lf put %left floor
- dup 8#122/lc put %left ceil
- dup 8#140/sq put %square
- dup 8#141/bx put %box
- dup 8#142/ci put %circle
- dup 8#143/br put %box rule
- dup 8#144/rn put %root extender
- dup 8#145/vr put %vertical rule
- dup 8#146/ob put %outline bullet
- dup 8#147/bu put %bullet
- dup 8#150/ru put %rule
- dup 8#151/ul put %underline
- pop
-/DITfd 100 dict def
-/BuildChar{0 begin
- /cc exch def /fd exch def
- /charname fd /Encoding get cc get def
- /charwid fd /Metrics get charname get def
- /charproc fd /CharProcs get charname get def
- charwid 0 fd /FontBBox get aload pop setcachedevice
- 2 setlinejoin 40 setlinewidth
- newpath 0 0 moveto gsave charproc grestore
- end}def
-/BuildChar load 0 DITfd put
-%/UniqueID 5 def
-/CharProcs 50 dict def
-CharProcs begin
-/space{}def
-/.notdef{}def
-/ru{500 0 rls}def
-/rn{0 840 moveto 500 0 rls}def
-/vr{0 800 moveto 0 -770 rls}def
-/bv{0 800 moveto 0 -1000 rls}def
-/br{0 750 moveto 0 -1000 rls}def
-/ul{0 -140 moveto 500 0 rls}def
-/ob{200 250 rmoveto currentpoint newpath 200 0 360 arc closepath stroke}def
-/bu{200 250 rmoveto currentpoint newpath 200 0 360 arc closepath fill}def
-/sq{80 0 rmoveto currentpoint dround newpath moveto
- 640 0 rlineto 0 640 rlineto -640 0 rlineto closepath stroke}def
-/bx{80 0 rmoveto currentpoint dround newpath moveto
- 640 0 rlineto 0 640 rlineto -640 0 rlineto closepath fill}def
-/ci{500 360 rmoveto currentpoint newpath 333 0 360 arc
- 50 setlinewidth stroke}def
-
-/lt{0 -200 moveto 0 550 rlineto currx 800 2cx s4 add exch s4 a4p stroke}def
-/lb{0 800 moveto 0 -550 rlineto currx -200 2cx s4 add exch s4 a4p stroke}def
-/rt{0 -200 moveto 0 550 rlineto currx 800 2cx s4 sub exch s4 a4p stroke}def
-/rb{0 800 moveto 0 -500 rlineto currx -200 2cx s4 sub exch s4 a4p stroke}def
-/lk{0 800 moveto 0 300 -300 300 s4 arcto pop pop 1000 sub
- 0 300 4 2 roll s4 a4p 0 -200 lineto stroke}def
-/rk{0 800 moveto 0 300 s2 300 s4 arcto pop pop 1000 sub
- 0 300 4 2 roll s4 a4p 0 -200 lineto stroke}def
-/lf{0 800 moveto 0 -1000 rlineto s4 0 rls}def
-/rf{0 800 moveto 0 -1000 rlineto s4 neg 0 rls}def
-/lc{0 -200 moveto 0 1000 rlineto s4 0 rls}def
-/rc{0 -200 moveto 0 1000 rlineto s4 neg 0 rls}def
-end
-
-/Metrics 50 dict def Metrics begin
-/.notdef 0 def
-/space 500 def
-/ru 500 def
-/br 0 def
-/lt 416 def
-/lb 416 def
-/rt 416 def
-/rb 416 def
-/lk 416 def
-/rk 416 def
-/rc 416 def
-/lc 416 def
-/rf 416 def
-/lf 416 def
-/bv 416 def
-/ob 350 def
-/bu 350 def
-/ci 750 def
-/bx 750 def
-/sq 750 def
-/rn 500 def
-/ul 500 def
-/vr 0 def
-end
-
-DITfd begin
-/s2 500 def /s4 250 def /s3 333 def
-/a4p{arcto pop pop pop pop}def
-/2cx{2 copy exch}def
-/rls{rlineto stroke}def
-/currx{currentpoint pop}def
-/dround{transform round exch round exch itransform} def
-end
-end
-/DIThacks exch definefont pop
-ditstart
-(psc)xT
-576 1 1 xr
-1(Times-Roman)xf 1 f
-2(Times-Italic)xf 2 f
-3(Times-Bold)xf 3 f
-4(Times-BoldItalic)xf 4 f
-5(Helvetica)xf 5 f
-6(Helvetica-Bold)xf 6 f
-7(Courier)xf 7 f
-8(Courier-Bold)xf 8 f
-9(Symbol)xf 9 f
-10(DIThacks)xf 10 f
-10 s
-1 f
-xi
-%%EndProlog
-
-%%Page: 1 1
-10 s 0 xH 0 xS 1 f
-8 s
-2 f
-12 s
-1778 672(sdbm)N
-3 f
-2004(\320)X
-2124(Substitute)X
-2563(DBM)X
-2237 768(or)N
-1331 864(Berkeley)N
-2 f
-1719(ndbm)X
-3 f
-1956(for)X
-2103(Every)X
-2373(UN*X)X
-1 f
-10 s
-2628 832(1)N
-3 f
-12 s
-2692 864(Made)N
-2951(Simple)X
-2 f
-10 s
-2041 1056(Ozan)N
-2230(\(oz\))X
-2375(Yigit)X
-1 f
-1658 1200(The)N
-1803(Guild)X
-2005(of)X
-2092(PD)X
-2214(Software)X
-2524(Toolmakers)X
-2000 1296(Toronto)N
-2278(-)X
-2325(Canada)X
-1965 1488(oz@nexus.yorku.ca)N
-2 f
-555 1804(Implementation)N
-1078(is)X
-1151(the)X
-1269(sincerest)X
-1574(form)X
-1745(of)X
-1827(\257attery.)X
-2094(\320)X
-2185(L.)X
-2269(Peter)X
-2463(Deutsch)X
-3 f
-555 1996(A)N
-633(The)X
-786(Clone)X
-1006(of)X
-1093(the)X
-2 f
-1220(ndbm)X
-3 f
-1418(library)X
-1 f
-755 2120(The)N
-903(sources)X
-1167(accompanying)X
-1658(this)X
-1796(notice)X
-2015(\320)X
-2 f
-2118(sdbm)X
-1 f
-2309(\320)X
-2411(constitute)X
-2744(the)X
-2864(\256rst)X
-3010(public)X
-3232(release)X
-3478(\(Dec.)X
-3677(1990\))X
-3886(of)X
-3975(a)X
-555 2216(complete)N
-874(clone)X
-1073(of)X
-1165(the)X
-1288(Berkeley)X
-1603(UN*X)X
-2 f
-1842(ndbm)X
-1 f
-2045(library.)X
-2304(The)X
-2 f
-2454(sdbm)X
-1 f
-2648(library)X
-2887(is)X
-2965(meant)X
-3186(to)X
-3273(clone)X
-3472(the)X
-3594(proven)X
-3841(func-)X
-555 2312(tionality)N
-846(of)X
-2 f
-938(ndbm)X
-1 f
-1141(as)X
-1233(closely)X
-1485(as)X
-1576(possible,)X
-1882(including)X
-2208(a)X
-2268(few)X
-2413(improvements.)X
-2915(It)X
-2988(is)X
-3065(practical,)X
-3386(easy)X
-3553(to)X
-3639(understand,)X
-555 2408(and)N
-691(compatible.)X
-1107(The)X
-2 f
-1252(sdbm)X
-1 f
-1441(library)X
-1675(is)X
-1748(not)X
-1870(derived)X
-2131(from)X
-2307(any)X
-2443(licensed,)X
-2746(proprietary)X
-3123(or)X
-3210(copyrighted)X
-3613(software.)X
-755 2532(The)N
-2 f
-910(sdbm)X
-1 f
-1109(implementation)X
-1641(is)X
-1723(based)X
-1935(on)X
-2044(a)X
-2109(1978)X
-2298(algorithm)X
-2638([Lar78])X
-2913(by)X
-3022(P.-A.)X
-3220(\(Paul\))X
-3445(Larson)X
-3697(known)X
-3944(as)X
-555 2628(``Dynamic)N
-934(Hashing''.)X
-1326(In)X
-1424(the)X
-1553(course)X
-1794(of)X
-1892(searching)X
-2231(for)X
-2355(a)X
-2421(substitute)X
-2757(for)X
-2 f
-2881(ndbm)X
-1 f
-3059(,)X
-3109(I)X
-3166(prototyped)X
-3543(three)X
-3734(different)X
-555 2724(external-hashing)N
-1119(algorithms)X
-1490([Lar78,)X
-1758(Fag79,)X
-2007(Lit80])X
-2236(and)X
-2381(ultimately)X
-2734(chose)X
-2946(Larson's)X
-3256(algorithm)X
-3596(as)X
-3692(a)X
-3756(basis)X
-3944(of)X
-555 2820(the)N
-2 f
-680(sdbm)X
-1 f
-875(implementation.)X
-1423(The)X
-1574(Bell)X
-1733(Labs)X
-2 f
-1915(dbm)X
-1 f
-2079(\(and)X
-2248(therefore)X
-2 f
-2565(ndbm)X
-1 f
-2743(\))X
-2796(is)X
-2875(based)X
-3084(on)X
-3190(an)X
-3292(algorithm)X
-3629(invented)X
-3931(by)X
-555 2916(Ken)N
-709(Thompson,)X
-1091([Tho90,)X
-1367(Tor87])X
-1610(and)X
-1746(predates)X
-2034(Larson's)X
-2335(work.)X
-755 3040(The)N
-2 f
-903(sdbm)X
-1 f
-1095(programming)X
-1553(interface)X
-1857(is)X
-1932(totally)X
-2158(compatible)X
-2536(with)X
-2 f
-2700(ndbm)X
-1 f
-2900(and)X
-3038(includes)X
-3327(a)X
-3385(slight)X
-3584(improvement)X
-555 3136(in)N
-641(database)X
-942(initialization.)X
-1410(It)X
-1483(is)X
-1560(also)X
-1713(expected)X
-2023(to)X
-2109(be)X
-2208(binary-compatible)X
-2819(under)X
-3025(most)X
-3203(UN*X)X
-3440(versions)X
-3730(that)X
-3873(sup-)X
-555 3232(port)N
-704(the)X
-2 f
-822(ndbm)X
-1 f
-1020(library.)X
-755 3356(The)N
-2 f
-909(sdbm)X
-1 f
-1107(implementation)X
-1638(shares)X
-1868(the)X
-1995(shortcomings)X
-2455(of)X
-2551(the)X
-2 f
-2678(ndbm)X
-1 f
-2885(library,)X
-3148(as)X
-3244(a)X
-3309(side)X
-3467(effect)X
-3680(of)X
-3775(various)X
-555 3452(simpli\256cations)N
-1046(to)X
-1129(the)X
-1248(original)X
-1518(Larson)X
-1762(algorithm.)X
-2114(It)X
-2183(does)X
-2350(produce)X
-2 f
-2629(holes)X
-1 f
-2818(in)X
-2900(the)X
-3018(page)X
-3190(\256le)X
-3312(as)X
-3399(it)X
-3463(writes)X
-3679(pages)X
-3882(past)X
-555 3548(the)N
-680(end)X
-823(of)X
-917(\256le.)X
-1066(\(Larson's)X
-1400(paper)X
-1605(include)X
-1867(a)X
-1929(clever)X
-2152(solution)X
-2435(to)X
-2523(this)X
-2664(problem)X
-2957(that)X
-3103(is)X
-3182(a)X
-3244(result)X
-3448(of)X
-3541(using)X
-3740(the)X
-3864(hash)X
-555 3644(value)N
-758(directly)X
-1032(as)X
-1128(a)X
-1193(block)X
-1400(address.\))X
-1717(On)X
-1844(the)X
-1971(other)X
-2165(hand,)X
-2370(extensive)X
-2702(tests)X
-2873(seem)X
-3067(to)X
-3158(indicate)X
-3441(that)X
-2 f
-3590(sdbm)X
-1 f
-3787(creates)X
-555 3740(fewer)N
-762(holes)X
-954(in)X
-1039(general,)X
-1318(and)X
-1456(the)X
-1576(resulting)X
-1878(page\256les)X
-2185(are)X
-2306(smaller.)X
-2584(The)X
-2 f
-2731(sdbm)X
-1 f
-2922(implementation)X
-3446(is)X
-3521(also)X
-3672(faster)X
-3873(than)X
-2 f
-555 3836(ndbm)N
-1 f
-757(in)X
-843(database)X
-1144(creation.)X
-1467(Unlike)X
-1709(the)X
-2 f
-1831(ndbm)X
-1 f
-2009(,)X
-2053(the)X
-2 f
-2175(sdbm)X
-7 f
-2396(store)X
-1 f
-2660(operation)X
-2987(will)X
-3134(not)X
-3259(``wander)X
-3573(away'')X
-3820(trying)X
-555 3932(to)N
-642(split)X
-804(its)X
-904(data)X
-1063(pages)X
-1271(to)X
-1358(insert)X
-1561(a)X
-1622(datum)X
-1847(that)X
-2 f
-1992(cannot)X
-1 f
-2235(\(due)X
-2403(to)X
-2490(elaborate)X
-2810(worst-case)X
-3179(situations\))X
-3537(be)X
-3637(inserted.)X
-3935(\(It)X
-555 4028(will)N
-699(fail)X
-826(after)X
-994(a)X
-1050(pre-de\256ned)X
-1436(number)X
-1701(of)X
-1788(attempts.\))X
-3 f
-555 4220(Important)N
-931(Compatibility)X
-1426(Warning)X
-1 f
-755 4344(The)N
-2 f
-904(sdbm)X
-1 f
-1097(and)X
-2 f
-1237(ndbm)X
-1 f
-1439(libraries)X
-2 f
-1726(cannot)X
-1 f
-1968(share)X
-2162(databases:)X
-2515(one)X
-2654(cannot)X
-2891(read)X
-3053(the)X
-3174(\(dir/pag\))X
-3478(database)X
-3778(created)X
-555 4440(by)N
-657(the)X
-777(other.)X
-984(This)X
-1148(is)X
-1222(due)X
-1359(to)X
-1442(the)X
-1561(differences)X
-1940(between)X
-2229(the)X
-2 f
-2348(ndbm)X
-1 f
-2547(and)X
-2 f
-2684(sdbm)X
-1 f
-2874(algorithms)X
-8 s
-3216 4415(2)N
-10 s
-4440(,)Y
-3289(and)X
-3426(the)X
-3545(hash)X
-3713(functions)X
-555 4536(used.)N
-769(It)X
-845(is)X
-925(easy)X
-1094(to)X
-1182(convert)X
-1449(between)X
-1743(the)X
-2 f
-1867(dbm/ndbm)X
-1 f
-2231(databases)X
-2565(and)X
-2 f
-2707(sdbm)X
-1 f
-2902(by)X
-3008(ignoring)X
-3305(the)X
-3429(index)X
-3633(completely:)X
-555 4632(see)N
-7 f
-706(dbd)X
-1 f
-(,)S
-7 f
-918(dbu)X
-1 f
-1082(etc.)X
-3 f
-555 4852(Notice)N
-794(of)X
-881(Intellectual)X
-1288(Property)X
-2 f
-555 4976(The)N
-696(entire)X
-1 f
-904(sdbm)X
-2 f
-1118(library)X
-1361(package,)X
-1670(as)X
-1762(authored)X
-2072(by)X
-2169(me,)X
-1 f
-2304(Ozan)X
-2495(S.)X
-2580(Yigit,)X
-2 f
-2785(is)X
-2858(hereby)X
-3097(placed)X
-3331(in)X
-3413(the)X
-3531(public)X
-3751(domain.)X
-1 f
-555 5072(As)N
-670(such,)X
-863(the)X
-987(author)X
-1218(is)X
-1297(not)X
-1425(responsible)X
-1816(for)X
-1936(the)X
-2060(consequences)X
-2528(of)X
-2621(use)X
-2754(of)X
-2847(this)X
-2988(software,)X
-3310(no)X
-3415(matter)X
-3645(how)X
-3808(awful,)X
-555 5168(even)N
-727(if)X
-796(they)X
-954(arise)X
-1126(from)X
-1302(defects)X
-1550(in)X
-1632(it.)X
-1716(There)X
-1924(is)X
-1997(no)X
-2097(expressed)X
-2434(or)X
-2521(implied)X
-2785(warranty)X
-3091(for)X
-3205(the)X
-2 f
-3323(sdbm)X
-1 f
-3512(library.)X
-8 s
-10 f
-555 5316(hhhhhhhhhhhhhhhhhh)N
-6 s
-1 f
-635 5391(1)N
-8 s
-691 5410(UN*X)N
-877(is)X
-936(not)X
-1034(a)X
-1078(trademark)X
-1352(of)X
-1421(any)X
-1529(\(dis\)organization.)X
-6 s
-635 5485(2)N
-8 s
-691 5504(Torek's)N
-908(discussion)X
-1194([Tor87])X
-1411(indicates)X
-1657(that)X
-2 f
-1772(dbm/ndbm)X
-1 f
-2061(implementations)X
-2506(use)X
-2609(the)X
-2705(hash)X
-2840(value)X
-2996(to)X
-3064(traverse)X
-3283(the)X
-3379(radix)X
-3528(trie)X
-3631(dif-)X
-555 5584(ferently)N
-772(than)X
-2 f
-901(sdbm)X
-1 f
-1055(and)X
-1166(as)X
-1238(a)X
-1285(result,)X
-1462(the)X
-1559(page)X
-1698(indexes)X
-1912(are)X
-2008(generated)X
-2274(in)X
-2 f
-2343(different)X
-1 f
-2579(order.)X
-2764(For)X
-2872(more)X
-3021(information,)X
-3357(send)X
-3492(e-mail)X
-3673(to)X
-555 5664(the)N
-649(author.)X
-
-2 p
-%%Page: 2 2
-8 s 0 xH 0 xS 1 f
-10 s
-2216 384(-)N
-2263(2)X
-2323(-)X
-755 672(Since)N
-971(the)X
-2 f
-1107(sdbm)X
-1 f
-1314(library)X
-1566(package)X
-1868(is)X
-1959(in)X
-2058(the)X
-2193(public)X
-2430(domain,)X
-2727(this)X
-2 f
-2879(original)X
-1 f
-3173(release)X
-3434(or)X
-3538(any)X
-3691(additional)X
-555 768(public-domain)N
-1045(releases)X
-1323(of)X
-1413(the)X
-1534(modi\256ed)X
-1841(original)X
-2112(cannot)X
-2348(possibly)X
-2636(\(by)X
-2765(de\256nition\))X
-3120(be)X
-3218(withheld)X
-3520(from)X
-3698(you.)X
-3860(Also)X
-555 864(by)N
-659(de\256nition,)X
-1009(You)X
-1170(\(singular\))X
-1505(have)X
-1680(all)X
-1783(the)X
-1904(rights)X
-2109(to)X
-2194(this)X
-2332(code)X
-2507(\(including)X
-2859(the)X
-2980(right)X
-3154(to)X
-3239(sell)X
-3373(without)X
-3640(permission,)X
-555 960(the)N
-679(right)X
-856(to)X
-944(hoard)X
-8 s
-1127 935(3)N
-10 s
-1185 960(and)N
-1327(the)X
-1451(right)X
-1628(to)X
-1716(do)X
-1821(other)X
-2011(icky)X
-2174(things)X
-2394(as)X
-2486(you)X
-2631(see)X
-2759(\256t\))X
-2877(but)X
-3004(those)X
-3198(rights)X
-3405(are)X
-3529(also)X
-3683(granted)X
-3949(to)X
-555 1056(everyone)N
-870(else.)X
-755 1180(Please)N
-997(note)X
-1172(that)X
-1329(all)X
-1446(previous)X
-1759(distributions)X
-2195(of)X
-2298(this)X
-2449(software)X
-2762(contained)X
-3110(a)X
-3182(copyright)X
-3525(\(which)X
-3784(is)X
-3873(now)X
-555 1276(dropped\))N
-868(to)X
-953(protect)X
-1199(its)X
-1297(origins)X
-1542(and)X
-1681(its)X
-1779(current)X
-2030(public)X
-2253(domain)X
-2516(status)X
-2721(against)X
-2970(any)X
-3108(possible)X
-3392(claims)X
-3623(and/or)X
-3850(chal-)X
-555 1372(lenges.)N
-3 f
-555 1564(Acknowledgments)N
-1 f
-755 1688(Many)N
-966(people)X
-1204(have)X
-1380(been)X
-1556(very)X
-1723(helpful)X
-1974(and)X
-2114(supportive.)X
-2515(A)X
-2596(partial)X
-2824(list)X
-2944(would)X
-3167(necessarily)X
-3547(include)X
-3806(Rayan)X
-555 1784(Zacherissen)N
-963(\(who)X
-1152(contributed)X
-1541(the)X
-1663(man)X
-1824(page,)X
-2019(and)X
-2158(also)X
-2310(hacked)X
-2561(a)X
-2620(MMAP)X
-2887(version)X
-3146(of)X
-2 f
-3236(sdbm)X
-1 f
-3405(\),)X
-3475(Arnold)X
-3725(Robbins,)X
-555 1880(Chris)N
-763(Lewis,)X
-1013(Bill)X
-1166(Davidsen,)X
-1523(Henry)X
-1758(Spencer,)X
-2071(Geoff)X
-2293(Collyer,)X
-2587(Rich)X
-2772(Salz)X
-2944(\(who)X
-3143(got)X
-3279(me)X
-3411(started)X
-3659(in)X
-3755(the)X
-3887(\256rst)X
-555 1976(place\),)N
-792(Johannes)X
-1106(Ruschein)X
-1424(\(who)X
-1609(did)X
-1731(the)X
-1849(minix)X
-2055(port\))X
-2231(and)X
-2367(David)X
-2583(Tilbrook.)X
-2903(I)X
-2950(thank)X
-3148(you)X
-3288(all.)X
-3 f
-555 2168(Distribution)N
-992(Manifest)X
-1315(and)X
-1463(Notes)X
-1 f
-555 2292(This)N
-717(distribution)X
-1105(of)X
-2 f
-1192(sdbm)X
-1 f
-1381(includes)X
-1668(\(at)X
-1773(least\))X
-1967(the)X
-2085(following:)X
-7 f
-747 2436(CHANGES)N
-1323(change)X
-1659(log)X
-747 2532(README)N
-1323(this)X
-1563(file.)X
-747 2628(biblio)N
-1323(a)X
-1419(small)X
-1707(bibliography)X
-2331(on)X
-2475(external)X
-2907(hashing)X
-747 2724(dba.c)N
-1323(a)X
-1419(crude)X
-1707(\(n/s\)dbm)X
-2139(page)X
-2379(file)X
-2619(analyzer)X
-747 2820(dbd.c)N
-1323(a)X
-1419(crude)X
-1707(\(n/s\)dbm)X
-2139(page)X
-2379(file)X
-2619(dumper)X
-2955(\(for)X
-3195(conversion\))X
-747 2916(dbe.1)N
-1323(man)X
-1515(page)X
-1755(for)X
-1947(dbe.c)X
-747 3012(dbe.c)N
-1323(Janick's)X
-1755(database)X
-2187(editor)X
-747 3108(dbm.c)N
-1323(a)X
-1419(dbm)X
-1611(library)X
-1995(emulation)X
-2475(wrapper)X
-2859(for)X
-3051(ndbm/sdbm)X
-747 3204(dbm.h)N
-1323(header)X
-1659(file)X
-1899(for)X
-2091(the)X
-2283(above)X
-747 3300(dbu.c)N
-1323(a)X
-1419(crude)X
-1707(db)X
-1851(management)X
-2379(utility)X
-747 3396(hash.c)N
-1323(hashing)X
-1707(function)X
-747 3492(makefile)N
-1323(guess.)X
-747 3588(pair.c)N
-1323(page-level)X
-1851(routines)X
-2283(\(posted)X
-2667(earlier\))X
-747 3684(pair.h)N
-1323(header)X
-1659(file)X
-1899(for)X
-2091(the)X
-2283(above)X
-747 3780(readme.ms)N
-1323(troff)X
-1611(source)X
-1947(for)X
-2139(the)X
-2331(README)X
-2667(file)X
-747 3876(sdbm.3)N
-1323(man)X
-1515(page)X
-747 3972(sdbm.c)N
-1323(the)X
-1515(real)X
-1755(thing)X
-747 4068(sdbm.h)N
-1323(header)X
-1659(file)X
-1899(for)X
-2091(the)X
-2283(above)X
-747 4164(tune.h)N
-1323(place)X
-1611(for)X
-1803(tuning)X
-2139(&)X
-2235(portability)X
-2811(thingies)X
-747 4260(util.c)N
-1323(miscellaneous)X
-755 4432(dbu)N
-1 f
-924(is)X
-1002(a)X
-1063(simple)X
-1301(database)X
-1603(manipulation)X
-2050(program)X
-8 s
-2322 4407(4)N
-10 s
-2379 4432(that)N
-2524(tries)X
-2687(to)X
-2774(look)X
-2941(like)X
-3086(Bell)X
-3244(Labs')X
-7 f
-3480(cbt)X
-1 f
-3649(utility.)X
-3884(It)X
-3958(is)X
-555 4528(currently)N
-867(incomplete)X
-1245(in)X
-1329(functionality.)X
-1800(I)X
-1849(use)X
-7 f
-2006(dbu)X
-1 f
-2172(to)X
-2255(test)X
-2387(out)X
-2510(the)X
-2629(routines:)X
-2930(it)X
-2995(takes)X
-3181(\(from)X
-3385(stdin\))X
-3588(tab)X
-3707(separated)X
-555 4624(key/value)N
-898(pairs)X
-1085(for)X
-1210(commands)X
-1587(like)X
-7 f
-1765(build)X
-1 f
-2035(or)X
-7 f
-2160(insert)X
-1 f
-2478(or)X
-2575(takes)X
-2770(keys)X
-2947(for)X
-3071(commands)X
-3448(like)X
-7 f
-3626(delete)X
-1 f
-3944(or)X
-7 f
-555 4720(look)N
-1 f
-(.)S
-7 f
-747 4864(dbu)N
-939(<build|creat|look|insert|cat|delete>)X
-2715(dbmfile)X
-755 5036(dba)N
-1 f
-927(is)X
-1008(a)X
-1072(crude)X
-1279(analyzer)X
-1580(of)X
-2 f
-1675(dbm/sdbm/ndbm)X
-1 f
-2232(page)X
-2412(\256les.)X
-2593(It)X
-2670(scans)X
-2872(the)X
-2998(entire)X
-3209(page)X
-3389(\256le,)X
-3538(reporting)X
-3859(page)X
-555 5132(level)N
-731(statistics,)X
-1046(and)X
-1182(totals)X
-1375(at)X
-1453(the)X
-1571(end.)X
-7 f
-755 5256(dbd)N
-1 f
-925(is)X
-1004(a)X
-1066(crude)X
-1271(dump)X
-1479(program)X
-1777(for)X
-2 f
-1897(dbm/ndbm/sdbm)X
-1 f
-2452(databases.)X
-2806(It)X
-2881(ignores)X
-3143(the)X
-3267(bitmap,)X
-3534(and)X
-3675(dumps)X
-3913(the)X
-555 5352(data)N
-717(pages)X
-928(in)X
-1018(sequence.)X
-1361(It)X
-1437(can)X
-1576(be)X
-1679(used)X
-1853(to)X
-1942(create)X
-2162(input)X
-2353(for)X
-2474(the)X
-7 f
-2627(dbu)X
-1 f
-2798(utility.)X
-3055(Note)X
-3238(that)X
-7 f
-3413(dbd)X
-1 f
-3584(will)X
-3735(skip)X
-3895(any)X
-8 s
-10 f
-555 5432(hhhhhhhhhhhhhhhhhh)N
-6 s
-1 f
-635 5507(3)N
-8 s
-691 5526(You)N
-817(cannot)X
-1003(really)X
-1164(hoard)X
-1325(something)X
-1608(that)X
-1720(is)X
-1779(available)X
-2025(to)X
-2091(the)X
-2185(public)X
-2361(at)X
-2423(large,)X
-2582(but)X
-2680(try)X
-2767(if)X
-2822(it)X
-2874(makes)X
-3053(you)X
-3165(feel)X
-3276(any)X
-3384(better.)X
-6 s
-635 5601(4)N
-8 s
-691 5620(The)N
-7 f
-829(dbd)X
-1 f
-943(,)X
-7 f
-998(dba)X
-1 f
-1112(,)X
-7 f
-1167(dbu)X
-1 f
-1298(utilities)X
-1508(are)X
-1602(quick)X
-1761(hacks)X
-1923(and)X
-2032(are)X
-2126(not)X
-2225(\256t)X
-2295(for)X
-2385(production)X
-2678(use.)X
-2795(They)X
-2942(were)X
-3081(developed)X
-3359(late)X
-3467(one)X
-3575(night,)X
-555 5700(just)N
-664(to)X
-730(test)X
-835(out)X
-2 f
-933(sdbm)X
-1 f
-1068(,)X
-1100(and)X
-1208(convert)X
-1415(some)X
-1566(databases.)X
-
-3 p
-%%Page: 3 3
-8 s 0 xH 0 xS 1 f
-10 s
-2216 384(-)N
-2263(3)X
-2323(-)X
-555 672(NULLs)N
-821(in)X
-903(the)X
-1021(key)X
-1157(and)X
-1293(data)X
-1447(\256elds,)X
-1660(thus)X
-1813(is)X
-1886(unsuitable)X
-2235(to)X
-2317(convert)X
-2578(some)X
-2767(peculiar)X
-3046(databases)X
-3374(that)X
-3514(insist)X
-3702(in)X
-3784(includ-)X
-555 768(ing)N
-677(the)X
-795(terminating)X
-1184(null.)X
-755 892(I)N
-841(have)X
-1052(also)X
-1240(included)X
-1575(a)X
-1670(copy)X
-1885(of)X
-2011(the)X
-7 f
-2195(dbe)X
-1 f
-2397(\()X
-2 f
-2424(ndbm)X
-1 f
-2660(DataBase)X
-3026(Editor\))X
-3311(by)X
-3449(Janick)X
-3712(Bergeron)X
-555 988([janick@bnr.ca])N
-1098(for)X
-1212(your)X
-1379(pleasure.)X
-1687(You)X
-1845(may)X
-2003(\256nd)X
-2147(it)X
-2211(more)X
-2396(useful)X
-2612(than)X
-2770(the)X
-2888(little)X
-7 f
-3082(dbu)X
-1 f
-3246(utility.)X
-7 f
-755 1112(dbm.[ch])N
-1 f
-1169(is)X
-1252(a)X
-2 f
-1318(dbm)X
-1 f
-1486(library)X
-1730(emulation)X
-2079(on)X
-2188(top)X
-2319(of)X
-2 f
-2415(ndbm)X
-1 f
-2622(\(and)X
-2794(hence)X
-3011(suitable)X
-3289(for)X
-2 f
-3412(sdbm)X
-1 f
-3581(\).)X
-3657(Written)X
-3931(by)X
-555 1208(Robert)N
-793(Elz.)X
-755 1332(The)N
-2 f
-901(sdbm)X
-1 f
-1090(library)X
-1324(has)X
-1451(been)X
-1623(around)X
-1866(in)X
-1948(beta)X
-2102(test)X
-2233(for)X
-2347(quite)X
-2527(a)X
-2583(long)X
-2745(time,)X
-2927(and)X
-3063(from)X
-3239(whatever)X
-3554(little)X
-3720(feedback)X
-555 1428(I)N
-609(received)X
-909(\(maybe)X
-1177(no)X
-1284(news)X
-1476(is)X
-1555(good)X
-1741(news\),)X
-1979(I)X
-2032(believe)X
-2290(it)X
-2360(has)X
-2493(been)X
-2671(functioning)X
-3066(without)X
-3336(any)X
-3478(signi\256cant)X
-3837(prob-)X
-555 1524(lems.)N
-752(I)X
-805(would,)X
-1051(of)X
-1144(course,)X
-1400(appreciate)X
-1757(all)X
-1863(\256xes)X
-2040(and/or)X
-2271(improvements.)X
-2774(Portability)X
-3136(enhancements)X
-3616(would)X
-3841(espe-)X
-555 1620(cially)N
-753(be)X
-849(useful.)X
-3 f
-555 1812(Implementation)N
-1122(Issues)X
-1 f
-755 1936(Hash)N
-944(functions:)X
-1288(The)X
-1437(algorithm)X
-1772(behind)X
-2 f
-2014(sdbm)X
-1 f
-2207(implementation)X
-2733(needs)X
-2939(a)X
-2998(good)X
-3181(bit-scrambling)X
-3671(hash)X
-3841(func-)X
-555 2032(tion)N
-702(to)X
-787(be)X
-886(effective.)X
-1211(I)X
-1261(ran)X
-1387(into)X
-1534(a)X
-1593(set)X
-1705(of)X
-1795(constants)X
-2116(for)X
-2233(a)X
-2292(simple)X
-2528(hash)X
-2698(function)X
-2988(that)X
-3130(seem)X
-3317(to)X
-3401(help)X
-2 f
-3561(sdbm)X
-1 f
-3752(perform)X
-555 2128(better)N
-758(than)X
-2 f
-916(ndbm)X
-1 f
-1114(for)X
-1228(various)X
-1484(inputs:)X
-7 f
-747 2272(/*)N
-795 2368(*)N
-891(polynomial)X
-1419(conversion)X
-1947(ignoring)X
-2379(overflows)X
-795 2464(*)N
-891(65599)X
-1179(nice.)X
-1467(65587)X
-1755(even)X
-1995(better.)X
-795 2560(*/)N
-747 2656(long)N
-747 2752(dbm_hash\(char)N
-1419(*str,)X
-1707(int)X
-1899(len\))X
-2139({)X
-939 2848(register)N
-1371(unsigned)X
-1803(long)X
-2043(n)X
-2139(=)X
-2235(0;)X
-939 3040(while)N
-1227(\(len--\))X
-1131 3136(n)N
-1227(=)X
-1323(n)X
-1419(*)X
-1515(65599)X
-1803(+)X
-1899(*str++;)X
-939 3232(return)N
-1275(n;)X
-747 3328(})N
-1 f
-755 3500(There)N
-975(may)X
-1145(be)X
-1253(better)X
-1467(hash)X
-1645(functions)X
-1974(for)X
-2099(the)X
-2228(purposes)X
-2544(of)X
-2642(dynamic)X
-2949(hashing.)X
-3269(Try)X
-3416(your)X
-3594(favorite,)X
-3895(and)X
-555 3596(check)N
-766(the)X
-887(page\256le.)X
-1184(If)X
-1261(it)X
-1328(contains)X
-1618(too)X
-1743(many)X
-1944(pages)X
-2150(with)X
-2315(too)X
-2440(many)X
-2641(holes,)X
-2853(\(in)X
-2965(relation)X
-3233(to)X
-3318(this)X
-3456(one)X
-3595(for)X
-3712(example\))X
-555 3692(or)N
-656(if)X
-2 f
-739(sdbm)X
-1 f
-942(simply)X
-1193(stops)X
-1391(working)X
-1692(\(fails)X
-1891(after)X
-7 f
-2101(SPLTMAX)X
-1 f
-2471(attempts)X
-2776(to)X
-2872(split\))X
-3070(when)X
-3278(you)X
-3432(feed)X
-3604(your)X
-3784(NEWS)X
-7 f
-555 3788(history)N
-1 f
-912(\256le)X
-1035(to)X
-1118(it,)X
-1203(you)X
-1344(probably)X
-1650(do)X
-1751(not)X
-1874(have)X
-2047(a)X
-2104(good)X
-2285(hashing)X
-2555(function.)X
-2883(If)X
-2958(you)X
-3099(do)X
-3200(better)X
-3404(\(for)X
-3545(different)X
-3842(types)X
-555 3884(of)N
-642(input\),)X
-873(I)X
-920(would)X
-1140(like)X
-1280(to)X
-1362(know)X
-1560(about)X
-1758(the)X
-1876(function)X
-2163(you)X
-2303(use.)X
-755 4008(Block)N
-967(sizes:)X
-1166(It)X
-1236(seems)X
-1453(\(from)X
-1657(various)X
-1914(tests)X
-2077(on)X
-2178(a)X
-2235(few)X
-2377(machines\))X
-2727(that)X
-2867(a)X
-2923(page)X
-3095(\256le)X
-3217(block)X
-3415(size)X
-7 f
-3588(PBLKSIZ)X
-1 f
-3944(of)X
-555 4104(1024)N
-738(is)X
-814(by)X
-917(far)X
-1030(the)X
-1150(best)X
-1301(for)X
-1417(performance,)X
-1866(but)X
-1990(this)X
-2127(also)X
-2278(happens)X
-2563(to)X
-2647(limit)X
-2819(the)X
-2939(size)X
-3086(of)X
-3175(a)X
-3233(key/value)X
-3567(pair.)X
-3734(Depend-)X
-555 4200(ing)N
-681(on)X
-785(your)X
-956(needs,)X
-1183(you)X
-1327(may)X
-1489(wish)X
-1663(to)X
-1748(increase)X
-2035(the)X
-2156(page)X
-2331(size,)X
-2499(and)X
-2638(also)X
-2790(adjust)X
-7 f
-3032(PAIRMAX)X
-1 f
-3391(\(the)X
-3539(maximum)X
-3886(size)X
-555 4296(of)N
-648(a)X
-710(key/value)X
-1048(pair)X
-1199(allowed:)X
-1501(should)X
-1740(always)X
-1989(be)X
-2090(at)X
-2173(least)X
-2345(three)X
-2531(words)X
-2752(smaller)X
-3013(than)X
-7 f
-3204(PBLKSIZ)X
-1 f
-(.\))S
-3612(accordingly.)X
-555 4392(The)N
-706(system-wide)X
-1137(version)X
-1399(of)X
-1492(the)X
-1616(library)X
-1856(should)X
-2095(probably)X
-2406(be)X
-2508(con\256gured)X
-2877(with)X
-3044(1024)X
-3229(\(distribution)X
-3649(default\),)X
-3944(as)X
-555 4488(this)N
-690(appears)X
-956(to)X
-1038(be)X
-1134(suf\256cient)X
-1452(for)X
-1566(most)X
-1741(common)X
-2041(uses)X
-2199(of)X
-2 f
-2286(sdbm)X
-1 f
-2455(.)X
-3 f
-555 4680(Portability)N
-1 f
-755 4804(This)N
-917(package)X
-1201(has)X
-1328(been)X
-1500(tested)X
-1707(in)X
-1789(many)X
-1987(different)X
-2284(UN*Xes)X
-2585(even)X
-2757(including)X
-3079(minix,)X
-3305(and)X
-3441(appears)X
-3707(to)X
-3789(be)X
-3885(rea-)X
-555 4900(sonably)N
-824(portable.)X
-1127(This)X
-1289(does)X
-1456(not)X
-1578(mean)X
-1772(it)X
-1836(will)X
-1980(port)X
-2129(easily)X
-2336(to)X
-2418(non-UN*X)X
-2799(systems.)X
-3 f
-555 5092(Notes)N
-767(and)X
-915(Miscellaneous)X
-1 f
-755 5216(The)N
-2 f
-913(sdbm)X
-1 f
-1115(is)X
-1201(not)X
-1336(a)X
-1405(very)X
-1581(complicated)X
-2006(package,)X
-2323(at)X
-2414(least)X
-2594(not)X
-2729(after)X
-2910(you)X
-3063(familiarize)X
-3444(yourself)X
-3739(with)X
-3913(the)X
-555 5312(literature)N
-879(on)X
-993(external)X
-1286(hashing.)X
-1589(There)X
-1811(are)X
-1944(other)X
-2143(interesting)X
-2514(algorithms)X
-2889(in)X
-2984(existence)X
-3316(that)X
-3469(ensure)X
-3712(\(approxi-)X
-555 5408(mately\))N
-825(single-read)X
-1207(access)X
-1438(to)X
-1525(a)X
-1586(data)X
-1745(value)X
-1944(associated)X
-2299(with)X
-2466(any)X
-2607(key.)X
-2768(These)X
-2984(are)X
-3107(directory-less)X
-3568(schemes)X
-3864(such)X
-555 5504(as)N
-2 f
-644(linear)X
-857(hashing)X
-1 f
-1132([Lit80])X
-1381(\(+)X
-1475(Larson)X
-1720(variations\),)X
-2 f
-2105(spiral)X
-2313(storage)X
-1 f
-2575([Mar79])X
-2865(or)X
-2954(directory)X
-3265(schemes)X
-3558(such)X
-3726(as)X
-2 f
-3814(exten-)X
-555 5600(sible)N
-731(hashing)X
-1 f
-1009([Fag79])X
-1288(by)X
-1393(Fagin)X
-1600(et)X
-1683(al.)X
-1786(I)X
-1838(do)X
-1943(hope)X
-2124(these)X
-2314(sources)X
-2579(provide)X
-2848(a)X
-2908(reasonable)X
-3276(playground)X
-3665(for)X
-3783(experi-)X
-555 5696(mentation)N
-907(with)X
-1081(other)X
-1277(algorithms.)X
-1690(See)X
-1837(the)X
-1966(June)X
-2144(1988)X
-2335(issue)X
-2526(of)X
-2624(ACM)X
-2837(Computing)X
-3227(Surveys)X
-3516([Enb88])X
-3810(for)X
-3935(an)X
-555 5792(excellent)N
-865(overview)X
-1184(of)X
-1271(the)X
-1389(\256eld.)X
-
-4 p
-%%Page: 4 4
-10 s 0 xH 0 xS 1 f
-2216 384(-)N
-2263(4)X
-2323(-)X
-3 f
-555 672(References)N
-1 f
-555 824([Lar78])N
-875(P.-A.)X
-1064(Larson,)X
-1327(``Dynamic)X
-1695(Hashing'',)X
-2 f
-2056(BIT)X
-1 f
-(,)S
-2216(vol.)X
-2378(18,)X
-2518(pp.)X
-2638(184-201,)X
-2945(1978.)X
-555 948([Tho90])N
-875(Ken)X
-1029(Thompson,)X
-2 f
-1411(private)X
-1658(communication)X
-1 f
-2152(,)X
-2192(Nov.)X
-2370(1990)X
-555 1072([Lit80])N
-875(W.)X
-992(Litwin,)X
-1246(``)X
-1321(Linear)X
-1552(Hashing:)X
-1862(A)X
-1941(new)X
-2096(tool)X
-2261(for)X
-2396(\256le)X
-2539(and)X
-2675(table)X
-2851(addressing'',)X
-2 f
-3288(Proceedings)X
-3709(of)X
-3791(the)X
-3909(6th)X
-875 1168(Conference)N
-1269(on)X
-1373(Very)X
-1548(Large)X
-1782(Dabatases)X
-2163(\(Montreal\))X
-1 f
-2515(,)X
-2558(pp.)X
-2701(212-223,)X
-3031(Very)X
-3215(Large)X
-3426(Database)X
-3744(Founda-)X
-875 1264(tion,)N
-1039(Saratoga,)X
-1360(Calif.,)X
-1580(1980.)X
-555 1388([Fag79])N
-875(R.)X
-969(Fagin,)X
-1192(J.)X
-1284(Nievergelt,)X
-1684(N.)X
-1803(Pippinger,)X
-2175(and)X
-2332(H.)X
-2451(R.)X
-2544(Strong,)X
-2797(``Extendible)X
-3218(Hashing)X
-3505(-)X
-3552(A)X
-3630(Fast)X
-3783(Access)X
-875 1484(Method)N
-1144(for)X
-1258(Dynamic)X
-1572(Files'',)X
-2 f
-1821(ACM)X
-2010(Trans.)X
-2236(Database)X
-2563(Syst.)X
-1 f
-2712(,)X
-2752(vol.)X
-2894(4,)X
-2994(no.3,)X
-3174(pp.)X
-3294(315-344,)X
-3601(Sept.)X
-3783(1979.)X
-555 1608([Wal84])N
-875(Rich)X
-1055(Wales,)X
-1305(``Discussion)X
-1739(of)X
-1835("dbm")X
-2072(data)X
-2235(base)X
-2406(system'',)X
-2 f
-2730(USENET)X
-3051(newsgroup)X
-3430(unix.wizards)X
-1 f
-3836(,)X
-3884(Jan.)X
-875 1704(1984.)N
-555 1828([Tor87])N
-875(Chris)X
-1068(Torek,)X
-1300(``Re:)X
-1505(dbm.a)X
-1743(and)X
-1899(ndbm.a)X
-2177(archives'',)X
-2 f
-2539(USENET)X
-2852(newsgroup)X
-3223(comp.unix)X
-1 f
-3555(,)X
-3595(1987.)X
-555 1952([Mar79])N
-875(G.)X
-974(N.)X
-1073(Martin,)X
-1332(``Spiral)X
-1598(Storage:)X
-1885(Incrementally)X
-2371(Augmentable)X
-2843(Hash)X
-3048(Addressed)X
-3427(Storage'',)X
-2 f
-3766(Techni-)X
-875 2048(cal)N
-993(Report)X
-1231(#27)X
-1 f
-(,)S
-1391(University)X
-1749(of)X
-1836(Varwick,)X
-2153(Coventry,)X
-2491(U.K.,)X
-2687(1979.)X
-555 2172([Enb88])N
-875(R.)X
-977(J.)X
-1057(Enbody)X
-1335(and)X
-1480(H.)X
-1586(C.)X
-1687(Du,)X
-1833(``Dynamic)X
-2209(Hashing)X
-2524(Schemes'',)X
-2 f
-2883(ACM)X
-3080(Computing)X
-3463(Surveys)X
-1 f
-3713(,)X
-3761(vol.)X
-3911(20,)X
-875 2268(no.)N
-995(2,)X
-1075(pp.)X
-1195(85-113,)X
-1462(June)X
-1629(1988.)X
-
-4 p
-%%Trailer
-xt
-
-xs
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3 b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3
index f0f2d07c841..7e5c1764042 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.3
@@ -1,7 +1,7 @@
.\" $Id: sdbm.3,v 1.2 90/12/13 13:00:57 oz Exp $
.TH SDBM 3 "1 March 1990"
.SH NAME
-sdbm, dbm_open, dbm_prep, dbm_close, dbm_fetch, dbm_store, dbm_delete, dbm_firstkey, dbm_nextkey, dbm_hash, dbm_rdonly, dbm_error, dbm_clearerr, dbm_dirfno, dbm_pagfno \- data base subroutines
+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
@@ -14,60 +14,60 @@ typedef struct {
.sp
datum nullitem = { NULL, 0 };
.sp
-\s-1DBM\s0 *dbm_open(char *file, int flags, int mode)
+\s-1DBM\s0 *sdbm_open(char *file, int flags, int mode)
.sp
-\s-1DBM\s0 *dbm_prep(char *dirname, char *pagname, int flags, int mode)
+\s-1DBM\s0 *sdbm_prep(char *dirname, char *pagname, int flags, int mode)
.sp
-void dbm_close(\s-1DBM\s0 *db)
+void sdbm_close(\s-1DBM\s0 *db)
.sp
-datum dbm_fetch(\s-1DBM\s0 *db, key)
+datum sdbm_fetch(\s-1DBM\s0 *db, key)
.sp
-int dbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags)
+int sdbm_store(\s-1DBM\s0 *db, datum key, datum val, int flags)
.sp
-int dbm_delete(\s-1DBM\s0 *db, datum key)
+int sdbm_delete(\s-1DBM\s0 *db, datum key)
.sp
-datum dbm_firstkey(\s-1DBM\s0 *db)
+datum sdbm_firstkey(\s-1DBM\s0 *db)
.sp
-datum dbm_nextkey(\s-1DBM\s0 *db)
+datum sdbm_nextkey(\s-1DBM\s0 *db)
.sp
-long dbm_hash(char *string, int len)
+long sdbm_hash(char *string, int len)
.sp
-int dbm_rdonly(\s-1DBM\s0 *db)
-int dbm_error(\s-1DBM\s0 *db)
-dbm_clearerr(\s-1DBM\s0 *db)
-int dbm_dirfno(\s-1DBM\s0 *db)
-int dbm_pagfno(\s-1DBM\s0 *db)
+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 dbm_open "" "\fLdbm_open\fR \(em open \fLsdbm\fR database"
-.IX dbm_prep "" "\fLdbm_prep\fR \(em prepare \fLsdbm\fR database"
-.IX dbm_close "" "\fLdbm_close\fR \(em close \fLsdbm\fR routine"
-.IX dbm_fetch "" "\fLdbm_fetch\fR \(em fetch \fLsdbm\fR database data"
-.IX dbm_store "" "\fLdbm_store\fR \(em add data to \fLsdbm\fR database"
-.IX dbm_delete "" "\fLdbm_delete\fR \(em remove data from \fLsdbm\fR database"
-.IX dbm_firstkey "" "\fLdbm_firstkey\fR \(em access \fLsdbm\fR database"
-.IX dbm_nextkey "" "\fLdbm_nextkey\fR \(em access \fLsdbm\fR database"
-.IX dbm_hash "" "\fLdbm_hash\fR \(em string hash for \fLsdbm\fR database"
-.IX dbm_rdonly "" "\fLdbm_rdonly\fR \(em return \fLsdbm\fR database read-only mode"
-.IX dbm_error "" "\fLdbm_error\fR \(em return \fLsdbm\fR database error condition"
-.IX dbm_clearerr "" "\fLdbm_clearerr\fR \(em clear \fLsdbm\fR database error condition"
-.IX dbm_dirfno "" "\fLdbm_dirfno\fR \(em return \fLsdbm\fR database bitmap file descriptor"
-.IX dbm_pagfno "" "\fLdbm_pagfno\fR \(em return \fLsdbm\fR database data file descriptor"
-.IX "database functions \(em \fLsdbm\fR" dbm_open "" \fLdbm_open\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_prep "" \fLdbm_prep\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_close "" \fLdbm_close\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_fetch "" \fLdbm_fetch\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_store "" \fLdbm_store\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_delete "" \fLdbm_delete\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_firstkey "" \fLdbm_firstkey\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_nextkey "" \fLdbm_nextkey\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_rdonly "" \fLdbm_rdonly\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_error "" \fLdbm_error\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_clearerr "" \fLdbm_clearerr\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_dirfno "" \fLdbm_dirfno\fP
-.IX "database functions \(em \fLsdbm\fR" dbm_pagfno "" \fLdbm_pagfno\fP
+.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
@@ -124,15 +124,15 @@ 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 dbm_open (\|)
+.BR sdbm_open (\|)
or
-.BR dbm_prep (\|).
+.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 dbm_open (\|)
+.BR sdbm_open (\|)
will take a base file name and call
-.BR dbm_prep (\|)
+.BR sdbm_prep (\|)
with the default extensions.
The
.I flags
@@ -142,18 +142,18 @@ parameters are the same as for
.BR open (2).
.LP
To free the resources occupied while a database handle is active, call
-.BR dbm_close (\|).
+.BR sdbm_close (\|).
.LP
Given a handle, one can retrieve data associated with a key by using the
-.BR dbm_fetch (\|)
+.BR sdbm_fetch (\|)
routine, and associate data with a key by using the
-.BR dbm_store (\|)
+.BR sdbm_store (\|)
routine.
.LP
The values of the
.I flags
parameter for
-.BR dbm_store (\|)
+.BR sdbm_store (\|)
can be either
.BR \s-1DBM_INSERT\s0 ,
which will not change an existing entry with the same key, or
@@ -162,14 +162,14 @@ 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 dbm_delete (\|)
+.BR sdbm_delete (\|)
routine.
.LP
To retrieve every key in the database, use a loop like:
.sp
.nf
.ft B
-for (key = dbm_firstkey(db); key.dptr != NULL; key = dbm_nextkey(db))
+for (key = sdbm_firstkey(db); key.dptr != NULL; key = sdbm_nextkey(db))
;
.ft R
.fi
@@ -180,27 +180,27 @@ 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 dbm_hash (\|)
+.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 dbm_rdonly (\|)
+.BR sdbm_rdonly (\|)
returns true if the database has been opened read\-only.
.IP
-.BR dbm_error (\|)
+.BR sdbm_error (\|)
returns true if an I/O error has occurred.
.IP
-.BR dbm_clearerr (\|)
+.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 dbm_dirfno (\|)
+.BR sdbm_dirfno (\|)
returns the file descriptor associated with the bitmap file.
.IP
-.BR dbm_pagfno (\|)
+.BR sdbm_pagfno (\|)
returns the file descriptor associated with the data file.
.SH SEE ALSO
.IR open (2).
@@ -220,7 +220,7 @@ will return
to indicate an error.
.LP
As a special case of
-.BR dbm_store (\|),
+.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.
@@ -281,10 +281,10 @@ header file should be installed in
The
.B nullitem
data item, and the
-.BR dbm_prep (\|),
-.BR dbm_hash (\|),
-.BR dbm_rdonly (\|),
-.BR dbm_dirfno (\|),
+.BR sdbm_prep (\|),
+.BR sdbm_hash (\|),
+.BR sdbm_rdonly (\|),
+.BR sdbm_dirfno (\|),
and
-.BR dbm_pagfno (\|)
+.BR sdbm_pagfno (\|)
functions are unique to this package.
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c
index d4836be6710..c2d9cbd47de 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.c
@@ -32,6 +32,7 @@ static char rcsid[] = "$Id: sdbm.c,v 1.16 90/12/13 13:01:31 oz Exp $";
/*
* externals
*/
+#ifndef WIN32
#ifndef sun
extern int errno;
#endif
@@ -39,6 +40,7 @@ extern int errno;
extern Malloc_t malloc proto((MEM_SIZE));
extern Free_t free proto((Malloc_t));
extern Off_t lseek();
+#endif
/*
* forward
@@ -135,7 +137,7 @@ int mode;
* open the files in sequence, and stat the dirfile.
* If we fail anywhere, undo everything, return NULL.
*/
-# ifdef OS2
+#if defined(OS2) || defined(MSDOS) || defined(WIN32)
flags |= O_BINARY;
# endif
if ((db->pagf = open(pagname, flags, mode)) > -1) {
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h
index 4d6c8448902..fdd9165145c 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h
+++ b/gnu/usr.bin/perl/ext/SDBM_File/sdbm/sdbm.h
@@ -79,15 +79,15 @@ 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;
+#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. */
@@ -108,17 +108,6 @@ extern long sdbm_hash proto((char *, int));
# endif
#endif
-#ifdef MYMALLOC
-# ifdef HIDEMYMALLOC
-# define malloc Mymalloc
-# define realloc Myremalloc
-# define free Myfree
-# endif
-# define safemalloc malloc
-# define saferealloc realloc
-# define safefree free
-#endif
-
#if defined(__STDC__) || defined(_AIX) || defined(__stdc__) || defined(__cplusplus)
# define STANDARD_C 1
#endif
@@ -131,7 +120,7 @@ extern long sdbm_hash proto((char *, int));
#include <unistd.h>
#endif
-#ifndef MSDOS
+#if !defined(MSDOS) && !defined(WIN32)
# ifdef PARAM_NEEDS_TYPES
# include <sys/types.h>
# endif
@@ -161,6 +150,31 @@ extern long sdbm_hash proto((char *, int));
#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
@@ -171,14 +185,10 @@ extern long sdbm_hash proto((char *, int));
#include <memory.h>
#endif
-#if defined(mips) && defined(ultrix) && !defined(__STDC__)
-# undef HAS_MEMCMP
-#endif
-
#ifdef HAS_MEMCPY
# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
# ifndef memcpy
- extern char * memcpy _((char*, char*, int));
+ extern char * memcpy proto((char*, char*, int));
# endif
# endif
#else
@@ -194,7 +204,7 @@ extern long sdbm_hash proto((char *, int));
#ifdef HAS_MEMSET
# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
# ifndef memset
- extern char *memset _((char*, int, int));
+ extern char *memset proto((char*, int, int));
# endif
# endif
# define memzero(d,l) memset(d,0,l)
@@ -208,24 +218,44 @@ extern long sdbm_hash proto((char *, int));
# endif
#endif /* HAS_MEMSET */
-#ifdef HAS_MEMCMP
+#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));
+ extern int memcmp proto((char*, char*, int));
# endif
# endif
+# ifdef BUGGY_MSC
+ # pragma function(memcmp)
+# endif
#else
# ifndef memcmp
-# define memcmp my_memcmp
+# /* maybe we should have included the full embedding header... */
+# ifdef NO_EMBED
+# define memcmp my_memcmp
+# else
+# define memcmp Perl_my_memcmp
+# endif
+ extern int memcmp proto((char*, char*, int));
# endif
#endif /* HAS_MEMCMP */
-/* we prefer bcmp slightly for comparisons that don't care about ordering */
#ifndef HAS_BCMP
# ifndef bcmp
# define bcmp(s1,s2,l) memcmp(s1,s2,l)
# endif
-#endif /* HAS_BCMP */
+#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
# include <netinet/in.h>
diff --git a/gnu/usr.bin/perl/ext/SDBM_File/typemap b/gnu/usr.bin/perl/ext/SDBM_File/typemap
index a6b0e5faa86..a9b73d8b811 100644
--- a/gnu/usr.bin/perl/ext/SDBM_File/typemap
+++ b/gnu/usr.bin/perl/ext/SDBM_File/typemap
@@ -23,3 +23,5 @@ 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/gnu/usr.bin/perl/ext/Safe/Makefile.PL b/gnu/usr.bin/perl/ext/Safe/Makefile.PL
deleted file mode 100644
index 108109f61d4..00000000000
--- a/gnu/usr.bin/perl/ext/Safe/Makefile.PL
+++ /dev/null
@@ -1,7 +0,0 @@
-use ExtUtils::MakeMaker;
-WriteMakefile(
- NAME => 'Safe',
- MAN3PODS => ' ', # Pods will be built by installman.
- XSPROTOARG => '-noprototypes', # XXX remove later?
- VERSION_FROM => 'Safe.pm',
-);
diff --git a/gnu/usr.bin/perl/ext/Safe/Safe.pm b/gnu/usr.bin/perl/ext/Safe/Safe.pm
deleted file mode 100644
index 0fafcbe7411..00000000000
--- a/gnu/usr.bin/perl/ext/Safe/Safe.pm
+++ /dev/null
@@ -1,670 +0,0 @@
-package Safe;
-
-use vars qw($VERSION @ISA @EXPORT_OK);
-
-require Exporter;
-require DynaLoader;
-use Carp;
-$VERSION = "1.00";
-@ISA = qw(Exporter DynaLoader);
-@EXPORT_OK = qw(op_mask ops_to_mask mask_to_ops opcode opname opdesc
- MAXO emptymask fullmask);
-
-=head1 NAME
-
-Safe - Safe extension module for Perl
-
-=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 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 much 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.
-
-By default, the operator mask for a newly created compartment masks
-out all operations which give "access to the system" in some sense.
-This includes masking off operators such as I<system>, I<open>,
-I<chown>, and I<shmget> but does not mask off operators such as
-I<print>, I<sysread> and I<E<lt>HANDLE<gt>>. Those file operators
-are allowed since for the code in the compartment to have access
-to a filehandle, the code outside the compartment must have explicitly
-placed the filehandle variable inside the compartment.
-
-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
-
-=head2 Operator masks
-
-An operator mask exists at user-level as a string of bytes of length
-MAXO, each of which is either 0x00 or 0x01. Here, MAXO is the number
-of operators in the current version of perl. The subroutine MAXO()
-(available for export by package Safe) returns the number of operators
-in the current version of perl. Note that, unlike the beta versions of
-the Safe extension, this is a reliable count of the number of
-operators in the currently running perl executable. The presence of a
-0x01 byte at offset B<n> of the string indicates that operator number
-B<n> should be masked (i.e. disallowed). The Safe extension makes
-available routines for converting from operator names to operator
-numbers (and I<vice versa>) and for converting from a list of operator
-names to the corresponding mask (and I<vice versa>).
-
-=head2 Methods in class Safe
-
-To create a new compartment, use
-
- $cpt = new Safe;
-
-Optional arguments are (NAMESPACE, MASK), where
-
-=over 8
-
-=item NAMESPACE
-
-is the root namespace to use for the compartment (defaults to
-"Safe::Root000000000", auto-incremented for each new compartment); and
-
-=item MASK
-
-is the operator mask to use (defaults to a fairly restrictive set).
-
-=back
-
-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 root (NAMESPACE)
-
-This is a get-or-set method for the compartment's namespace. With the
-NAMESPACE argument present, it sets the root namespace for the
-compartment. With no NAMESPACE argument present, it returns the
-current root namespace of the compartment.
-
-=item mask (MASK)
-
-This is a get-or-set method for the compartment's operator mask.
-With the MASK argument present, it sets the operator mask for the
-compartment. With no MASK argument present, it returns the
-current operator mask of the compartment.
-
-=item trap (OP, ...)
-
-This sets bits in the compartment's operator mask corresponding
-to each operator named in the list of arguments. Each OP can be
-either the name of an operation or its number. See opcode.h or
-opcode.pl in the main perl distribution for a canonical list of
-operator names.
-
-=item untrap (OP, ...)
-
-This resets bits in the compartment's operator mask corresponding
-to each operator named in the list of arguments. Each OP can be
-either the name of an operation or its number. See opcode.h or
-opcode.pl in the main perl distribution for a canonical list of
-operator names.
-
-=item share (VARNAME, ...)
-
-This shares the variable(s) in the argument list with the compartment.
-Each VARNAME must be the B<name> of a variable with a leading type
-identifier included. Examples of legal variable names are '$foo' for
-a scalar, '@foo' for an array, '%foo' for a hash, '&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).
-
-=item varglob (VARNAME)
-
-This returns a glob 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). Any attempt by code in STRING to use an operator which is
-in the compartment's mask 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()>. Note that 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.
-
-=item rdo (FILENAME)
-
-This evaluates the contents of file FILENAME inside the compartment.
-See above documentation on the B<reval> method for further details.
-
-=back
-
-=head2 Subroutines in package Safe
-
-The Safe package contains subroutines for manipulating operator
-names and operator masks. All are available for export by the package.
-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.
-
-=over 8
-
-=item ops_to_mask (OP, ...)
-
-This takes a list of operator names and returns an operator mask
-with precisely those operators masked.
-
-=item mask_to_ops (MASK)
-
-This takes an operator mask and returns a list of operator names
-corresponding to those operators which are masked in MASK.
-
-=item opcode (OP, ...)
-
-This takes a list of operator names and returns the corresponding
-list of opcodes (which can then be used as byte offsets into a mask).
-
-=item opname (OP, ...)
-
-This takes a list of opcodes and returns the corresponding list of
-operator names.
-
-=item fullmask
-
-This just returns a mask which has all operators masked.
-It returns the string "\1" x MAXO().
-
-=item emptymask
-
-This just returns a mask which has all operators unmasked.
-It returns the string "\0" x MAXO(). This is useful if you
-want a compartment to make use of the namespace protection
-features but do not want the default restrictive mask.
-
-=item MAXO
-
-This returns the number of operators (and hence the length of an
-operator mask). Note that, unlike the beta distributions of the
-Safe extension, this is derived from a genuine integer variable
-in the perl executable and not from a preprocessor constant.
-This means that the Safe extension is more robust in the presence
-of mismatched versions of the perl executable and the Safe extension.
-
-=item op_mask
-
-This returns the operator mask which is actually in effect at the
-time the invocation to the subroutine is compiled. In general,
-this is probably not terribly useful.
-
-=back
-
-=head2 AUTHOR
-
-Malcolm Beattie, mbeattie@sable.ox.ac.uk.
-
-=cut
-
-my $default_root = 'Root000000000';
-
-my $default_mask;
-
-sub new {
- my($class, $root, $mask) = @_;
- my $obj = {};
- bless $obj, $class;
- $obj->root(defined($root) ? $root : ("Safe::".$default_root++));
- $obj->mask(defined($mask) ? $mask : $default_mask);
- # 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->root . "::_"} = *_;
- return $obj;
-}
-
-sub DESTROY {
- my($obj) = @_;
- my $root = $obj->root();
- if ($root =~ /^Safe::(Root\d+)$/){
- $root = $1;
- delete $ {"Safe::"}{"$root\::"};
- }
-}
-
-sub root {
- my $obj = shift;
- if (@_) {
- $obj->{Root} = $_[0];
- } else {
- return $obj->{Root};
- }
-}
-
-sub mask {
- my $obj = shift;
- if (@_) {
- $obj->{Mask} = verify_mask($_[0]);
- } else {
- return $obj->{Mask};
- }
-}
-
-sub verify_mask {
- my($mask) = @_;
- if (length($mask) != MAXO() || $mask !~ /^[\0\1]+$/) {
- croak("argument is not a mask");
- }
- return $mask;
-}
-
-sub trap {
- my $obj = shift;
- $obj->setmaskel("\1", @_);
-}
-
-sub untrap {
- my $obj = shift;
- $obj->setmaskel("\0", @_);
-}
-
-sub emptymask { "\0" x MAXO() }
-sub fullmask { "\1" x MAXO() }
-
-sub setmaskel {
- my $obj = shift;
- my $val = shift;
- croak("bad value for mask element") unless $val eq "\0" || $val eq "\1";
- my $maskref = \$obj->{Mask};
- my ($op, $opcode);
- foreach $op (@_) {
- $opcode = ($op =~ /^\d/) ? $op : opcode($op);
- substr($$maskref, $opcode, 1) = $val;
- }
-}
-
-sub share {
- my $obj = shift;
- my $root = $obj->root();
- my ($arg);
- foreach $arg (@_) {
- my $var;
- ($var = $arg) =~ s/^(.)//;
- my $caller = caller;
- *{$root."::$var"} = ($1 eq '$') ? \${$caller."::$var"}
- : ($1 eq '@') ? \@{$caller."::$var"}
- : ($1 eq '%') ? \%{$caller."::$var"}
- : ($1 eq '*') ? *{$caller."::$var"}
- : ($1 eq '&') ? \&{$caller."::$var"}
- : croak(qq(No such variable type for "$1$var"));
- }
-}
-
-sub varglob {
- my ($obj, $var) = @_;
- return *{$obj->root()."::$var"};
-}
-
-sub reval {
- my ($obj, $expr) = @_;
- my $root = $obj->{Root};
- my $mask = $obj->{Mask};
- verify_mask($mask);
-
- my $evalsub = eval sprintf(<<'EOT', $root);
- package %s;
- sub {
- eval $expr;
- }
-EOT
- return safe_call_sv($root, $mask, $evalsub);
-}
-
-sub rdo {
- my ($obj, $file) = @_;
- my $root = $obj->{Root};
- my $mask = $obj->{Mask};
- verify_mask($mask);
-
- $file =~ s/"/\\"/g; # just in case the filename contains any double quotes
- my $evalsub = eval sprintf(<<'EOT', $root, $file);
- package %s;
- sub {
- do "%s";
- }
-EOT
- return safe_call_sv($root, $mask, $evalsub);
-}
-
-bootstrap Safe $VERSION;
-
-$default_mask = fullmask;
-my $name;
-while (defined ($name = <DATA>)) {
- chomp $name;
- next if $name =~ /^#/;
- my $code = opcode($name);
- substr($default_mask, $code, 1) = "\0";
-}
-
-1;
-
-__DATA__
-null
-stub
-scalar
-pushmark
-wantarray
-const
-gvsv
-gv
-gelem
-padsv
-padav
-padhv
-padany
-pushre
-rv2gv
-rv2sv
-av2arylen
-rv2cv
-anoncode
-prototype
-refgen
-srefgen
-ref
-bless
-glob
-readline
-rcatline
-regcmaybe
-regcomp
-match
-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
-split
-join
-list
-lslice
-anonlist
-anonhash
-splice
-push
-pop
-shift
-unshift
-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
-goto
-close
-fileno
-tie
-untie
-dbmopen
-dbmclose
-sselect
-select
-getc
-read
-enterwrite
-leavewrite
-prtf
-print
-sysread
-syswrite
-send
-recv
-eof
-tell
-seek
-truncate
-fcntl
-ioctl
-sockpair
-bind
-connect
-listen
-accept
-shutdown
-gsockopt
-ssockopt
-getsockname
-ftrwrite
-ftsvtx
-open_dir
-readdir
-telldir
-seekdir
-rewinddir
-kill
-getppid
-getpgrp
-setpgrp
-getpriority
-setpriority
-time
-tms
-localtime
-alarm
-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
diff --git a/gnu/usr.bin/perl/ext/Safe/Safe.xs b/gnu/usr.bin/perl/ext/Safe/Safe.xs
deleted file mode 100644
index 6b25924a334..00000000000
--- a/gnu/usr.bin/perl/ext/Safe/Safe.xs
+++ /dev/null
@@ -1,131 +0,0 @@
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.h"
-
-/* maxo should never differ from MAXO but leave some room anyway */
-#define OP_MASK_BUF_SIZE (MAXO + 100)
-
-MODULE = Safe PACKAGE = Safe
-
-void
-safe_call_sv(package, mask, codesv)
- char * package
- SV * mask
- SV * codesv
- CODE:
- int i;
- char *str;
- STRLEN len;
- char op_mask_buf[OP_MASK_BUF_SIZE];
-
- assert(maxo < OP_MASK_BUF_SIZE);
- ENTER;
- SAVETMPS;
- save_hptr(&defstash);
- save_aptr(&endav);
- SAVEPPTR(op_mask);
- op_mask = &op_mask_buf[0];
- str = SvPV(mask, len);
- if (maxo != len)
- croak("Bad mask length");
- for (i = 0; i < maxo; i++)
- op_mask[i] = str[i];
- defstash = gv_stashpv(package, TRUE);
- endav = (AV*)sv_2mortal((SV*)newAV()); /* Ignore END blocks for now */
- GvHV(gv_fetchpv("main::", TRUE, SVt_PVHV)) = defstash;
- PUSHMARK(sp);
- i = perl_call_sv(codesv, G_SCALAR|G_EVAL|G_KEEPERR);
- SPAGAIN;
- ST(0) = i ? newSVsv(POPs) : &sv_undef;
- PUTBACK;
- FREETMPS;
- LEAVE;
- sv_2mortal(ST(0));
-
-void
-op_mask()
- CODE:
- ST(0) = sv_newmortal();
- if (op_mask)
- sv_setpvn(ST(0), op_mask, maxo);
-
-void
-mask_to_ops(mask)
- SV * mask
- PPCODE:
- STRLEN len;
- char *maskstr = SvPV(mask, len);
- int i;
- if (maxo != len)
- croak("Bad mask length");
- for (i = 0; i < maxo; i++)
- if (maskstr[i])
- XPUSHs(sv_2mortal(newSVpv(op_name[i], 0)));
-
-void
-ops_to_mask(...)
- CODE:
- int i, j;
- char mask[OP_MASK_BUF_SIZE], *op;
- Zero(mask, sizeof mask, char);
- for (i = 0; i < items; i++)
- {
- op = SvPV(ST(i), na);
- for (j = 0; j < maxo && strNE(op, op_name[j]); j++) /* nothing */ ;
- if (j < maxo)
- mask[j] = 1;
- else
- {
- Safefree(mask);
- croak("bad op name \"%s\" in mask", op);
- }
- }
- ST(0) = sv_2mortal(newSVpv(mask,maxo));
-
-void
-opname(...)
- PPCODE:
- int i, myopcode;
- for (i = 0; i < items; i++)
- {
- myopcode = SvIV(ST(i));
- if (myopcode < 0 || myopcode >= maxo)
- croak("opcode out of range");
- XPUSHs(sv_2mortal(newSVpv(op_name[myopcode], 0)));
- }
-
-void
-opdesc(...)
- PPCODE:
- int i, myopcode;
- for (i = 0; i < items; i++)
- {
- myopcode = SvIV(ST(i));
- if (myopcode < 0 || myopcode >= maxo)
- croak("opcode out of range");
- XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
- }
-
-void
-opcode(...)
- PPCODE:
- int i, j;
- char *op;
- for (i = 0; i < items; i++)
- {
- op = SvPV(ST(i), na);
- for (j = 0; j < maxo; j++) {
- if (strEQ(op, op_name[j]) || strEQ(op, op_desc[j]))
- break;
- }
- if (j == maxo)
- croak("bad op name \"%s\"", op);
- XPUSHs(sv_2mortal(newSViv(j)));
- }
-
-int
-MAXO()
- CODE:
- RETVAL = maxo;
- OUTPUT:
- RETVAL
diff --git a/gnu/usr.bin/perl/ext/Socket/Socket.pm b/gnu/usr.bin/perl/ext/Socket/Socket.pm
index 43c3c404bc4..51dce5939e0 100644
--- a/gnu/usr.bin/perl/ext/Socket/Socket.pm
+++ b/gnu/usr.bin/perl/ext/Socket/Socket.pm
@@ -1,7 +1,7 @@
package Socket;
use vars qw($VERSION @ISA @EXPORT);
-$VERSION = "1.5";
+$VERSION = "1.6";
=head1 NAME
@@ -47,12 +47,15 @@ all of the commonly used pound-defines like AF_INET, SOCK_STREAM, etc.
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.
+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
@@ -72,6 +75,15 @@ 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.
@@ -83,7 +95,7 @@ to inet_aton('localhost').
Note - does not return a number.
-Returns the 4-byte invalid ip address. Normally equivalent
+Returns the 4-byte 'invalid' ip address. Normally equivalent
to inet_aton('255.255.255.255').
=item sockaddr_in PORT, ADDRESS
@@ -115,10 +127,10 @@ Will croak if the structure does not have AF_INET in the right place.
=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 PATHANE
+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 <sys/un.h>.
+These are only supported if your system has E<lt>F<sys/un.h>E<gt>.
=item pack_sockaddr_un PATH
@@ -134,19 +146,20 @@ 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;
-use AutoLoader;
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_LOOPBACK INADDR_NONE
+ INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
AF_802
AF_APPLETALK
AF_CCITT
@@ -256,14 +269,8 @@ sub AUTOLOAD {
($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 Socket macro $constname, used";
- }
+ my ($pack,$file,$line) = caller;
+ croak "Your vendor has not defined Socket macro $constname, used";
}
eval "sub $AUTOLOAD { $val }";
goto &$AUTOLOAD;
@@ -271,8 +278,4 @@ sub AUTOLOAD {
bootstrap Socket $VERSION;
-# Preloaded methods go here. Autoload methods go after __END__, and are
-# processed by the autosplit program.
-
1;
-__END__
diff --git a/gnu/usr.bin/perl/ext/Socket/Socket.xs b/gnu/usr.bin/perl/ext/Socket/Socket.xs
index 378824f42d4..e3b282b0adb 100644
--- a/gnu/usr.bin/perl/ext/Socket/Socket.xs
+++ b/gnu/usr.bin/perl/ext/Socket/Socket.xs
@@ -30,10 +30,119 @@
#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(cp, addr)
+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(hexdigit,c))) {
+ val = (val << 4) +
+ ((s - 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(s)
@@ -595,15 +704,17 @@ inet_aton(host)
{
struct in_addr ip_address;
struct hostent * phe;
+ int ok;
if (phe = gethostbyname(host)) {
Copy( phe->h_addr, &ip_address, phe->h_length, char );
+ ok = 1;
} else {
- ip_address.s_addr = inet_addr(host);
+ ok = inet_aton(host, &ip_address);
}
ST(0) = sv_newmortal();
- if(ip_address.s_addr != INADDR_NONE) {
+ if (ok) {
sv_setpvn( ST(0), (char *)&ip_address, sizeof ip_address );
}
}
@@ -649,7 +760,7 @@ pack_sockaddr_un(pathname)
void
unpack_sockaddr_un(sun_sv)
SV * sun_sv
- PPCODE:
+ CODE:
{
#ifdef I_SYS_UN
STRLEN sockaddrlen;
@@ -748,3 +859,12 @@ INADDR_NONE()
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/gnu/usr.bin/perl/ext/util/extliblist b/gnu/usr.bin/perl/ext/util/extliblist
deleted file mode 100644
index 2351ddfd0ec..00000000000
--- a/gnu/usr.bin/perl/ext/util/extliblist
+++ /dev/null
@@ -1,155 +0,0 @@
-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
-: extliblist
-:
-: Author: Andy Dougherty doughera@lafcol.lafayette.edu
-:
-: This utility was only used by the old Makefile.SH extension
-: mechanism. It is now obsolete and may be removed in a future
-: release.
-:
-: This utility takes a list of libraries in the form
-: -llib1 -llib2 -llib3
-: and prints out lines suitable for inclusion in an extension
-: Makefile.
-: Extra library paths may be included with the form -L/another/path
-: this will affect the searches for all subsequent libraries.
-:
-: It is intended to be "dotted" from within an extension Makefile.SH.
-: see ext/POSIX/Makefile.SH for an example.
-: Prior to calling this, the variable potential_libs should be set
-: to the potential list of libraries
-:
-: It sets the following
-: extralibs = full list of libraries needed for static linking.
-: Only those libraries that actually exist are included.
-: dynaloadlibs = full path names of those libraries that are needed
-: but can be linked in dynamically on this platform. On
-: SunOS, for example, this would be .so* libraries,
-: but not archive libraries.
-: Eventually, this list can be used to write a bootstrap file.
-: statloadlibs = list of those libraries which must be statically
-: linked into the shared library. On SunOS 4.1.3,
-: for example, I have only an archive version of
-: -lm, and it must be linked in statically.
-:
-: This script uses config.sh variables libs, libpth, and so. It is mostly
-: taken from the metaconfig libs.U unit.
-extralibs=''
-dynaloadlibs=''
-statloadlibs=''
-Llibpth=''
-for thislib in `echo "XXX $potential_libs " | $sed 's/ -l/ /g'` ; do
- case "$thislib" in
- XXX)
- : Handle case where potential_libs is empty.
- ;;
- -L*)
- : Handle possible linker path arguments.
- newpath=`echo $thislib | $sed 's/^-L//'`
- if $test -d $newpath; then
- Llibpth="$Llibpth $newpath"
- extralibs="$extralibs $thislib"
- statloadlibs="$statloadlibs $thislib"
- fi
- ;;
- *)
- : Handle possible library arguments.
- for thispth in $Llibpth $libpth; do
- : Loop over possible wildcards and take the last one.
- for fullname in $thispth/lib$thislib.$so.[0-9]* ; do
- :
- done
- if $test -f $fullname; then
- break
- elif fullname=$thispth/lib$thislib.$so && $test -f $fullname; then
- break
- elif fullname=$thispth/lib${thislib}_s.a && $test -f $fullname; then
- thislib=${thislib}_s
- break
- elif fullname=$thispth/lib${thislib}.a && $test -f $fullname; then
- break
- elif fullname=$thispth/Slib${thislib}.a && $test -f $fullname; then
- break
- else
- fullname=''
- fi
- done
- : Now update library lists
- case "$fullname" in
- '')
- : Skip nonexistent files
- ;;
- *)
- : Do not add it into the extralibs if it is already linked in
- : with the main perl executable.
- case " $libs " in
- *" -l$thislib "*|*" -l${thislib}_s "*) ;;
- *) extralibs="$extralibs -l$thislib" ;;
- esac
- :
- : For NeXT and DLD, put files into DYNALOADLIBS to be
- : converted into a boostrap file. For other systems,
- : we will use ld with what I have misnamed STATLOADLIBS
- : to assemble the shared object.
- case "$dlsrc" in
- dl_dld*|dl_next*)
- dynaloadlibs="$dynaloadlibs $fullname" ;;
- *)
- case "$fullname" in
- *.a)
- statloadlibs="$statloadlibs -l$thislib"
- ;;
- *)
- : For SunOS4, do not add in this shared library
- : if it is already linked in the main
- : perl executable
- case "$osname" in
- sunos)
- case " $libs " in
- *" -l$thislib "*) ;;
- *) statloadlibs="$statloadlibs -l$thislib" ;;
- esac
- ;;
- *)
- statloadlibs="$statloadlibs -l$thislib"
- ;;
- esac
- ;;
- esac
- ;;
- esac
- ;;
- esac
- ;;
- esac
-done
-
-case "$dlsrc" in
-dl_next*)
- extralibs=`echo " $extralibs "| $sed -e 's/ -lm / /'` ;;
-esac
-
-set X $extralibs
-shift
-extralibs="$*"
-
-set X $dynaloadlibs
-shift
-dynaloadlibs="$*"
-
-set X $statloadlibs
-shift
-statloadlibs="$*"
-
diff --git a/gnu/usr.bin/perl/ext/util/make_ext b/gnu/usr.bin/perl/ext/util/make_ext
index 8c1abbbc013..70a5d2eb231 100644
--- a/gnu/usr.bin/perl/ext/util/make_ext
+++ b/gnu/usr.bin/perl/ext/util/make_ext
@@ -4,16 +4,35 @@
# It primarily used by the perl Makefile:
#
# d_dummy $(dynamic_ext): miniperl preplibrary FORCE
-# ext/util/make_ext dynamic $@
+# @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=.;
@@ -34,9 +53,9 @@ if test "X$extspec" = X; then
fi
# The Perl Makefile.SH will expand all extensions to
-# lib/auto/X/X.a (or lib/auto/X/Y/Y.a is nested)
+# 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 is nested)
+# X (or X/Y or X::Y if nested)
# canonise into X/Y form (pname)
case "$extspec" in
@@ -50,7 +69,6 @@ esac
mname=`echo "$pname" | sed -e 's!/!::!g'`
depth=`echo "$pname" | sed -e 's![^/][^/]*!..!g'`
-make=${altmake-make}
makefile=Makefile
makeargs=''
makeopts=''
@@ -108,10 +126,10 @@ clean) ;;
realclean) ;;
*) # Give makefile an opportunity to rewrite itself.
# reassure users that life goes on...
- $make config $passthru || echo "$make config failed, continuing anyway..."
+ $MAKE config $passthru || echo "$MAKE config failed, continuing anyway..."
;;
esac
-$make $makeopts $target $makeargs $passthru || exit
+$MAKE $makeopts $target $makeargs $passthru || exit
exit $?
diff --git a/gnu/usr.bin/perl/form.h b/gnu/usr.bin/perl/form.h
index 531cc72294a..5e74c613fad 100644
--- a/gnu/usr.bin/perl/form.h
+++ b/gnu/usr.bin/perl/form.h
@@ -1,6 +1,6 @@
/* form.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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/gnu/usr.bin/perl/global.sym b/gnu/usr.bin/perl/global.sym
index 70d07c0034e..864be817570 100644
--- a/gnu/usr.bin/perl/global.sym
+++ b/gnu/usr.bin/perl/global.sym
@@ -3,6 +3,7 @@
# Variables
AMG_names
+Error
No
Sv
Xpv
@@ -15,19 +16,25 @@ amagic_generation
an
atan2_amg
band_amg
+block_type
bool__amg
bor_amg
-buf
bufend
bufptr
bxor_amg
check
+collation_ix
+collation_name
+collation_standard
+collxfrm_base
+collxfrm_mult
+compcv
compiling
compl_amg
-compcv
comppad
comppad_name
comppad_name_fill
+comppad_name_floor
concat_amg
concat_ass_amg
cop_seqmax
@@ -35,17 +42,17 @@ cos_amg
cryptseen
cshlen
cshname
-curcop
curinterp
curpad
dc
+debug
dec_amg
di
div_amg
div_ass_amg
+do_undump
ds
egid
-envgv
eq_amg
error_count
euid
@@ -54,10 +61,8 @@ exp_amg
expect
expectterm
fallback_amg
-filter_add
-filter_del
-filter_read
fold
+fold_locale
freq
ge_amg
gid
@@ -72,22 +77,22 @@ last_lop
last_lop_op
last_uni
le_amg
-lex_state
-lex_defer
-lex_expect
lex_brackets
-lex_formbrack
-lex_fakebrack
+lex_brackstack
lex_casemods
+lex_casestack
+lex_defer
lex_dojoin
-lex_starts
-lex_stuff
-lex_repl
-lex_op
+lex_expect
+lex_fakebrack
+lex_formbrack
lex_inpat
lex_inwhat
-lex_brackstack
-lex_casestack
+lex_op
+lex_repl
+lex_starts
+lex_state
+lex_stuff
linestr
log_amg
lshift_amg
@@ -96,8 +101,8 @@ lt_amg
markstack
markstack_max
markstack_ptr
-maxo
max_intro_pending
+maxo
min_intro_pending
mod_amg
mod_ass_amg
@@ -109,27 +114,33 @@ multi_open
multi_start
na
ncmp_amg
-nextval
-nexttype
-nexttoke
ne_amg
neg_amg
+nexttoke
nexttype
nextval
+nice_chunk
+nice_chunk_size
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
nomemok
nomethod_amg
not_amg
+numeric_local
+numeric_name
+numeric_standard
numer_amg
oldbufptr
oldoldbufptr
@@ -141,14 +152,17 @@ opargs
origalen
origenviron
osname
+pad_reset_pending
padix
+padix_floor
patleave
+pidstatus
pow_amg
pow_ass_amg
ppaddr
profiledata
-provide_ref
-qrt_amg
+psig_name
+psig_ptr
rcsid
reall_srchlen
regarglen
@@ -157,7 +171,7 @@ regcode
regdummy
regendp
regeol
-regfold
+regflags
reginput
regkind
reglastparen
@@ -184,7 +198,6 @@ rsfp
rsfp_filters
rshift_amg
rshift_ass_amg
-save_pptr
savestack
savestack_ix
savestack_max
@@ -197,16 +210,15 @@ scrgv
seq_amg
sge_amg
sgt_amg
+sh_path
sig_name
sig_num
-siggv
-sighandler
simple
sin_amg
sle_amg
slt_amg
sne_amg
-stack
+sqrt_amg
stack_base
stack_max
stack_sp
@@ -220,24 +232,29 @@ subtr_ass_amg
sv_no
sv_undef
sv_yes
-tainting
thisexpr
timesbuf
tokenbuf
uid
varies
vert
+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_nkeys
vtbl_pack
vtbl_packelem
vtbl_pos
@@ -251,6 +268,7 @@ vtbl_vec
warn_nl
warn_nosemi
warn_reserved
+warn_uninit
watchaddr
watchok
yychar
@@ -274,6 +292,10 @@ yyval
# Functions
Gv_AMupdate
+SvTRUE
+SvIV
+SvUV
+SvNV
amagic_call
append_elem
append_list
@@ -288,28 +310,33 @@ av_len
av_make
av_pop
av_push
+av_reify
av_shift
av_store
av_undef
av_unshift
bind_match
block_end
+block_gimme
block_start
-calllist
+boot_core_UNIVERSAL
+call_list
cando
cast_ulong
check_uni
checkcomma
-chsize
ck_aelem
+ck_anoncode
+ck_bitop
ck_concat
ck_delete
ck_eof
ck_eval
ck_exec
-ck_formline
+ck_exists
ck_ftst
ck_fun
+ck_fun_locale
ck_glob
ck_grep
ck_gvconst
@@ -324,6 +351,7 @@ ck_require
ck_retarget
ck_rfun
ck_rvconst
+ck_scmp
ck_select
ck_shift
ck_sort
@@ -333,9 +361,10 @@ ck_subr
ck_svconst
ck_trunc
convert
-cpytill
croak
+cv_ckproto
cv_clone
+cv_const_sv
cv_undef
cx_dump
cxinc
@@ -345,6 +374,7 @@ debop
debprofdump
debstack
debstackptrs
+delimcpy
deprecate
die
die_where
@@ -369,6 +399,7 @@ do_seek
do_semop
do_shmio
do_sprintf
+do_sysseek
do_tell
do_trans
do_vecset
@@ -400,6 +431,7 @@ force_ident
force_list
force_next
force_word
+form
free_tmps
gen_constant_list
gp_free
@@ -407,36 +439,49 @@ 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
-he_delayfree
-he_free
he_root
hoistmust
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
instr
+intro_my
intuit_more
invert
jmaybe
@@ -450,13 +495,18 @@ listkids
localize
looks_like_number
magic_clearenv
+magic_clear_all_env
magic_clearpack
+magic_clearsig
magic_existspack
+magic_freedefelem
magic_get
magic_getarylen
+magic_getdefelem
magic_getglob
magic_getpack
magic_getpos
+magic_getsig
magic_gettaint
magic_getuvar
magic_len
@@ -465,11 +515,15 @@ magic_set
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
@@ -477,9 +531,11 @@ magic_setsubstr
magic_settaint
magic_setuvar
magic_setvec
+magic_set_all_env
magic_wipepack
magicname
markstack_grow
+mem_collxfrm
mess
mg_clear
mg_copy
@@ -496,10 +552,13 @@ 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
@@ -544,6 +603,7 @@ newSVREF
newSViv
newSVnv
newSVpv
+newSVpvf
newSVrv
newSVsv
newUNOP
@@ -893,6 +953,7 @@ pp_symlink
pp_syscall
pp_sysopen
pp_sysread
+pp_sysseek
pp_system
pp_syswrite
pp_tell
@@ -934,8 +995,24 @@ regnext
regprop
repeatcpy
rninstr
+rsignal
+rsignal_save
+rsignal_state
+rsignal_restore
runops
+rxres_free
+rxres_restore
+rxres_save
+safecalloc
+safemalloc
+safefree
+saferealloc
+safexcalloc
+safexmalloc
+safexfree
+safexrealloc
same_dirent
+save_I16
save_I32
save_aptr
save_ary
@@ -945,10 +1022,12 @@ save_destructor
save_freeop
save_freepv
save_freesv
+save_gp
save_hash
save_hptr
save_int
save_item
+save_iv
save_list
save_long
save_nogv
@@ -982,12 +1061,13 @@ scope
screaminstr
setdefout
setenv_getix
+share_hek
+sharepvn
sighandler
skipspace
stack_grow
start_subparse
-sublex_done
-sublex_start
+sub_crush_depth
sv_2bool
sv_2cv
sv_2io
@@ -995,9 +1075,11 @@ sv_2iv
sv_2mortal
sv_2nv
sv_2pv
+sv_2uv
sv_add_arena
sv_backoff
sv_bless
+sv_catpvf
sv_catpv
sv_catpvn
sv_catsv
@@ -1006,7 +1088,10 @@ sv_clean_all
sv_clean_objs
sv_clear
sv_cmp
+sv_cmp_locale
+sv_collxfrm
sv_dec
+sv_derived_from
sv_dump
sv_eq
sv_free
@@ -1023,32 +1108,42 @@ sv_mortalcopy
sv_newmortal
sv_newref
sv_peek
+sv_pvn
sv_pvn_force
sv_ref
sv_reftype
sv_replace
sv_report_used
sv_reset
+sv_setpvf
sv_setiv
sv_setnv
sv_setptrobj
sv_setpv
+sv_setpviv
sv_setpvn
sv_setref_iv
sv_setref_nv
sv_setref_pv
sv_setref_pvn
sv_setsv
+sv_setuv
+sv_taint
+sv_tainted
sv_unmagic
sv_unref
+sv_untaint
sv_upgrade
sv_usepvn
+sv_vcatpvfn
+sv_vsetpvfn
taint_env
-taint_not
taint_proper
too_few_arguments
too_many_arguments
unlnk
+unshare_hek
+unsharepvn
utilize
wait4pid
warn
@@ -1060,6 +1155,7 @@ xnv_root
xpv_root
xrv_root
yyerror
+yydestruct
yylex
yyparse
yywarn
diff --git a/gnu/usr.bin/perl/gv.c b/gnu/usr.bin/perl/gv.c
index dc6d2e5a919..fff3bcfa876 100644
--- a/gnu/usr.bin/perl/gv.c
+++ b/gnu/usr.bin/perl/gv.c
@@ -1,6 +1,6 @@
/* gv.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -19,7 +19,7 @@
#include "EXTERN.h"
#include "perl.h"
-extern char rcsid[];
+EXT char rcsid[];
GV *
gv_AVadd(gv)
@@ -58,15 +58,28 @@ GV *
gv_fetchfile(name)
char *name;
{
- char tmpbuf[1200];
+ char smallbuf[256];
+ char *tmpbuf;
+ STRLEN tmplen;
GV *gv;
- sprintf(tmpbuf,"::_<%s", name);
- gv = gv_fetchpv(tmpbuf, TRUE, SVt_PVGV);
+ 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(defstash, tmpbuf, tmplen, TRUE);
+ if (!isGV(gv))
+ gv_init(gv, defstash, tmpbuf, tmplen, FALSE);
+ if (tmpbuf != smallbuf)
+ Safefree(tmpbuf);
sv_setpv(GvSV(gv), name);
- if (*name == '/' && (instr(name,"/lib/") || instr(name,".pm")))
+ if (*name == '/' && (instr(name, "/lib/") || instr(name, ".pm")))
GvMULTI_on(gv);
- if (perldb)
+ if (PERLDB_LINE)
hv_magic(GvHVn(gv_AVadd(gv)), gv, 'L');
return gv;
}
@@ -81,12 +94,11 @@ int multi;
{
register GP *gp;
- sv_upgrade(gv, SVt_PVGV);
+ sv_upgrade((SV*)gv, SVt_PVGV);
if (SvLEN(gv))
Safefree(SvPVX(gv));
- Newz(602,gp, 1, GP);
+ Newz(602, gp, 1, GP);
GvGP(gv) = gp_ref(gp);
- GvREFCNT(gv) = 1;
GvSV(gv) = NEWSV(72,0);
GvLINE(gv) = curcop->cop_line;
GvFILEGV(gv) = curcop->cop_filegv;
@@ -128,37 +140,60 @@ I32 level;
GV* topgv;
GV* gv;
GV** gvp;
- HV* lastchance;
CV* cv;
if (!stash)
return 0;
- if (level > 100)
+ if ((level > 100) || (level < -100))
croak("Recursive inheritance detected");
- gvp = (GV**)hv_fetch(stash, name, len, TRUE);
-
DEBUG_o( deb("Looking for method %s in package %s\n",name,HvNAME(stash)) );
- topgv = *gvp;
- if (SvTYPE(topgv) != SVt_PVGV)
- gv_init(topgv, stash, name, len, TRUE);
-
- if (cv=GvCV(topgv)) {
- if (GvCVGEN(topgv) >= sub_generation)
- return topgv; /* valid cached inheritance */
- if (!GvCVGEN(topgv)) { /* not an inheritance cache */
- return topgv;
- }
- else {
- /* stale cached entry, just junk it */
- GvCV(topgv) = cv = 0;
+
+ 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) >= sub_generation)
+ return topgv;
+ /* Stale cached entry: junk it */
+ SvREFCNT_dec(cv);
+ GvCV(topgv) = cv = Nullcv;
GvCVGEN(topgv) = 0;
}
}
- /* if cv is still set, we have to free it if we find something to cache */
- gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
- if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
+ gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
+ av = (gvp && (gv = *gvp) && gv != (GV*)&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*)&sv_undef && (av = GvAV(gv))) {
+ 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);
I32 items = AvFILL(av) + 1;
while (items--) {
@@ -170,30 +205,37 @@ I32 level;
SvPVX(sv), HvNAME(stash));
continue;
}
- gv = gv_fetchmeth(basestash, name, len, level + 1);
- if (gv) {
- if (cv) { /* junk old undef */
- assert(SvREFCNT(topgv) > 1);
- SvREFCNT_dec(topgv);
- SvREFCNT_dec(cv);
- }
- GvCV(topgv) = GvCV(gv); /* cache the CV */
- GvCVGEN(topgv) = sub_generation; /* valid for now */
- return gv;
- }
+ gv = gv_fetchmeth(basestash, name, len,
+ (level >= 0) ? level + 1 : level - 1);
+ if (gv)
+ goto gotcha;
}
}
- if (!level) {
- if (lastchance = gv_stashpv("UNIVERSAL", FALSE)) {
- if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) {
- if (cv) { /* junk old undef */
- assert(SvREFCNT(topgv) > 1);
- SvREFCNT_dec(topgv);
- SvREFCNT_dec(cv);
+ /* 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) = sub_generation;
}
- GvCV(topgv) = GvCV(gv); /* cache the CV */
- GvCVGEN(topgv) = sub_generation; /* valid for now */
return gv;
}
}
@@ -207,88 +249,116 @@ gv_fetchmethod(stash, name)
HV* stash;
char* name;
{
+ return gv_fetchmethod_autoload(stash, name, TRUE);
+}
+
+GV *
+gv_fetchmethod_autoload(stash, name, autoload)
+HV* stash;
+char* name;
+I32 autoload;
+{
register char *nend;
char *nsplit = 0;
GV* gv;
for (nend = name; *nend; nend++) {
- if (*nend == ':' || *nend == '\'')
+ if (*nend == '\'')
nsplit = nend;
+ else if (*nend == ':' && *(nend + 1) == ':')
+ nsplit = ++nend;
}
if (nsplit) {
- char ch;
char *origname = name;
name = nsplit + 1;
- ch = *nsplit;
if (*nsplit == ':')
--nsplit;
- *nsplit = '\0';
- if (strEQ(origname,"SUPER")) {
- /* Degenerate case ->SUPER::method should really lookup in original stash */
- SV *tmpstr = sv_2mortal(newSVpv(HvNAME(curcop->cop_stash),0));
- sv_catpvn(tmpstr, "::SUPER", 7);
- stash = gv_stashpv(SvPV(tmpstr,na),TRUE);
- *nsplit = ch;
- DEBUG_o( deb("Treating %s as %s::%s\n",origname,HvNAME(stash),name) );
- } else {
- stash = gv_stashpv(origname,TRUE);
- *nsplit = ch;
+ 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(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);
+ gv = gv_fetchmeth(stash, name, nend - name, 0);
if (!gv) {
- /* Failed obvious case - look for SUPER as last element of stash's name */
- char *packname = HvNAME(stash);
- STRLEN len = strlen(packname);
- if (len >= 7 && strEQ(packname+len-7,"::SUPER")) {
- /* Now look for @.*::SUPER::ISA */
- GV** gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
- if (!gvp || (gv = *gvp) == (GV*)&sv_undef || !GvAV(gv)) {
- /* No @ISA in package ending in ::SUPER - drop suffix
- and see if there is an @ISA there
- */
- HV *basestash;
- char ch = packname[len-7];
- AV *av;
- packname[len-7] = '\0';
- basestash = gv_stashpv(packname, TRUE);
- packname[len-7] = ch;
- gvp = (GV**)hv_fetch(basestash,"ISA",3,FALSE);
- if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
- /* Okay found @ISA after dropping the SUPER, alias it */
- SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0));
- sv_catpvn(tmpstr, "::ISA", 5);
- gv = gv_fetchpv(SvPV(tmpstr,na),TRUE,SVt_PVGV);
- if (gv) {
- GvAV(gv) = (AV*)SvREFCNT_inc(av);
- /* ... and re-try lookup */
- gv = gv_fetchmeth(stash, name, nend - name, 0);
- } else {
- croak("Cannot create %s::ISA",HvNAME(stash));
- }
- }
- }
- }
+ if (strEQ(name,"import"))
+ gv = (GV*)&sv_yes;
+ else if (autoload)
+ gv = gv_autoload4(stash, name, nend - name, TRUE);
}
-
- if (!gv) {
- CV* cv;
-
- if (strEQ(name,"import") || strEQ(name,"unimport"))
- gv = &sv_yes;
- else if (strNE(name, "AUTOLOAD")) {
- gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0);
- if (gv && (cv = GvCV(gv))) { /* One more chance... */
- SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0));
- sv_catpvn(tmpstr,"::", 2);
- sv_catpvn(tmpstr, name, nend - name);
- sv_setsv(GvSV(CvGV(cv)), tmpstr);
- if (tainting)
- sv_unmagic(GvSV(CvGV(cv)), 't');
+ 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(stash, name, len, method)
+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 (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;
}
@@ -297,15 +367,31 @@ gv_stashpv(name,create)
char *name;
I32 create;
{
- char tmpbuf[1234];
+ return gv_stashpvn(name, strlen(name), create);
+}
+
+HV*
+gv_stashpvn(name,namelen,create)
+char *name;
+U32 namelen;
+I32 create;
+{
+ char smallbuf[256];
+ char *tmpbuf;
HV *stash;
GV *tmpgv;
- /* Use strncpy to avoid bug in VMS sprintf */
- /* sprintf(tmpbuf,"%.*s::",1200,name); */
- strncpy(tmpbuf, name, 1200);
- tmpbuf[1200] = '\0'; /* just in case . . . */
- strcat(tmpbuf, "::");
- tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
+
+ 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))
@@ -321,7 +407,10 @@ gv_stashsv(sv,create)
SV *sv;
I32 create;
{
- return gv_stashpv(SvPV(sv,na), create);
+ register char *ptr;
+ STRLEN len;
+ ptr = SvPV(sv,len);
+ return gv_stashpvn(ptr, len, create);
}
@@ -337,7 +426,7 @@ I32 sv_type;
I32 len;
register char *namend;
HV *stash = 0;
- bool global = FALSE;
+ U32 add_gvflags = 0;
char *tmpbuf;
if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
@@ -349,7 +438,7 @@ I32 sv_type;
{
if (!stash)
stash = defstash;
- if (!SvREFCNT(stash)) /* symbol table under destruction */
+ if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
return Nullgv;
len = namend - name;
@@ -384,7 +473,7 @@ I32 sv_type;
namend++;
name = namend;
if (!*name)
- return gv ? gv : *hv_fetch(defstash, "main::", 6, TRUE);
+ return gv ? gv : (GV*)*hv_fetch(defstash, "main::", 6, TRUE);
}
}
len = namend - name;
@@ -395,6 +484,8 @@ I32 sv_type;
if (!stash) {
if (isIDFIRST(*name)) {
+ bool global = FALSE;
+
if (isUPPER(*name)) {
if (*name > 'I') {
if (*name == 'S' && (
@@ -419,6 +510,7 @@ I32 sv_type;
}
else if (*name == '_' && !name[1])
global = TRUE;
+
if (global)
stash = defstash;
else if ((COP*)curcop == &compiling) {
@@ -445,7 +537,7 @@ I32 sv_type;
sv_type == SVt_PVAV ? '@' :
sv_type == SVt_PVHV ? '%' : '$',
name);
- if (GvCV(*gvp))
+ if (GvCVu(*gvp))
warn("(Did you mean &%s instead?)\n", name);
stash = 0;
}
@@ -465,6 +557,10 @@ I32 sv_type;
warn("Global symbol \"%s\" requires explicit package name", name);
++error_count;
stash = curstash ? curstash : 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);
}
else
return Nullgv;
@@ -491,6 +587,7 @@ I32 sv_type;
warn("Had to create %s unexpectedly", nambeg);
gv_init(gv, stash, name, len, add & 2);
gv_init_sv(gv, sv_type);
+ GvFLAGS(gv) |= add_gvflags;
/* set up magic where warranted */
switch (*name) {
@@ -518,15 +615,15 @@ I32 sv_type;
{
char *pname;
av_push(av, newSVpv(pname = "NDBM_File",0));
- gv_stashpv(pname, TRUE);
+ gv_stashpvn(pname, 9, TRUE);
av_push(av, newSVpv(pname = "DB_File",0));
- gv_stashpv(pname, TRUE);
+ gv_stashpvn(pname, 7, TRUE);
av_push(av, newSVpv(pname = "GDBM_File",0));
- gv_stashpv(pname, TRUE);
+ gv_stashpvn(pname, 9, TRUE);
av_push(av, newSVpv(pname = "SDBM_File",0));
- gv_stashpv(pname, TRUE);
+ gv_stashpvn(pname, 9, TRUE);
av_push(av, newSVpv(pname = "ODBM_File",0));
- gv_stashpv(pname, TRUE);
+ gv_stashpvn(pname, 9, TRUE);
}
}
break;
@@ -542,11 +639,19 @@ I32 sv_type;
case 'S':
if (strEQ(name, "SIG")) {
HV *hv;
+ I32 i;
siggv = gv;
GvMULTI_on(siggv);
hv = GvHVn(siggv);
hv_magic(hv, 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,&sv_undef);
+ psig_ptr[i] = 0;
+ psig_name[i] = 0;
+ }
/* initialize signal stack */
signalstack = newAV();
AvREAL_off(signalstack);
@@ -582,6 +687,14 @@ I32 sv_type;
sv_setpv(GvSV(gv),chopset);
goto magicalize;
+ case '?':
+ if (len > 1)
+ break;
+#ifdef COMPLEX_STATUS
+ sv_upgrade(GvSV(gv), SVt_PVLV);
+#endif
+ goto magicalize;
+
case '#':
case '*':
if (dowarn && len == 1 && sv_type == SVt_PV)
@@ -589,7 +702,6 @@ I32 sv_type;
/* FALL THROUGH */
case '[':
case '!':
- case '?':
case '^':
case '~':
case '=':
@@ -628,6 +740,7 @@ I32 sv_type;
case '7':
case '8':
case '9':
+ case '\023':
ro_magicalize:
SvREADONLY_on(GvSV(gv));
magicalize:
@@ -647,10 +760,11 @@ I32 sv_type;
break;
case ']':
if (len == 1) {
- SV *sv;
- sv = GvSV(gv);
+ SV *sv = GvSV(gv);
sv_upgrade(sv, SVt_PVNV);
sv_setpv(sv, patchlevel);
+ (void)sv_2nv(sv);
+ SvREADONLY_on(sv);
}
break;
}
@@ -658,38 +772,50 @@ I32 sv_type;
}
void
-gv_fullname(sv,gv)
+gv_fullname3(sv, gv, prefix)
SV *sv;
GV *gv;
+char *prefix;
{
HV *hv = GvSTASH(gv);
-
- if (!hv)
+ if (!hv) {
+ SvOK_off(sv);
return;
- sv_setpv(sv, sv == (SV*)gv ? "*" : "");
+ }
+ sv_setpv(sv, prefix ? prefix : "");
sv_catpv(sv,HvNAME(hv));
sv_catpvn(sv,"::", 2);
sv_catpvn(sv,GvNAME(gv),GvNAMELEN(gv));
}
void
-gv_efullname(sv,gv)
+gv_efullname3(sv, gv, prefix)
SV *sv;
GV *gv;
+char *prefix;
{
- GV* egv = GvEGV(gv);
- HV *hv;
-
+ GV *egv = GvEGV(gv);
if (!egv)
egv = gv;
- hv = GvSTASH(egv);
- if (!hv)
- return;
+ gv_fullname3(sv, egv, prefix);
+}
- sv_setpv(sv, sv == (SV*)gv ? "*" : "");
- sv_catpv(sv,HvNAME(hv));
- sv_catpvn(sv,"::", 2);
- sv_catpvn(sv,GvNAME(egv),GvNAMELEN(egv));
+/* XXX compatibility with versions <= 5.003. */
+void
+gv_fullname(sv,gv)
+SV *sv;
+GV *gv;
+{
+ gv_fullname3(sv, gv, sv == (SV*)gv ? "*" : "");
+}
+
+/* XXX compatibility with versions <= 5.003. */
+void
+gv_efullname(sv,gv)
+SV *sv;
+GV *gv;
+{
+ gv_efullname3(sv, gv, sv == (SV*)gv ? "*" : "");
}
IO *
@@ -702,7 +828,9 @@ newIO()
sv_upgrade((SV *)io,SVt_PVIO);
SvREFCNT(io) = 1;
SvOBJECT_on(io);
- iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVHV);
+ 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;
}
@@ -720,15 +848,15 @@ HV* stash;
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
- for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
- if (entry->hent_key[entry->hent_klen-1] == ':' &&
- (gv = (GV*)entry->hent_val) && (hv = GvHV(gv)) && HvNAME(hv))
+ 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 != defstash)
gv_check(hv); /* nested package */
}
- else if (isALPHA(*entry->hent_key)) {
- gv = (GV*)entry->hent_val;
+ else if (isALPHA(*HeKEY(entry))) {
+ gv = (GV*)HeVAL(entry);
if (GvMULTI(gv))
continue;
curcop->cop_line = GvLINE(gv);
@@ -736,7 +864,7 @@ HV* stash;
curcop->cop_filegv = filegv;
if (filegv && GvMULTI(filegv)) /* Filename began with slash */
continue;
- warn("Identifier \"%s::%s\" used only once: possible typo",
+ warn("Name \"%s::%s\" used only once: possible typo",
HvNAME(stash), GvNAME(gv));
}
}
@@ -747,8 +875,8 @@ GV *
newGVgen(pack)
char *pack;
{
- (void)sprintf(tokenbuf,"%s::_GEN_%ld",pack,(long)gensym++);
- return gv_fetchpv(tokenbuf,TRUE, SVt_PVGV);
+ return gv_fetchpv(form("%s::_GEN_%ld", pack, (long)gensym++),
+ TRUE, SVt_PVGV);
}
/* hopefully this is only called on local symbol table entries */
@@ -758,8 +886,19 @@ gp_ref(gp)
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 */
+ sub_generation++;
+ }
+ }
return gp;
-
}
void
@@ -775,6 +914,10 @@ GV* gv;
warn("Attempt to free unreferenced glob pointers");
return;
}
+ if (gp->gp_cv) {
+ /* Deleting the name of a subroutine invalidates method cache */
+ sub_generation++;
+ }
if (--gp->gp_refcnt > 0) {
if (gp->gp_egv == gv)
gp->gp_egv = 0;
@@ -785,8 +928,7 @@ GV* gv;
SvREFCNT_dec(gp->gp_av);
SvREFCNT_dec(gp->gp_hv);
SvREFCNT_dec(gp->gp_io);
- if ((cv = gp->gp_cv) && !GvCVGEN(gv))
- SvREFCNT_dec(cv);
+ SvREFCNT_dec(gp->gp_cv);
SvREFCNT_dec(gp->gp_form);
Safefree(gp);
@@ -830,14 +972,14 @@ HV* stash;
CV* cv;
MAGIC* mg=mg_find((SV*)stash,'c');
AMT *amtp=mg ? (AMT*)mg->mg_ptr: NULL;
+ AMT amt;
- if (mg && (amtp=((AMT*)(mg->mg_ptr)))->was_ok_am == amagic_generation &&
- amtp->was_ok_sub == sub_generation)
- return HV_AMAGIC(stash)? TRUE: FALSE;
- gvp=(GV**)hv_fetch(stash,"OVERLOAD",8,FALSE);
- if (amtp && amtp->table) {
+ if (mg && amtp->was_ok_am == amagic_generation
+ && amtp->was_ok_sub == sub_generation)
+ return AMT_AMAGIC(amtp);
+ if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
int i;
- for (i=1;i<NofAMmeth*2;i++) {
+ for (i=1; i<NofAMmeth; i++) {
if (amtp->table[i]) {
SvREFCNT_dec(amtp->table[i]);
}
@@ -847,38 +989,33 @@ HV* stash;
DEBUG_o( deb("Recalcing overload magic in package %s\n",HvNAME(stash)) );
+ amt.was_ok_am = amagic_generation;
+ amt.was_ok_sub = 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*)&sv_undef && (hv = GvHV(gv)))) {
int filled=0;
int i;
char *cp;
- AMT amt;
SV* sv;
SV** svp;
-/* if (*(svp)==(SV*)amagic_generation && *(svp+1)==(SV*)sub_generation) {
- DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash))
-);
- return HV_AMAGIC(stash)? TRUE: FALSE;
- }*/
-
- amt.was_ok_am=amagic_generation;
- amt.was_ok_sub=sub_generation;
- amt.fallback=AMGfallNO;
-
/* 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 (( 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*2;i++) {
- cv=0;
-
- if ( (cp=((char**)(*AMG_names))[i]) ) {
- svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE);
- if (svp && ((sv = *svp) != (GV*)&sv_undef)) {
+ 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) != &sv_undef)) {
switch (SvTYPE(sv)) {
default:
if (!SvROK(sv)) {
@@ -893,35 +1030,92 @@ HV* stash;
/* FALL THROUGH */
case SVt_PVHV:
case SVt_PVAV:
- die("Not a subroutine reference in %%OVERLOAD");
+ croak("Not a subroutine reference in overload table");
return FALSE;
case SVt_PVCV:
- cv = (CV*)sv;
- break;
+ cv = (CV*)sv;
+ break;
case SVt_PVGV:
- if (!(cv = GvCV((GV*)sv)))
- cv = sv_2cv(sv, &stash, &gv, TRUE);
- break;
+ if (!(cv = GvCVu((GV*)sv)))
+ cv = sv_2cv(sv, &stash, &gv, TRUE);
+ break;
}
if (cv) filled=1;
else {
- die("Method for operation %s not found in package %.256s during blessing\n",
+ croak("Method for operation %s not found in package %.256s during blessing\n",
cp,HvNAME(stash));
return FALSE;
}
}
- }
- amt.table[i]=(CV*)SvREFCNT_inc(cv);
+#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), 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);
}
- sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(amt));
if (filled) {
-/* HV_badAMAGIC_off(stash);*/
- HV_AMAGIC_on(stash);
+ AMT_AMAGIC_on(&amt);
+ sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMT));
return TRUE;
}
}
-/*HV_badAMAGIC_off(stash);*/
- HV_AMAGIC_off(stash);
+ /* Here we have no table: */
+ no_table:
+ AMT_AMAGIC_off(&amt);
+ sv_magic((SV*)stash, 0, 'c', (char*)&amt, sizeof(AMTS));
return FALSE;
}
@@ -944,7 +1138,9 @@ int flags;
HV* stash;
if (!(AMGf_noleft & flags) && SvAMAGIC(left)
&& (mg = mg_find((SV*)(stash=SvSTASH(SvRV(left))),'c'))
- && (ocvp = cvp = ((oamtp=amtp=(AMT*)mg->mg_ptr)->table))
+ && (ocvp = cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
+ ? (oamtp = amtp = (AMT*)mg->mg_ptr)->table
+ : NULL))
&& ((cv = cvp[off=method+assignshift])
|| (assign && amtp->fallback > AMGfallNEVER && /* fallback to
* usual method */
@@ -977,16 +1173,20 @@ int flags;
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=SvRV(left);
- if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) { /* Just to be
- * extra
- * causious,
- * maybe in some
- * additional
- * cases sv_setsv
- * is safe too */
+ if (!SvROK(ref) && SvTYPE(ref) <= SVt_PVMG) {
+ /*
+ * Just to be extra cautious. Maybe in some
+ * additional cases sv_setsv is safe, too.
+ */
SV* newref = newSVsv(ref);
SvOBJECT_on(newref);
SvSTASH(newref) = (HV*)SvREFCNT_inc(SvSTASH(ref));
@@ -1031,7 +1231,9 @@ int flags;
if (!cv) goto not_found;
} else if (!(AMGf_noright & flags) && SvAMAGIC(right)
&& (mg = mg_find((SV*)(stash=SvSTASH(SvRV(right))),'c'))
- && (cvp = ((amtp=(AMT*)mg->mg_ptr)->table))
+ && (cvp = (AMT_AMAGIC((AMT*)mg->mg_ptr)
+ ? (amtp = (AMT*)mg->mg_ptr)->table
+ : NULL))
&& (cv = cvp[off=method])) { /* Method for right
* argument found */
lr=1;
@@ -1041,7 +1243,7 @@ int flags;
&& !(flags & AMGf_unary)) {
/* We look for substitution for
* comparison operations and
- * concatendation */
+ * concatenation */
if (method==concat_amg || method==concat_ass_amg
|| method==repeat_amg || method==repeat_ass_amg) {
return NULL; /* Delegate operation to string conversion */
@@ -1068,15 +1270,18 @@ int flags;
goto not_found;
}
} else {
- not_found: /* No method found, either report or die */
+ 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 {
- if (off==-1) off=method;
- sprintf(buf, "Operation `%s': no method found,\n\tleft argument %s%.256s,\n\tright argument %s%.256s",
- ((char**)AMG_names)[method + assignshift],
+ 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",
@@ -1084,27 +1289,30 @@ int flags;
HvNAME(SvSTASH(SvRV(left))):
"",
SvAMAGIC(right)?
- "in overloaded package ":
- "has no overloaded magic",
+ ",\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(buf) );
+ DEBUG_o( deb("%s", SvPVX(msg)) );
} else {
- die(buf);
+ croak("%_", msg);
}
return NULL;
}
}
}
if (!notfound) {
- DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
- ((char**)AMG_names)[off],
+ 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? "" :
- ((char**)AMG_names)[method+assignshift],
+ AMG_names[method+assignshift],
method+assignshift==off? "" : "')",
flags & AMGf_unary? "" :
lr==1 ? " for right argument": " for left argument",
@@ -1123,24 +1331,28 @@ int flags;
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_KNOW|OPf_STACKED;
+ myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
ENTER;
SAVESPTR(op);
op = (OP *) &myop;
+ if (PERLDB_SUB && curstash != debstash)
+ op->op_private |= OPpENTERSUB_DB;
PUTBACK;
pp_pushmark();
EXTEND(sp, notfound + 5);
PUSHs(lr>0? right: left);
PUSHs(lr>0? left: right);
- PUSHs( assign ? &sv_undef : (lr>0? &sv_yes: &sv_no));
+ PUSHs( lr > 0 ? &sv_yes : ( assign ? &sv_undef : &sv_no ));
if (notfound) {
- PUSHs( sv_2mortal(newSVpv(((char**)AMG_names)[method + assignshift],0)) );
+ PUSHs( sv_2mortal(newSVpv((char *)AMG_names[method + assignshift],0)) );
}
PUSHs((SV*)cv);
PUTBACK;
@@ -1152,11 +1364,7 @@ int flags;
res=POPs;
PUTBACK;
-
- if (notfound) {
- /* sv_2mortal(res); */
- return NULL;
- }
+ CATCH_SET(oldcatch);
if (postpr) {
int ans;
@@ -1181,12 +1389,14 @@ int flags;
ans=SvIV(res)!=0; break;
case inc_amg:
case dec_amg:
- SvSetSV(left,res); return res; break;
+ SvSetSV(left,res); return left;
+ case not_amg:
+ ans=!SvOK(res); break;
}
- return ans? &sv_yes: &sv_no;
+ return boolSV(ans);
} else if (method==copy_amg) {
if (!SvROK(res)) {
- die("Copy method did not return a reference");
+ croak("Copy method did not return a reference");
}
return SvREFCNT_inc(SvRV(res));
} else {
diff --git a/gnu/usr.bin/perl/gv.h b/gnu/usr.bin/perl/gv.h
index b823fa59474..804007519e7 100644
--- a/gnu/usr.bin/perl/gv.h
+++ b/gnu/usr.bin/perl/gv.h
@@ -1,6 +1,6 @@
/* gv.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -13,7 +13,7 @@ struct gp {
struct io * gp_io; /* filehandle value */
CV * gp_form; /* format value */
AV * gp_av; /* array value */
- HV * gp_hv; /* associative 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 */
@@ -43,6 +43,9 @@ struct gp {
#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
@@ -62,6 +65,7 @@ HV *GvHVn();
#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)
diff --git a/gnu/usr.bin/perl/handy.h b/gnu/usr.bin/perl/handy.h
index aa4107eca55..379fab8b04e 100644
--- a/gnu/usr.bin/perl/handy.h
+++ b/gnu/usr.bin/perl/handy.h
@@ -1,6 +1,6 @@
/* handy.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -20,9 +20,23 @@
#define Null(type) ((type)NULL)
#define Nullch Null(char*)
-#define Nullfp Null(FILE*)
+#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
@@ -37,6 +51,19 @@
# 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
# ifdef UTS
# define bool int
@@ -45,30 +72,69 @@
# endif
#endif
-#ifdef TRUE
-#undef TRUE
-#endif
-#ifdef FALSE
-#undef FALSE
-#endif
-#define TRUE (1)
-#define FALSE (0)
+/* 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
+
+ In the future, we may perhaps want to think about something like
+ #if INTSIZE == 4
+ typedef I32 int;
+ #else
+ # if LONGSIZE == 4
+ typedef I32 long;
+ # else
+ # if SHORTSIZE == 4
+ typedef I32 short;
+ # else
+ typedef I32 int;
+ # endif
+ # endif
+ #endif
+ For the moment, these are mentioned here so metaconfig will
+ construct Configure to figure out the various sizes.
+*/
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 BYTEORDER > 0x4321
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 Ctl(ch) (ch & 037)
+#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))
@@ -79,46 +145,97 @@ typedef unsigned short U16;
#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
-#ifdef USE_NEXT_CTYPE
-#define isALNUM(c) (NXIsAlpha((unsigned int)c) || NXIsDigit((unsigned int)c) || c == '_')
-#define isIDFIRST(c) (NXIsAlpha((unsigned int)c) || c == '_')
-#define isALPHA(c) NXIsAlpha((unsigned int)c)
-#define isSPACE(c) NXIsSpace((unsigned int)c)
-#define isDIGIT(c) NXIsDigit((unsigned int)c)
-#define isUPPER(c) NXIsUpper((unsigned int)c)
-#define isLOWER(c) NXIsLower((unsigned int)c)
-#define toUPPER(c) NXToUpper((unsigned int)c)
-#define toLOWER(c) NXToLower((unsigned int)c)
-#else /* USE_NEXT_CTYPE */
-#if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII))
-#define isALNUM(c) (isalpha((unsigned char)(c)) || isdigit((unsigned char)(c)) || c == '_')
-#define isIDFIRST(c) (isalpha((unsigned char)(c)) || (c) == '_')
-#define isALPHA(c) isalpha((unsigned char)(c))
-#define isSPACE(c) isspace((unsigned char)(c))
-#define isDIGIT(c) isdigit((unsigned char)(c))
-#define isUPPER(c) isupper((unsigned char)(c))
-#define isLOWER(c) islower((unsigned char)(c))
-#define toUPPER(c) toupper((unsigned char)(c))
-#define toLOWER(c) tolower((unsigned char)(c))
-#else
-#define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_'))
-#define isIDFIRST(c) (isascii(c) && (isalpha(c) || (c) == '_'))
-#define isALPHA(c) (isascii(c) && isalpha(c))
-#define isSPACE(c) (isascii(c) && isspace(c))
-#define isDIGIT(c) (isascii(c) && isdigit(c))
-#define isUPPER(c) (isascii(c) && isupper(c))
-#define isLOWER(c) (isascii(c) && islower(c))
-#define toUPPER(c) toupper(c)
-#define toLOWER(c) tolower(c)
-#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')
+#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))
+
+#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 */
+/* This conversion works both ways, strangely enough. */
+#define toCTRL(c) (toUPPER(c) ^ 64)
+
/* Line numbers are unsigned, 16 bits. */
typedef U16 line_t;
#ifdef lint
@@ -127,62 +244,68 @@ typedef U16 line_t;
#define NOLINE ((line_t) 65535)
#endif
+/* 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
#ifndef LEAKTEST
-#ifndef safemalloc
-char *safemalloc _((MEM_SIZE));
-char *saferealloc _((char *, MEM_SIZE));
-void safefree _((char *));
-#endif
-#ifndef MSDOS
-#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((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
-#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
-#else
-#define New(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t))))
-#define Newc(x,v,n,t,c) (v = (c*)safemalloc(((unsigned long)(n) * sizeof(t))))
-#define Newz(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))), \
- memzero((char*)(v), (n) * sizeof(t))
-#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t))))
-#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t))))
-#endif /* MSDOS */
-#define Safefree(d) safefree((char*)d)
-#define NEWSV(x,len) newSV(len)
+
+#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))
+#define NEWSV(x,len) newSV(len)
+
#else /* LEAKTEST */
-char *safexmalloc();
-char *safexrealloc();
-void safexfree();
-#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((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
-#define Renewc(v,n,t,c) (v = (c*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
-#define Safefree(d) safexfree((char*)d)
-#define NEWSV(x,len) newSV(x,len)
-#define MAXXCOUNT 1200
+
+#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 NEWSV(x,len) newSV(x,len)
+
+#define MAXXCOUNT 1400
long xcount[MAXXCOUNT];
long lastxcount[MAXXCOUNT];
+
#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))
+
+#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 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
+#define Safefree(d) (d) = (d)
+
#endif /* lint */
#ifdef USE_STRUCT_COPY
-#define StructCopy(s,d,t) *((t*)(d)) = *((t*)(s))
+#define StructCopy(s,d,t) (*((t*)(d)) = *((t*)(s)))
#else
#define StructCopy(s,d,t) Copy(s,d,1,t)
#endif
diff --git a/gnu/usr.bin/perl/hints/3b1.sh b/gnu/usr.bin/perl/hints/3b1.sh
index 2ed65c591bc..991348af3ec 100644
--- a/gnu/usr.bin/perl/hints/3b1.sh
+++ b/gnu/usr.bin/perl/hints/3b1.sh
@@ -10,6 +10,6 @@ do
rm -f $i/3b1cc
ln ../hints/3b1cc $i
done
-echo "\nIf you want to use the 3b1 shared libraries, complete this script then"
-echo "read the header in 3b1cc. [Type carriage return to continue]\c"
+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/gnu/usr.bin/perl/hints/README.hints b/gnu/usr.bin/perl/hints/README.hints
index 6c67585561b..2c27068e385 100644
--- a/gnu/usr.bin/perl/hints/README.hints
+++ b/gnu/usr.bin/perl/hints/README.hints
@@ -1,61 +1,39 @@
These files are used by Configure to set things which Configure either
-can't or doesn't guess properly. Many of these hints files are from
-perl4. They may or may not work with perl5, but they are probably a
-good starting point.
+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. I would appreciate hearing about any problems
+or suggested changes.
-The following hints files have been tested with at least some version
-of perl5 and are probably reasonably close to being correct:
+Hint file naming convention: Each hint file name should have only
+one '.'. (This is for portability to non-unix filesystems.) 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.
-aix.sh
-aux.sh
-bsdos.sh
-dec_osf.sh
-dgux.sh
-esix4.sh
-freebsd.sh
-hpux_9.sh
-irix_4.sh
-irix_5.sh
-irix_6.sh
-irix_6_2.sh
-isc.sh
-linux.sh
-machten_2.sh
-machten.sh
-ncr_tower.sh
-netbsd.sh
-next_3_2.sh
-sco_3.sh
-solaris_2.sh
-sunos_4_1.sh
-svr4.sh
-titanos.sh
-ultrix_4.sh
-unicos.sh
-utekv.sh
+For example, consider SunOS 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:
-The following hints files have not been tested with perl5:
+ sunos_4_1_3.sh
+ sunos_4_1.sh
+ sunos_4.sh
+ sunos.sh
-3b1.sh
-altos486.sh
-apollo.sh
-dnix.sh
-dynix.sh
-fps.sh
-genix.sh
-greenhills.sh
-i386.sh
-isc_2.sh
-mips.sh
-mpc.sh
-opus.sh
-sco_2_3_0.sh
-sco_2_3_1.sh
-sco_2_3_2.sh
-sco_2_3_3.sh
-sco_2_3_4.sh
-stellar.sh
-sunos_4_0.sh
-ti1500.sh
-unisysdynix.sh
-uts.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. Be sure also 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.
+
+Have the appropriate amount of fun :-)
+
+ Andy Dougherty doughera@lafcol.lafayette.edu
+ Dept. of Physics
+ Lafayette College, Easton PA 18042
diff --git a/gnu/usr.bin/perl/hints/aix.sh b/gnu/usr.bin/perl/hints/aix.sh
index a9f277eed19..2c42151ea61 100644
--- a/gnu/usr.bin/perl/hints/aix.sh
+++ b/gnu/usr.bin/perl/hints/aix.sh
@@ -17,6 +17,9 @@ alignbytes=8
usemymalloc='n'
+so="a"
+dlext="so"
+
# Make setsockopt work correctly. See man page.
# ccflags='-D_BSD=44'
@@ -30,13 +33,19 @@ case "$osvers" in
ccflags='-D_ALL_SOURCE'
;;
*) # These hints at least work for 4.x, possibly other systems too.
- d_setregid='undef'
- d_setreuid='undef'
- ccflags='-qmaxmem=8192 -D_ALL_SOURCE -D_ANSI_C_SOURCE -D_POSIX_SOURCE'
+ ccflags='-D_ALL_SOURCE -D_ANSI_C_SOURCE -D_POSIX_SOURCE'
+ case "$cc" in
+ *gcc*) ;;
+ *) ccflags="-qmaxmem=8192 $ccflags" ;;
+ esac
nm_opt='-B'
;;
esac
+# These functions don't work like Perl expects them to.
+d_setregid='undef'
+d_setreuid='undef'
+
# The optimizer in 4.1.1 apparently generates bad code for scope.c.
# Configure doesn't offer an easy way to propagate extra variables
# only for certain cases, so the following contortion is required:
diff --git a/gnu/usr.bin/perl/hints/amigaos.sh b/gnu/usr.bin/perl/hints/amigaos.sh
new file mode 100644
index 00000000000..e7686436913
--- /dev/null
+++ b/gnu/usr.bin/perl/hints/amigaos.sh
@@ -0,0 +1,55 @@
+# 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'
+
+# Avoid telldir prototype conflict in pp_sys.c (AmigaOS uses const DIR *)
+# Configure should test for this. Volunteers?
+pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"'
+
+# 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/gnu/usr.bin/perl/hints/apollo.sh b/gnu/usr.bin/perl/hints/apollo.sh
index 26180396341..8c361aa0518 100644
--- a/gnu/usr.bin/perl/hints/apollo.sh
+++ b/gnu/usr.bin/perl/hints/apollo.sh
@@ -15,7 +15,7 @@ i_malloc='undef'
malloctype='void *'
# This info is left over from perl4.
-cat <<'EOF'
+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
diff --git a/gnu/usr.bin/perl/hints/aux.sh b/gnu/usr.bin/perl/hints/aux_3.sh
index add0f4dec8f..aa3150afbe7 100644
--- a/gnu/usr.bin/perl/hints/aux.sh
+++ b/gnu/usr.bin/perl/hints/aux_3.sh
@@ -1,12 +1,13 @@
-# hints/aux.sh
+# 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
-# Fri May 5 10:59:43 EDT 1995
+# Sun Jan 5 11:16:41 WET 1997
case "$cc" in
-gcc) optimize='-O2'
+*gcc*) optimize='-O2'
ccflags="$ccflags -D_POSIX_SOURCE"
echo "Setting hints for GNU CC."
;;
@@ -18,3 +19,4 @@ gcc) optimize='-O2'
echo "./Configure -Dcc=gcc"
;;
esac
+test -r ./broken-db.msg && . ./broken-db.msg
diff --git a/gnu/usr.bin/perl/hints/broken-db.msg b/gnu/usr.bin/perl/hints/broken-db.msg
new file mode 100644
index 00000000000..92ba0776bfc
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/hints/bsdos.sh b/gnu/usr.bin/perl/hints/bsdos.sh
index aedf4b69676..53adfa3b501 100644
--- a/gnu/usr.bin/perl/hints/bsdos.sh
+++ b/gnu/usr.bin/perl/hints/bsdos.sh
@@ -1,40 +1,60 @@
# hints/bsdos.sh
#
-# hints file for BSD/OS 2.x (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>
-# Mon Nov 27 17:25:51 CST 1995
+# 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
+# SYSV IPC tested Ok so I re-enabled.
#
-# You can override the compiler and loader on the Configure command line:
-# ./Configure -Dcc=shlicc2 -Dld=shlicc2
-
-# filename extension for shared library objects
-so='o'
+# To override the compiler on the command line:
+# ./Configure -Dcc=gcc2
+#
+# The BSD/OS distribution is built with:
+# ./Configure -des -Dbsdos_distribution=defined
-# Don't use this for Perl 5.002, which needs parallel sig_name and sig_num lists
-#sig_name='ZERO HUP INT QUIT ILL TRAP IOT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM URG STOP TSTP CONT CHLD TTIN TTOU IO XCPU XFSZ VTALRM PROF WINCH INFO USR1 USR2 '
signal_t='void'
d_voidsig='define'
-d_dosuid='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="$*"
-# BSD/OS X libraries are in their own tree
+# X libraries are in their own tree
glibpth="$glibpth /usr/X11/lib"
ldflags="$ldflags -L/usr/X11/lib"
# Avoid telldir prototype conflict in pp_sys.c
pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"'
+case "$optimize" in
+'') optimize='-O2' ;;
+esac
+
case "$bsdos_distribution" in
-defined)
- d_portable='no'
+''|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
@@ -49,51 +69,41 @@ case "$osvers" in
'') cc='gcc2' ;;
esac
;;
-2.0*)
+2.0*|2.1*|3.0*)
+ so='o'
+
# default to GCC 2.X w/shared libraries
case "$cc" in
- '') cc='shlicc2' ;;
+ '') cc='shlicc2'
+ cccdlflags=' ' ;; # Avoid the dreaded -fpic
esac
# default ld to shared library linker
case "$ld" in
- '') ld='shlicc2' ;;
+ '') ld='shlicc2'
+ lddlflags='-r' ;; # this one is necessary
esac
- # setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS stuff
- # in 4.4BSD-based systems (including BSD/OS 2.0 and later).
- # See http://www.bsdi.com/bsdi-man?setuid(2)
- d_setregid='undef'
- d_setreuid='undef'
- d_setrgid='undef'
- d_setruid='undef'
+ # Must preload the static shared libraries.
+ libswanted="Xpm Xaw Xmu Xt SM ICE Xext X11 $libswanted"
+ libswanted="rpc curses termcap $libswanted"
;;
-2.1*)
- # Use 2.1's shlicc2 for dynamic linking
- # Since cc -o is linking, use it for compiling too.
- # I'm not sure whether Configure is careful about
- # distinguishing between the two.
+3.1*)
+ # ELF dynamic link libraries starting in 3.1
+ useshrplib='true'
+ so='so'
+ dlext='so'
case "$cc" in
- '') cc='shlicc2'
- cccdlflags=' ' ;; # Avoid the dreaded -fpic
+ '') cc='cc' # cc is gcc2 in 3.1
+ cccdlflags="-fPIC"
+ ccdlflags=" " ;;
esac
- # Link with shared libraries in 2.1
- # Turns out that shlicc2 will automatically use the
- # shared libs, so don't explicitly specify -lc_s.2.1.*
case "$ld" in
- '') ld='shlicc2'
- lddlflags='-r' ;; # this one is necessary
+ '') ld='ld'
+ lddlflags="-shared -x $lddlflags" ;;
esac
-
- # setre?[ug]id() have been replaced by the _POSIX_SAVED_IDS stuff
- # in 4.4BSD-based systems (including BSD/OS 2.0 and later).
- # See http://www.bsdi.com/bsdi-man?setuid(2)
- # This stuff may or may not be right, but it works.
- d_setregid='undef'
- d_setreuid='undef'
- d_setrgid='undef'
- d_setruid='undef'
;;
esac
+
diff --git a/gnu/usr.bin/perl/hints/convexos.sh b/gnu/usr.bin/perl/hints/convexos.sh
index f0ce4097563..9f6d702b06c 100644
--- a/gnu/usr.bin/perl/hints/convexos.sh
+++ b/gnu/usr.bin/perl/hints/convexos.sh
@@ -10,11 +10,3 @@
set X $myuname
shift
osvers=$4
-# ConvexOS 10.2 uses POSIX process group semantics for getpgrp but
-# BSD semantics for setpgrp. Perl assumes you don't have such
-# a mixed system, so we undef d_getpgrp.
-# Andy Dougherty doughera@lafcol.lafayette.edu
-#
-case "$osvers" in
-10.2) d_getpgrp='undef' ;;
-esac
diff --git a/gnu/usr.bin/perl/hints/cxux.sh b/gnu/usr.bin/perl/hints/cxux.sh
index 66608decef0..e3ac086e235 100644
--- a/gnu/usr.bin/perl/hints/cxux.sh
+++ b/gnu/usr.bin/perl/hints/cxux.sh
@@ -1,37 +1,38 @@
-# Hints for the CX/UX 7.1 operating system running on Harris NightHawk
-# machines. written by Tom.Horsley@mail.hcsc.com
+#! /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 Harris C compiler.
+# 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 ''
- echo WARNING: Do not build perl 5 with the SDE_TARGET set to
- echo generate coff object - perl 5 must be built in the ELF
- echo environment.
- 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 ''
- echo 'Unknown SDE_TARGET value: '$SDE_TARGET
- echo '';;
+ *) echo '' >&2
+ echo 'Unknown SDE_TARGET value: '$SDE_TARGET >&2
+ echo '' >&2 ;;
esac
case `uname -r` in
[789]*) : ;;
*) echo ''
- echo ''
- echo WARNING: Perl 5 requires shared library support, it cannot
- echo be built on releases of CX/UX prior to 7.0 with this hints
- echo file. You\'ll have to do a separate port for the statically
- echo linked COFF environment.
- 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 Harris, we use a source management tool which winds up
+# 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
@@ -60,16 +61,18 @@ libswanted=`echo ' '$libswanted' ' | sed -e 's/ malloc / /'`
#
glibpth="/usr/sde/elf/usr/lib $glibpth"
-# Need to use Harris 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
+# 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).
+# 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'
+cc='/bin/cc -Xa -Qtarget=M88110compat -DCXUX_BROKEN_CONSTANT_CONVERT'
cccdlflags='-Zelf -Zpic'
ccdlflags='-Zelf -Zlink=dynamic -Wl,-Bexport -u sigaction'
lddlflags='-Zlink=so'
@@ -91,11 +94,13 @@ i_ndbm='undef'
d_mymalloc='undef'
usemymalloc='n'
-cat <<'EOM'
+cat <<'EOM' >&4
-You will get a failure on lib/posix.t test 16 because ungetc() on
-stdin does not work if no characters have been read from stdin.
-If you type a character at the terminal where you are running
-the tests, you can fool it into thinking it worked.
+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/gnu/usr.bin/perl/hints/cygwin32.sh b/gnu/usr.bin/perl/hints/cygwin32.sh
new file mode 100644
index 00000000000..5853499954a
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/hints/dcosx.sh b/gnu/usr.bin/perl/hints/dcosx.sh
new file mode 100644
index 00000000000..c1b0d0ac420
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/hints/dec_osf.sh b/gnu/usr.bin/perl/hints/dec_osf.sh
index bfd235faaf9..255505b087f 100644
--- a/gnu/usr.bin/perl/hints/dec_osf.sh
+++ b/gnu/usr.bin/perl/hints/dec_osf.sh
@@ -1,11 +1,280 @@
# 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' ;;
+ old) optimize='-O2 -Olimit 3200' ;;
+ esac
+ ccflags="$ccflags -D_INTRINSICS"
+ ;;
+ esac
+ ;;
+esac
+
+# 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
-'')
- case "$cc" in
- *gcc*) ;;
- *) optimize='-O2 -Olimit 2900' ;;
- esac
- ;;
-esac
-ccflags="$ccflags -DSTANDARD_C"
-lddlflags='-shared -expect_unresolved "*" -s -hidden'
+ *-g*) ;; # left intentionally blank
+*) case "$_DEC_uname_r" in
+ *[123].*)
+ case "$useshrplib" in
+ false|undef|'') lddlflags="$lddlflags -s" ;;
+ esac
+ ;;
+ *) lddlflags="$lddlflags -s"
+ ;;
+ esac
+ ;;
+esac
+
+#
+# Unset temporary variables no more needed.
+#
+
+unset _DEC_cc_style
+unset _DEC_uname_r
+
+#
+# History:
+#
+# 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/gnu/usr.bin/perl/hints/dgux.sh b/gnu/usr.bin/perl/hints/dgux.sh
index bc54c945bd1..03b285dbd4a 100644
--- a/gnu/usr.bin/perl/hints/dgux.sh
+++ b/gnu/usr.bin/perl/hints/dgux.sh
@@ -1,13 +1,13 @@
-# $Id: dgux.sh,v 1.4 1996/01/18 03:40:38 roderick Exp $
+# $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
-# developed using version 5.4.3.10 of the OS. I think the gross
-# features should work with versions 5.4.2 through 5.4.4.11 with perhaps
-# minor tweaking, but I don't have any older or newer versions installed
-# at the moment with which to test it.
+# 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 5.4.3.0 it has shipped with Perl 4.036
+# 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),
@@ -18,7 +18,7 @@
# your $LD_LIBRARY_PATH to include the source directory when you build,
# test and install the software.
#
-# -Roderick Schertler <roderick@gate.net>
+# -Roderick Schertler <roderick@argon.org>
# Here are the things from some old DGUX hints files which are different
@@ -34,7 +34,7 @@
# 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 5.4.2.01 of DGUX.
+# file said it was developed with version 2.01 of DGUX.
#
# gidtype='gid_t'
# groupstype='gid_t'
@@ -53,7 +53,7 @@
#
# 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 5.4.2.01 loaded and my memory
+# 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.
@@ -82,8 +82,45 @@ usevfork=true
# $plibpth to explicitly include the place to which the elinks point
# allows Configure to find libraries which vary based on the development
# environment.
-plibpth="$plibpth \
- ${SDE_PATH:-/usr}/sde/${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib"
+#
+# 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
@@ -93,31 +130,12 @@ plibpth="$plibpth \
libswanted="dgc $libswanted"
# Dynamic loading works using the dlopen() functions. Note that dlfcn.h
-# is broken, it declares _dl*() rather than dl*(). (This is in my
-# I'd-open-a-ticket-about-this-if-it-weren't-going-to-be-such-a-hassle
-# file.) You can ignore the warnings caused by the missing
-# declarations, they're harmless.
+# 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
-# The Perl library has to be built as a shared library so that dynamic
-# loading will work (otherwise code loaded with dlopen() won't be able
-# to reference symbols in the main part of perl). Note that since
-# Configure doesn't normally prompt about $d_shrplib this will cause a
-# `Whoa there!'. This is normal, just keep the recommended value. A
-# consequence of all this is that you've got to include the source
-# directory in your LD_LIBRARY_PATH when you're building and testing
-# perl.
-d_shrplib=define
-
-# The system has a function called dg_flock() which is an flock()
-# emulation built using fcntl() locking. Perl currently comes with an
-# flock() emulation which uses lockf(), it should eventually also
-# include an fcntl() emulation of its own. Until that happens I
-# recommend using DG's emulation (and ignoring the `WHOA THERE!' this
-# causes), it provides semantics closer to the original than the lockf()
-# emulation.
-ccflags="$ccflags -Dflock=dg_flock"
-d_flock=define
diff --git a/gnu/usr.bin/perl/hints/dnix.sh b/gnu/usr.bin/perl/hints/dnix.sh
deleted file mode 100644
index 5b67dab8f2d..00000000000
--- a/gnu/usr.bin/perl/hints/dnix.sh
+++ /dev/null
@@ -1 +0,0 @@
-optimize='-g'
diff --git a/gnu/usr.bin/perl/hints/dynixptx.sh b/gnu/usr.bin/perl/hints/dynixptx.sh
index d44f6b82cde..78a45e42a31 100644
--- a/gnu/usr.bin/perl/hints/dynixptx.sh
+++ b/gnu/usr.bin/perl/hints/dynixptx.sh
@@ -8,32 +8,17 @@ 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 -l inet
+# 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'
-# The Perl library has to be built as a shared library so that dynamic
-# loading will work (otherwise code loaded with dlopen() won't be able
-# to reference symbols in the main part of perl). Note that since
-# Configure doesn't normally prompt about $d_shrplib this will cause a
-# `Whoa there!'. This is normal, just keep the recommended value. A
-# consequence of all this is that you've got to include the source
-# directory in your LD_LIBRARY_PATH when you're building and testing
-# perl.
-d_shrplib=define
-
-cat <<'EOM' >&4
-
-If you get a 'Whoa there!' with regard to d_shrplib, you can ignore
-it, and just keep the recommended value.
-
-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
+# 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/gnu/usr.bin/perl/hints/epix.sh b/gnu/usr.bin/perl/hints/epix.sh
index 25e357328f1..b91537a202a 100644
--- a/gnu/usr.bin/perl/hints/epix.sh
+++ b/gnu/usr.bin/perl/hints/epix.sh
@@ -28,7 +28,7 @@ usrinc='/svr4/usr/include'
strings='/svr4/usr/include/string.h'
timeincl='/svr4/usr/include/sys/time.h '
libc='/svr4/usr/lib/libc.a'
-libpth='/svr4/usr/lib /svr4/usr/lib/cmplrs/cc /usr/ccs/lib /svr4/lib /svr4/usr/ucblib'
+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
diff --git a/gnu/usr.bin/perl/hints/esix4.sh b/gnu/usr.bin/perl/hints/esix4.sh
index c8dec8a8b8e..3d3145d2550 100644
--- a/gnu/usr.bin/perl/hints/esix4.sh
+++ b/gnu/usr.bin/perl/hints/esix4.sh
@@ -19,7 +19,7 @@ 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
+ 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
@@ -30,7 +30,7 @@ EOM
rm -f /tmp/esix$$
fi
-cat <<'EOM'
+cat <<'EOM' >&4
If you wish to use dynamic linking, you must use
LD_LIBRARY_PATH=`pwd`; export LD_LIBRARY_PATH
diff --git a/gnu/usr.bin/perl/hints/freebsd.sh b/gnu/usr.bin/perl/hints/freebsd.sh
index 1e92053cf54..6ce5fa720c7 100644
--- a/gnu/usr.bin/perl/hints/freebsd.sh
+++ b/gnu/usr.bin/perl/hints/freebsd.sh
@@ -14,6 +14,10 @@
# 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)
+#
# 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
@@ -43,16 +47,41 @@ case "$osvers" in
d_setruid='undef'
;;
#
-# Trying to cover 2.0.5, 2.1-current and future 2.1
+# 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.1
+# Guesses at what will be needed after 2.2
*) usevfork='true'
+ usemymalloc='n'
+ libswanted=`echo $libswanted | sed 's/ malloc / /'`
;;
esac
@@ -69,7 +98,7 @@ esac
# Configure should test for this. Volunteers?
pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"'
-cat <<'EOM'
+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
diff --git a/gnu/usr.bin/perl/hints/hpux.sh b/gnu/usr.bin/perl/hints/hpux.sh
index 8eaf272d70e..c2500d0c370 100644
--- a/gnu/usr.bin/perl/hints/hpux.sh
+++ b/gnu/usr.bin/perl/hints/hpux.sh
@@ -1,24 +1,68 @@
+#! /bin/sh
+
# hints/hpux.sh
-# Perl Configure hints file for Hewlett Packard HP/UX 9.x and 10.x
-# This file is based on
-# hints/hpux_9.sh, Perl Configure hints file for Hewlett Packard HP/UX 9.x
+# 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@hpcc123.corp.hp.com>
-# Date: Thu, 28 Sep 95 11:06:07 PDT
+#
+# From: Jeff Okamoto <okamoto@corp.hp.com>
# and
-# hints/hpux_10.sh, Perl Configure hints file for Hewlett Packard HP/UX 10.x
+# hints/hpux_10.sh, Perl Configure hints file for Hewlett Packard HP-UX 10.x
# From: Giles Lean <giles@nemeton.com.au>
-# Date: Tue, 27 Jun 1995 08:17:45 +1000
+# 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.
-
-# Some users have reported problems with dynamic loading if the
-# environment variable LDOPTS='-a archive' .
+#
+# 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", you might have to
+# add the following to your ccflags: '-Wp,-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"
-ldflags="$ldflags"
+
+# If you plan to use gcc, then you should uncomment the following line
+# so you get the HP math library and not the GCC math library.
+# ccflags="$ccflags -L/lib/pa1.1"
# 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
@@ -28,7 +72,7 @@ case "$cc" in
then
case "$usedl" in
'') usedl="$undef"
- cat <<'EOM'
+ cat <<'EOM' >&4
The bundled C compiler can not produce shared libraries, so you will
not be able to use dynamic loading.
@@ -39,49 +83,48 @@ EOM
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
# Determine the architecture type of this system.
-xxuname=`uname -r`
-if echo $xxuname | $contains '10'
+# 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.0
- xxcontext=`grep $(printf %#x $(getconf CPU_VERSION)) /usr/include/sys/unistd.h`
- if echo "$xxcontext" | $contains 'PA-RISC1.1'
- then
- archname='PA-RISC1.1'
- elif echo "$xxcontext" | $contains 'PA-RISC1.0'
- then
- archname='PA-RISC1.0'
- elif echo "$xxcontext" | $contains 'PA-RISC2'
- then
- archname='PA-RISC2'
- else
- echo "This 10.0 system is of a PA-RISC type I don't recognize."
- echo "Debugging output: $xxcontext"
- archname=''
- fi
+ # 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 not running 10.0
- xxcontext=`/bin/getcontext`
- if echo "$xxcontext" | $contains 'PA-RISC1.1'
- then
- archname='PA-RISC1.1'
- elif echo "$xxcontext" | $contains 'PA-RISC1.0'
- then
- archname='PA-RISC1.0'
- elif echo "$xxcontext" | $contains 'HP-MC'
- then
- archname='HP-MC68K'
- else
- echo "I cannot recognize what chip set this system is using."
- echo "Debugging output: $xxcontext"
- archname=''
- fi
+ # 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)
@@ -91,27 +134,29 @@ fi
# 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 @ @'`
+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.
-# ccdlflags="-Wl,-E $ccdlflags"
+# 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
-selecttype='int *'
+# For native nm, you need "-p" to produce BSD format output.
+nm_opt='-p'
-# There are some lingering issues about whether g/setpgrp should be a part
-# of the perl core. This setting should cause perl to conform to the Principle
-# of Least Astonishment. The best thing is to use the g/setpgrp in the POSIX
-# module.
-d_bsdpgrp='define'
+# 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"'
@@ -121,3 +166,11 @@ d_bsdpgrp='define'
case "$prefix" in
'') prefix='/opt/perl5' ;;
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.
diff --git a/gnu/usr.bin/perl/hints/irix_4.sh b/gnu/usr.bin/perl/hints/irix_4.sh
index f934ac7725d..f5883f38cb7 100644
--- a/gnu/usr.bin/perl/hints/irix_4.sh
+++ b/gnu/usr.bin/perl/hints/irix_4.sh
@@ -7,7 +7,7 @@ d_voidsig=define
d_charsprf=undef
case "$cc" in
-*gcc) ccflags="$ccflags -D_BSD_TYPES" ;;
+*gcc*) ccflags="$ccflags -D_BSD_TYPES" ;;
*) ccflags="$ccflags -ansiposix -signed" ;;
esac
@@ -17,7 +17,7 @@ esac
# 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'
+cat <<'EOM' >&4
If you have problems, you might have try including
-DSTANDARD_C -cckr
in ccflags.
diff --git a/gnu/usr.bin/perl/hints/irix_5.sh b/gnu/usr.bin/perl/hints/irix_5.sh
index 5027b1574f8..e4d03473281 100644
--- a/gnu/usr.bin/perl/hints/irix_5.sh
+++ b/gnu/usr.bin/perl/hints/irix_5.sh
@@ -11,7 +11,7 @@ ld=ld
i_time='define'
case "$cc" in
-*gcc) ccflags="$ccflags -D_BSD_TYPES" ;;
+*gcc*) ccflags="$ccflags -D_BSD_TYPES" ;;
*) ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 3000" ;;
esac
diff --git a/gnu/usr.bin/perl/hints/irix_6.sh b/gnu/usr.bin/perl/hints/irix_6.sh
index 38fe27d282c..795b6ab640d 100644
--- a/gnu/usr.bin/perl/hints/irix_6.sh
+++ b/gnu/usr.bin/perl/hints/irix_6.sh
@@ -1,43 +1,114 @@
-# 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"
+# 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
+
+# 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"*)
+
+ # 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.*) # Mongoose 7.1+
+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1110,1184 -OPT:Olimit=0"
+ 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
+ ldflags=' -L/usr/local/lib -L/usr/lib32 -L/lib32'
+ 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'
+ ;;
+*)
+ # 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
+
+# This should be a Configure thing, but not for now...
+pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"'
# 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="$*"
+
+# 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)
#
-# 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="$*"
+# 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. -- scotth@sgi.com
+
+set `echo X "$libswanted "|sed -e 's/ sun / /' -e 's/ crypt / /' -e 's/ bsd / /' -e 's/ PW / /'`
+shift
+libswanted="$*"
diff --git a/gnu/usr.bin/perl/hints/irix_6_0.sh b/gnu/usr.bin/perl/hints/irix_6_0.sh
new file mode 100644
index 00000000000..38fe27d282c
--- /dev/null
+++ b/gnu/usr.bin/perl/hints/irix_6_0.sh
@@ -0,0 +1,43 @@
+# 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="$*"
diff --git a/gnu/usr.bin/perl/hints/irix_6_1.sh b/gnu/usr.bin/perl/hints/irix_6_1.sh
new file mode 100644
index 00000000000..38fe27d282c
--- /dev/null
+++ b/gnu/usr.bin/perl/hints/irix_6_1.sh
@@ -0,0 +1,43 @@
+# 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="$*"
diff --git a/gnu/usr.bin/perl/hints/irix_6_2.sh b/gnu/usr.bin/perl/hints/irix_6_2.sh
deleted file mode 100644
index 111c4ad02ca..00000000000
--- a/gnu/usr.bin/perl/hints/irix_6_2.sh
+++ /dev/null
@@ -1,28 +0,0 @@
-# irix_6_2.sh
-# from Krishna Sethuraman, krishna@sgi.com
-# Date: Tue Aug 22 00:38:26 PDT 1995
-# removed -ansiposix and -D_POSIX_SOURCE cuz it was choking
-
-# Perl built with this hints file under IRIX 6.2 passes
-# all tests (`make test').
-
-ld=ld
-i_time='define'
-cc="cc -32"
-ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -Olimit 3000"
-#ccflags="$ccflags -Olimit 3000" # this line builds perl but not tk (beta 8)
-lddlflags="-32 -shared"
-# Configure would suggest the default -Kpic, which won't work for SGI.
-# Configure will respect this blank hint value instead.
-cccdlflags=' '
-
-# 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="$*"
-# 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)
-#set `echo X "$libswanted "|sed -e 's/ sun / /' -e 's/ crypt / /' -e 's/ bsd / /' -e 's/ PW / /'`
-#shift
-#libswanted="$*"
diff --git a/gnu/usr.bin/perl/hints/isc.sh b/gnu/usr.bin/perl/hints/isc.sh
index df745a9b252..43b70fde366 100644
--- a/gnu/usr.bin/perl/hints/isc.sh
+++ b/gnu/usr.bin/perl/hints/isc.sh
@@ -28,6 +28,12 @@ case "$cc" in
;;
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
+
# 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.
diff --git a/gnu/usr.bin/perl/hints/linux.sh b/gnu/usr.bin/perl/hints/linux.sh
index b76ee89e515..8ddb765e1e0 100644
--- a/gnu/usr.bin/perl/hints/linux.sh
+++ b/gnu/usr.bin/perl/hints/linux.sh
@@ -15,6 +15,9 @@
# 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.
@@ -26,6 +29,14 @@ esac
# gcc-2.6.3 defines _G_HAVE_BOOL to 1, but doesn't actually supply bool.
ccflags="-Dbool=char -DHAS_BOOL $ccflags"
+# libc6, aka glibc2, seems to need STRUCT_TM_HASZONE defined.
+# Thanks to Bart Schuller <schuller@Lunatech.com>
+# See Message-ID: <19971009002636.50729@tanglefoot>
+# This is currently commented out for maintenance releases
+# but should probably be uncommented for 5.005 or after
+# more widespread testing.
+#POSIX_cflags='ccflags="$ccflags -DSTRUCT_TM_HASZONE"'
+
# BSD compatability library no longer needed
set `echo X "$libswanted "| sed -e 's/ bsd / /'`
shift
@@ -134,8 +145,8 @@ fi
rm -f try.c a.out
if /bin/bash -c exit; then
- echo
- echo You appear to have a working bash. Good.
+ echo ''
+ echo 'You appear to have a working bash. Good.'
else
cat << 'EOM' >&4
@@ -148,16 +159,46 @@ EOM
fi
-# Avoid some troublesome gcvt() functions. With some libc versions,
-# perl -e '$x=1e5; print "$x\n";' prints 1e+5. We'd like it
-# to print 100000 instead, consistent with the integer value given
-# on other platforms. This isn't a bug in gcvt, really; more in our
-# expectations for it. We'd like it to behave exactly as
-# sprintf %.16g, but it isn't documented to do that.
-#
-# We'll use sprintf() instead, since we can control the output more
-# precisely.
+# 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 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'
#
-# The next version of Configure will check for this automatically.
-d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+# it should be:
+# ccdlflags='-Wl,-E'
diff --git a/gnu/usr.bin/perl/hints/lynxos.sh b/gnu/usr.bin/perl/hints/lynxos.sh
new file mode 100644
index 00000000000..ddffcbe3cc7
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/hints/machten.sh b/gnu/usr.bin/perl/hints/machten.sh
index c86707c1827..380f70261d8 100644
--- a/gnu/usr.bin/perl/hints/machten.sh
+++ b/gnu/usr.bin/perl/hints/machten.sh
@@ -1,8 +1,8 @@
# machten.sh
-# This is for MachTen 4.0.2. It might work on other versions too.
+# This is for MachTen 4.0.3. It might work on other versions and variants too.
#
-# MachTen users might need a fixed tr from ftp.tenon.com. This should
-# be described in the MachTen release notes.
+# 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.
#
@@ -13,28 +13,53 @@
# Martijn Koster <m.koster@webcrawler.com>
# Richard Yeh <rcyeh@cco.caltech.edu>
#
-# File::Find's use of link count disabled by Dominic Dunlop 950528
-# Perl's use of sigsetjmp etc. disabled by Dominic Dunlop 950521
+# 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.X does support dynamic loading, but perl doesn't
# know how to use it yet.
-#
-# Updated by Dominic Dunlop <domo@tcp.ip.lu>
-# Tue May 28 11:20:08 WET DST 1996
-# Configure doesn't know how to parse the nm output.
-usenm=undef
+# 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.
+usemymalloc='false'
+
+# Make symbol table listings les voluminous
+nmopts=-gp
+
+# Increase perl's stack size. Without this, lib/complex.t crashes out.
+# Particularly perverse programs may require that perl has an even larger
+# stack allocation than that specified here. (See man setstackspace )
+ldflags='-Xlstack=0x014000'
+
+# 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
-# There appears to be a problem with perl's use of sigsetjmp and
+# 4.0.2 and earlier had a problem with perl's use of sigsetjmp and
# friends. Use setjmp and friends instead.
-d_sigsetjmp='undef'
+expr "$osvers" \< "4.0.3" > /dev/null && d_sigsetjmp='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="$*"
# MachTen always reports ony two links to directories, even if they
# contain subdirectories. Consequently, we use this variable to stop
@@ -56,7 +81,8 @@ 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.
+ Propagating recommended variable nmopts
+Read the File::Find documentation for more information about dont_use_nlink
EOM
+test -r ./broken-db.msg && . ./broken-db.msg
diff --git a/gnu/usr.bin/perl/hints/machten_2.sh b/gnu/usr.bin/perl/hints/machten_2.sh
index e9fe41df134..bc7dde4e3fa 100644
--- a/gnu/usr.bin/perl/hints/machten_2.sh
+++ b/gnu/usr.bin/perl/hints/machten_2.sh
@@ -3,17 +3,57 @@
# Comments, questions, and improvements welcome!
#
# MachTen does not support dynamic loading. If you wish to, you
-# can get <ftp://tsx-11.mit.edu/pub/linux/sources/libs/dld-src-3.2.4.tar.gz>
-# compile and install. This is the version of DLD that works with the
-# ext/DynaLoader/dl_dld.xs in the perl5 package. Have fun!
+# 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>
-# Fri Feb 9 13:04:45 EST 1996
+# 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 don't know why this is needed. It might be similar to NeXT's
-# problem. See hints/next_3.sh.
-usemymalloc='n'
+# 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.
@@ -33,14 +73,13 @@ i_db=$undef
# 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
-Tests
- io/fs test 4 and
- op/stat test 3
-may fail since MachTen versions 2.X have no hard links.
+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
@@ -49,4 +88,7 @@ Hmm...You had some extra variables I don't know about...I'll try to keep 'em.
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/gnu/usr.bin/perl/hints/mips.sh b/gnu/usr.bin/perl/hints/mips.sh
index 39cadb4b667..bc0b7e80737 100644
--- a/gnu/usr.bin/perl/hints/mips.sh
+++ b/gnu/usr.bin/perl/hints/mips.sh
@@ -2,11 +2,11 @@ perl_cflags='optimize="-g"'
d_volatile=undef
d_castneg=undef
cc=cc
-libpth="/usr/lib/cmplrs/cc $libpth"
+glibpth="/usr/lib/cmplrs/cc $glibpth"
groupstype=int
nm_opt='-B'
case $PATH in
-*bsd*:/bin:*) cat <<END
+*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
diff --git a/gnu/usr.bin/perl/hints/mpeix.sh b/gnu/usr.bin/perl/hints/mpeix.sh
index 9fc2737893a..e952f0e0023 100644
--- a/gnu/usr.bin/perl/hints/mpeix.sh
+++ b/gnu/usr.bin/perl/hints/mpeix.sh
@@ -5,7 +5,7 @@ osvers='5.0'
alignbytes='8'
ccflags='-D_POSIX_SOURCE -D_SOCKET_SOURCE -D_POSIX_JOB_CONTROL'
cc='c89'
-optimize='-g'
+optimize='none'
d_safebcpy='undef'
d_safemcpy='undef'
intsize='8'
diff --git a/gnu/usr.bin/perl/hints/netbsd.sh b/gnu/usr.bin/perl/hints/netbsd.sh
index 24ffe15f730..c508815a46c 100644
--- a/gnu/usr.bin/perl/hints/netbsd.sh
+++ b/gnu/usr.bin/perl/hints/netbsd.sh
@@ -5,22 +5,51 @@
# 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.
+# 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"
;;
-*) d_dlopen=$define
- d_dlerror=$define
+*)
+ 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"
-# netbsd has these but they don't really work as advertised. 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.
+ cccdlflags="-DPIC -fPIC $cccdlflags"
+ lddlflags="-Bforcearchive -Bshareable $lddlflags"
+ ;;
+ esac
+ ;;
+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"
@@ -31,9 +60,3 @@ esac
# Avoid telldir prototype conflict in pp_sys.c (NetBSD uses const DIR *)
# Configure should test for this. Volunteers?
pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"'
-
-case "$archname" in
-'')
- archname=`uname -m`-${osname}
- ;;
-esac
diff --git a/gnu/usr.bin/perl/hints/newsos4.sh b/gnu/usr.bin/perl/hints/newsos4.sh
new file mode 100644
index 00000000000..a33cb3154a3
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/hints/next_3.sh b/gnu/usr.bin/perl/hints/next_3.sh
index 7db901c7385..55e89591d88 100644
--- a/gnu/usr.bin/perl/hints/next_3.sh
+++ b/gnu/usr.bin/perl/hints/next_3.sh
@@ -1,41 +1,131 @@
-# 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 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'
-POSIX_cflags='ccflags="-posix $ccflags"'
+usemymalloc='n'
+
+######################################################################
+# End of the MALLOC story
+######################################################################
+
ldflags='-u libsys_s'
libswanted='dbm gdbm db'
-lddlflags='-r'
+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'
-# 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'
-d_setpgid='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."
-# (Thanks to Andreas Koenig <k@franz.ww.tu-berlin.de>)
+#
ranlib='sleep 5; /bin/ranlib'
+
#
# There where reports that the compiler on HPPA machines
# fails with the -O flag on pp.c.
-if [ `arch` = "hppa" ]; then
-pp_cflags='optimize="-g"'
-fi
+# 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/gnu/usr.bin/perl/hints/next_3_0.sh b/gnu/usr.bin/perl/hints/next_3_0.sh
index 3a50247e9c4..b8cc2c2d905 100644
--- a/gnu/usr.bin/perl/hints/next_3_0.sh
+++ b/gnu/usr.bin/perl/hints/next_3_0.sh
@@ -6,15 +6,15 @@
# <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.
-echo Be aware that some of the tests that are run during "make test"
-echo will fail due to the lack of POSIX support on this system.
-echo
-echo Also, if you have the GDBM installed, make sure the header file
-echo is located at a place on the system where the C compiler will
-echo find it. By default, it is placed in /usr/local/include/gdbm.h.
-echo It will not be found there. Try moving it to
-echo /NextDeveloper/Headers/bsd/gdbm.h.
+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"'
@@ -35,10 +35,15 @@ d_strcoll='undef'
# with Larry's malloc on NS 3.2 due to broken sbrk()
usemymalloc='n'
d_uname='define'
-d_setpgid='define'
-d_setsid='define'
-d_tcgetpgrp='define'
-d_tcsetpgrp='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
diff --git a/gnu/usr.bin/perl/hints/next_4.sh b/gnu/usr.bin/perl/hints/next_4.sh
new file mode 100644
index 00000000000..316b3392123
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/hints/os2.sh b/gnu/usr.bin/perl/hints/os2.sh
index 43b4b8ea49b..2a589b5cb4a 100644
--- a/gnu/usr.bin/perl/hints/os2.sh
+++ b/gnu/usr.bin/perl/hints/os2.sh
@@ -1,3 +1,4 @@
+#! /bin/sh
# hints/os2.sh
# This file reflects the tireless work of
# Ilya Zakharevich <ilya@math.ohio-state.edu>
@@ -5,23 +6,87 @@
# Trimmed and comments added by
# Andy Dougherty <doughera@lafcol.lafayette.edu>
# Exactly what is required beyond a standard OS/2 installation?
-# There are notes about "patched pdksh" I don't understand.
+# (see in README.os2)
# Note that symbol extraction code gives wrong answers (sometimes?) on
# gethostent and setsid.
-# Note that during the .obj compile you need to move the perl.dll file
-# to LIBPATH :-(
+# 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
-#osname="OS/2"
-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`
+path_sep=\;
+
+if test -f $sh.exe; then sh=$sh.exe; fi
+
+startsh="#!$sh"
cc='gcc'
-usrinc='/emx/include'
-libemx="`../UU/loc . X c:/emx/lib d:/emx/lib e:/emx/lib f:/emx/lib g:/emx/lib h:/emx/lib /emx/lib`"
-if test "$libemx" = "X"; then echo "Cannot find C library!"; fi
+# 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`"
-libpth="$libemx/st $libemx"
+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'
@@ -30,37 +95,83 @@ so='dll'
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'
+if [ $emxcrtrev -ge 50 ]; then
+ aout_ldflags='-Zexe -Zsmall-conv'
+else
+ aout_ldflags='-Zexe'
+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. -DPACK_MALLOC -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK'
+aout_cppflags='-DPERL_CORE -DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK'
+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='undef'
- obj_ext='.o'
- lib_ext='.a'
- ar='ar'
- plibext='.a'
- d_fork='define'
- lddlflags='-Zdll'
- ldflags='-Zexe'
- ccflags='-DDOSISH -DNO_SYS_ALLOC -DOS2=2 -DEMBED -I. -DPACK_MALLOC'
- use_clib='c'
+ 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'
- d_fork='undef'
- lddlflags='-Zdll -Zomf -Zcrtdll'
+ if [ $emxcrtrev -ge 50 ]; then
+ d_fork='define'
+ else
+ d_fork='undef'
+ fi
+ lddlflags='-Zdll -Zomf -Zmt -Zcrtdll'
# Recursive regmatch may eat 2.5M of stack alone.
- ldflags='-Zexe -Zomf -Zcrtdll -Zstack 32000'
- ccflags='-Zomf -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC'
+ ldflags='-Zexe -Zomf -Zmt -Zcrtdll -Zstack 32000'
+ if [ $emxcrtrev -ge 50 ]; then
+ ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK'
+ else
+ ccflags='-Zomf -Zmt -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DEMX_BAD_SBRK'
+ fi
use_clib='c_import'
+ usedl='define'
fi
# 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/st/$use_clib$lib_ext"
+libc="$libemx/mt/$use_clib$lib_ext"
if test -r "$libemx/c_alias$lib_ext"; then
libnames="$libemx/c_alias$lib_ext"
@@ -69,19 +180,17 @@ fi
# [Maybe we should just remove c from $libswanted ?]
-libs='-lsocket -lm'
-archobjs="os2$obj_ext"
+# 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 - feature of patched ksh
-# [???]
-NOHASHBANG=sh
-# Same with newer ksh
+# Run files without extension with sh:
EXECSHELL=sh
cccdlflags='-Zdll'
-dlsrc='dl_os2.xs'
+dlsrc='dl_dlopen.xs'
ld='gcc'
-usedl='define'
#cppflags='-DDOSISH -DOS2=2 -DEMBED -I.'
@@ -116,6 +225,7 @@ 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'
@@ -123,17 +233,57 @@ lns='cp'
nm_opt='-p'
-####### All the rest is commented
+####### We define these functions ourselves
-# I do not have these:
-#dynamic_ext='Fcntl GDBM_File SDBM_File POSIX Socket UPM REXXCALL'
-#dynamic_ext='Fcntl POSIX Socket SDBM_File Devel/DProf'
-#extensions='Fcntl GDBM_File SDBM_File POSIX Socket UPM REXXCALL'
-#extensions='Fcntl SDBM_File POSIX Socket Devel/DProf'
+d_getprior='define'
+d_setprior='define'
-# The next two are commented. pdksh handles #!
+# 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"
+ ;;
+esac
+
+# 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 ../../hints
diff --git a/gnu/usr.bin/perl/hints/os390.sh b/gnu/usr.bin/perl/hints/os390.sh
new file mode 100644
index 00000000000..fd590eaa4e6
--- /dev/null
+++ b/gnu/usr.bin/perl/hints/os390.sh
@@ -0,0 +1,33 @@
+# hints/os390.sh
+# 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
+#
+
+cc='c89'
+ccflags='-DMAXSIG=38 -DOEMVS -D_OE_SOCKETS -D_XOPEN_SOURCE_EXTENDED -D_ALL_SOURCE'
+optimize='none'
+alignbytes=8
+usemymalloc='y'
+so='a'
+dlext='none'
+d_shmatprototype='define'
+usenm='false'
+i_time='define'
+i_systime='define'
+d_select='undef'
+
+# (from aix.sh)
+# uname -m output is too specific and not appropriate here
+#
+case "$archname" in
+'') archname="$osname" ;;
+esac
+
diff --git a/gnu/usr.bin/perl/hints/powerux.sh b/gnu/usr.bin/perl/hints/powerux.sh
index b1c082651f6..fd2ebe682db 100644
--- a/gnu/usr.bin/perl/hints/powerux.sh
+++ b/gnu/usr.bin/perl/hints/powerux.sh
@@ -1,10 +1,14 @@
-# Hints for the PowerUX operating system running on Harris NightHawk
-# machines. Written by Tom.Horsley@mail.hcsc.com
+# Hints for the PowerUX operating system running on Concurrent (formerly
+# Harris) NightHawk machines. Written by Tom.Horsley@mail.ccur.com
#
-# This config uses dynamic linking and the Harris C compiler. It has been
-# tested on a Harris 6800 running PowerUX.
+# 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 Harris, we use a source management tool which winds up
+# 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
@@ -26,9 +30,10 @@ then
fi
# We DO NOT want -lmalloc or -lPW, we DO need -lgen to follow -lnsl, so
-# fixup libswanted to reflect that desire.
+# 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 /'`
+libswanted=`echo ' '$libswanted' ' | sed -e 's/ malloc / /' -e 's/ PW / /' -e 's/ nsl / nsl gen resolv /'`
# We DO NOT want /usr/ucblib in glibpth
#
@@ -39,7 +44,7 @@ glibpth=`echo ' '$glibpth' ' | sed -e 's@ /usr/ucblib @ @'`
#
d_csh='undef'
-# Need to use Harris cc for most of these options to be meaningful (if you
+# 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
@@ -58,6 +63,18 @@ lddlflags='-Zlink=so'
#
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'
+
# Misc other flags that might be able to change, but I know these work right.
#
d_suidsafe='define'
diff --git a/gnu/usr.bin/perl/hints/qnx.sh b/gnu/usr.bin/perl/hints/qnx.sh
new file mode 100644
index 00000000000..947c98f6799
--- /dev/null
+++ b/gnu/usr.bin/perl/hints/qnx.sh
@@ -0,0 +1,184 @@
+#----------------------------------------------------------------
+# 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
+# If there is a softlink in your path, Findbin will fail.
+# This is a documented feature of perl's getpwd().
+# There is currently no support for dynamically linked
+# libraries.
+# op/magic.t failure due to a feature of QNX which rewrites script
+# names before they are executed. I think you'll find that if
+# you cd `fullpath -t` before doing the make, the test will pass.
+#----------------------------------------------------------------
+# At present, all QNX systems are equivalent architectures,
+# so it might be reasonable to call archname=qnx rather than
+# making an unnecessary distinction between AT-qnx and PCI-qnx,
+# for example.
+#----------------------------------------------------------------
+# 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 ""
+
+#----------------------------------------------------------------
+# 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/gnu/usr.bin/perl/hints/sco.sh b/gnu/usr.bin/perl/hints/sco.sh
index 307e27e4db2..cef1c0c9423 100644
--- a/gnu/usr.bin/perl/hints/sco.sh
+++ b/gnu/usr.bin/perl/hints/sco.sh
@@ -1,15 +1,35 @@
-# sco_3.sh
-# Courtesy of Joel Rosi-Schwartz <joel@ftechne.co.uk>
+# sco.sh
+# Courtesy of Joel Rosi-Schwartz <j.schwartz@agonet.it>
+
# Additional SCO version info from
# Peter Wolfe <wolfe@teloseng.com>
# Last revised
-# Tue Feb 13 09:09:10 EST 1996
+# 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:
-case `uname -X | egrep '^Release'` in
-*3.2v4.2) scorls=3 ;;
+# 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
@@ -30,17 +50,42 @@ glibpth=`echo $glibpth | sed -e 's! /usr/lib/386 ! !' -e 's! /lib/386 ! !'`
xlibpth=''
case "$cc" in
-gcc)
- ccflags="$ccflags -U M_XENIX"
+*gcc*) ccflags="$ccflags -U M_XENIX"
optimize="$optimize -O2"
;;
scocc) ;;
-*) # Apparently, SCO's cc gives rather verbose warnings
+# 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" ;;
+ 5) ccflags="$ccflags -w0 -U M_XENIX -DPERL_SCO5" ;;
esac
;;
esac
@@ -88,3 +133,8 @@ 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/gnu/usr.bin/perl/hints/sco_2_3_3.sh b/gnu/usr.bin/perl/hints/sco_2_3_3.sh
index 10baafd6a30..6d398fccf2e 100644
--- a/gnu/usr.bin/perl/hints/sco_2_3_3.sh
+++ b/gnu/usr.bin/perl/hints/sco_2_3_3.sh
@@ -1,3 +1,3 @@
yacc='/usr/bin/yacc -Sm25000'
-echo "NOTE: you may have problems due to a spurious semicolon on the strerror()"
-echo "macro definition in /usr/include/string.h. If so, delete the semicolon."
+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/gnu/usr.bin/perl/hints/sco_2_3_4.sh b/gnu/usr.bin/perl/hints/sco_2_3_4.sh
index 84f58172b3c..34bcadae5f5 100644
--- a/gnu/usr.bin/perl/hints/sco_2_3_4.sh
+++ b/gnu/usr.bin/perl/hints/sco_2_3_4.sh
@@ -1,5 +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()"
-echo "macro definition in /usr/include/string.h. If so, delete the semicolon."
+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/gnu/usr.bin/perl/hints/solaris_2.sh b/gnu/usr.bin/perl/hints/solaris_2.sh
index 6ce4666421e..d2124edb063 100644
--- a/gnu/usr.bin/perl/hints/solaris_2.sh
+++ b/gnu/usr.bin/perl/hints/solaris_2.sh
@@ -4,6 +4,13 @@
# 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
@@ -35,17 +42,6 @@ case "$archname" in
;;
esac
-# Solaris 2.5 has reintroduced some BSD-ish functions into libc.
-# This is no problem unless you compile perl under Solaris 2.5 but
-# try to run the binary on 2.4. Here, we take the easy way out by
-# claiming we don't have these functions. perl.h works around all of
-# these anyway.
-# XXX Eventually, I should fix perl.h to prefer the POSIX versions.
-d_bcmp='undef'
-d_bcopy='undef'
-d_safebcpy='undef'
-d_index='undef'
-
######################################################
# General sanity testing. See below for excerpts from the Solaris FAQ.
@@ -58,7 +54,7 @@ d_index='undef'
# Here's another draft of the perl5/solaris/gcc sanity-checker.
case $PATH in
-*/usr/ucb*:/usr/bin:*|*/usr/ucb*:/usr/bin) cat <<END
+*/usr/ucb*:/usr/bin:*|*/usr/ucb*:/usr/bin) cat <<END >&4
NOTE: Some people have reported problems with /usr/ucb/cc.
Remove /usr/ucb from your PATH if you have difficulties.
@@ -74,7 +70,7 @@ esac
case $? in
0) ;;
*)
- cat <<END
+ 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
@@ -90,7 +86,7 @@ esac
/usr/bin/ls /usr/lib/libucb* >/dev/null 2>&1
case $? in
0)
- cat <<END
+ 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.
@@ -107,7 +103,7 @@ if grep GNU make.vers > /dev/null 2>&1; then
tmp=`/usr/bin/which make`
case "`/usr/bin/ls -l $tmp`" in
??????s*)
- cat <<END
+ 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
@@ -148,11 +144,12 @@ case "`${cc:-cc} -v 2>&1`" in
case $verbose in
*/usr/ccs/bin/as*) ;;
*)
- cat <<END
+ 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.
+GCC_EXEC_PREFIX or by including -B/usr/ccs/bin/ in your cc command.
+(Note that the trailing "/" is required.)
END
;;
@@ -162,11 +159,11 @@ END
case $verbose in
*/usr/ccs/bin/ld*) ;;
*)
- cat <<END
+ 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.
+GCC_EXEC_PREFIX or by including -B/usr/ccs/bin/ in your cc command.
END
;;
@@ -182,7 +179,7 @@ END
# 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
+ 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
@@ -193,17 +190,32 @@ 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*)
- cat <<END
+ *GNU*|ld\ version\ 2*)
+ gnu_ld=true ;;
+ *) ;;
+ esac
+ if $gnu_ld ; then :
+ else
+ case `which ld` in
+ no\ ld\ in*|[Cc]ommand\ not\ found*)
+ ;;
+ /*gnu*/ld|/*GNU*/ld)
+ gnu_ld=true ;;
+ esac
+ fi
+ if $gnu_ld ; then
+ 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
+beginning of your PATH.
END
- ;;
- esac
+ fi
;; #not using gcc
esac
diff --git a/gnu/usr.bin/perl/hints/sunos_4_0.sh b/gnu/usr.bin/perl/hints/sunos_4_0.sh
index 99fce3f44b4..56a87bf5be3 100644
--- a/gnu/usr.bin/perl/hints/sunos_4_0.sh
+++ b/gnu/usr.bin/perl/hints/sunos_4_0.sh
@@ -1 +1,2 @@
ccflags="$ccflags -DFPUTS_BOTCH"
+i_unistd=$undef
diff --git a/gnu/usr.bin/perl/hints/sunos_4_1.sh b/gnu/usr.bin/perl/hints/sunos_4_1.sh
index ee42e2c448c..07cd89fc7b4 100644
--- a/gnu/usr.bin/perl/hints/sunos_4_1.sh
+++ b/gnu/usr.bin/perl/hints/sunos_4_1.sh
@@ -3,7 +3,9 @@
# Andy Dougherty <doughera@lafcol.lafayette.edu>
case "$cc" in
-*gcc*) usevfork=false ;;
+*gcc*) usevfork=false
+ # GNU as and GNU ld might not work. See the INSTALL file.
+ ;;
*) usevfork=true ;;
esac
@@ -13,15 +15,64 @@ esac
# 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. The POSIX extension is built with
+# unistd.h because, even though unistd.h has problems, if used with
+# care, it helps create a better POSIX extension.
+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
+
# SunOS 4.1.3 has two extra fields in struct tm. This works around
# the problem. Other BSD platforms may have similar problems.
POSIX_cflags='ccflags="$ccflags -DSTRUCT_TM_HASZONE"'
-# check if user is in a bsd or system 5 type environment
+# 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
- groupstype='gid_t'
+ 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/gnu/usr.bin/perl/hints/svr4.sh b/gnu/usr.bin/perl/hints/svr4.sh
index 5569274753c..922736aa487 100644
--- a/gnu/usr.bin/perl/hints/svr4.sh
+++ b/gnu/usr.bin/perl/hints/svr4.sh
@@ -32,6 +32,41 @@ usevfork='false'
# other SVR4 derivatives.
d_lstat=define
+# UnixWare has a broken csh. The undocumented -X argument to uname is probably
+# a reasonable way of detecting UnixWare. Also in 2.1.1 the fields in
+# FILE* got renamed!
+uw_ver=`uname -v`
+uw_isuw=`uname -X 2>&1 | grep Release`
+if [ "$uw_isuw" = "Release = 4.2MP" ]; then
+ case $uw_ver in
+ 2.1)
+ d_csh='undef'
+ ;;
+ 2.1.*)
+ d_csh='undef'
+ stdio_cnt='((fp)->__cnt)'
+ d_stdio_cnt_lval='define'
+ stdio_ptr='((fp)->__ptr)'
+ d_stdio_ptr_lval='define'
+ ;;
+ esac
+fi
+
+# DDE SMES Supermax Enterprise Server
+case "`uname -sm`" in
+"UNIX_SV SMES")
+ if test "$cc" = '/bin/cc' -o "$gccversion" = ""
+ then
+ # for cc we need -K PIC (not -K pic)
+ cccdlflags="$cccdlflags -K PIC"
+ fi
+ # the *grent functions are in libgen.
+ libswanted="$libswanted gen"
+ # csh is broken (also) in SMES
+ d_csh='undef'
+ ;;
+esac
+
cat <<'EOM' >&4
If you wish to use dynamic linking, you must use
diff --git a/gnu/usr.bin/perl/hints/titanos.sh b/gnu/usr.bin/perl/hints/titanos.sh
index 0f382ac0ff9..cea99f82a3a 100644
--- a/gnu/usr.bin/perl/hints/titanos.sh
+++ b/gnu/usr.bin/perl/hints/titanos.sh
@@ -1,6 +1,6 @@
# 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@hut.fi> Aug 27 1994
+# 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"
@@ -25,16 +25,15 @@ stdchar='unsigned char'
# 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='nsl dbm gdbm db PW malloc m'
+libswanted='sfio nsl dbm gdbm db PW malloc m'
#
# Extensions: This system can not compile POSIX. We'll let Configure
-# figure out the others. Certainly Fcntl, Socket, and at least one *DB*
-# extension should be included.
-# perl5.000 had: static_ext='DynaLoader NDBM_File Socket'
+# figure out the others.
useposix='n'
#
uidtype='ushort'
voidflags='7'
inclwanted='/usr/include /usr/include/net'
-libpth='/usr/lib /usr/local/lib /lib'
+# 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/gnu/usr.bin/perl/hints/ultrix_4.sh b/gnu/usr.bin/perl/hints/ultrix_4.sh
index e00450792dc..d8d2063b22d 100644
--- a/gnu/usr.bin/perl/hints/ultrix_4.sh
+++ b/gnu/usr.bin/perl/hints/ultrix_4.sh
@@ -4,9 +4,15 @@
#
# Use Configure -Dcc=gcc to use gcc.
#
-# I don't know if -g is really needed. (AD)
+# This used to use -g, but that pulls in -DDEBUGGING by default.
case "$optimize" in
-'') optimize=-g ;;
+'')
+ # 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
@@ -16,7 +22,7 @@ esac
# Then run "sh5 Configure.sh5 [your options]"
case "$myuname" in
-*risc*) cat <<EOF
+*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.
@@ -28,16 +34,16 @@ case "$cc" in
*gcc*) ;;
*)
case "$osvers" in
- *4.1*) ccflags="$ccflags -DLANGUAGE_C -Olimit 2900" ;;
- *4.2*) ccflags="$ccflags -DLANGUAGE_C -Olimit 2900"
+ *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 2900" ;;
- *) ccflags="$ccflags -std -Olimit 2900" ;;
+ *4.3*) ccflags="$ccflags -std1 -DLANGUAGE_C -Olimit 3200" ;;
+ *) ccflags="$ccflags -std -Olimit 3200" ;;
esac
;;
esac
@@ -50,4 +56,11 @@ case "$osvers" in
*) 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/gnu/usr.bin/perl/hints/umips.sh b/gnu/usr.bin/perl/hints/umips.sh
new file mode 100644
index 00000000000..17d5ff46239
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/hints/unicos.sh b/gnu/usr.bin/perl/hints/unicos.sh
index 272cb9b5d62..b864019a841 100644
--- a/gnu/usr.bin/perl/hints/unicos.sh
+++ b/gnu/usr.bin/perl/hints/unicos.sh
@@ -1,9 +1,7 @@
case `uname -r` in
6.1*) shellflags="-m+65536" ;;
esac
-ccflags="$ccflags -DHZ=__hertz"
optimize="-O1"
-libswanted=m
d_setregid='undef'
d_setreuid='undef'
diff --git a/gnu/usr.bin/perl/hints/unicosmk.sh b/gnu/usr.bin/perl/hints/unicosmk.sh
new file mode 100644
index 00000000000..90784b5b39f
--- /dev/null
+++ b/gnu/usr.bin/perl/hints/unicosmk.sh
@@ -0,0 +1,3 @@
+optimize="-O1"
+d_setregid='undef'
+d_setreuid='undef'
diff --git a/gnu/usr.bin/perl/hints/utekv.sh b/gnu/usr.bin/perl/hints/utekv.sh
index ebc7809c601..95a31fdedfe 100644
--- a/gnu/usr.bin/perl/hints/utekv.sh
+++ b/gnu/usr.bin/perl/hints/utekv.sh
@@ -6,7 +6,7 @@ ccflags="$ccflags -X18"
usemymalloc='y'
-echo " "
-echo "NOTE: You may have to take out makefile dependencies on the files in"
-echo "/usr/include (i.e. /usr/include/ctype.h) or the make will fail. A"
-echo "simple 'grep -v /usr/include/ makefile' should suffice."
+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/gnu/usr.bin/perl/hv.c b/gnu/usr.bin/perl/hv.c
index d9cbe52337f..4eaae0f08ce 100644
--- a/gnu/usr.bin/perl/hv.c
+++ b/gnu/usr.bin/perl/hv.c
@@ -1,6 +1,6 @@
/* hv.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -25,7 +25,7 @@ new_he()
HE* he;
if (he_root) {
he = he_root;
- he_root = (HE*)he->hent_next;
+ he_root = HeNEXT(he);
return he;
}
return more_he();
@@ -35,7 +35,7 @@ static void
del_he(p)
HE* p;
{
- p->hent_next = (HE*)he_root;
+ HeNEXT(p) = (HE*)he_root;
he_root = p;
}
@@ -48,13 +48,41 @@ more_he()
he = he_root;
heend = &he[1008 / sizeof(HE) - 1];
while (he < heend) {
- he->hent_next = (HE*)(he + 1);
+ HeNEXT(he) = (HE*)(he + 1);
he++;
}
- he->hent_next = 0;
+ HeNEXT(he) = 0;
return new_he();
}
+static HEK *
+save_hek(str, len, hash)
+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 *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,key,klen,lval)
HV *hv;
@@ -63,9 +91,7 @@ U32 klen;
I32 lval;
{
register XPVHV* xhv;
- register char *s;
- register I32 i;
- register I32 hash;
+ register U32 hash;
register HE *entry;
SV *sv;
@@ -93,29 +119,25 @@ I32 lval;
return 0;
}
- i = klen;
- hash = 0;
- s = key;
- while (i--)
- hash = hash * 33 + *s++;
+ PERL_HASH(hash, key, klen);
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
- for (; entry; entry = entry->hent_next) {
- if (entry->hent_hash != hash) /* strings can't be equal */
+ for (; entry; entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
- if (entry->hent_klen != klen)
+ if (HeKLEN(entry) != klen)
continue;
- if (bcmp(entry->hent_key,key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- return &entry->hent_val;
+ 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;
- gotenv = my_getenv(key);
- if (gotenv != NULL) {
+ if ((gotenv = ENV_getenv(key)) != Nullch) {
sv = newSVpv(gotenv,strlen(gotenv));
+ SvTAINTED_on(sv);
return hv_store(hv,key,klen,sv,hash);
}
}
@@ -127,6 +149,85 @@ I32 lval;
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,keysv,lval,hash)
+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) && mg_find((SV*)hv,'P')) {
+ static HE mh;
+
+ sv = sv_newmortal();
+ keysv = sv_2mortal(newSVsv(keysv));
+ mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
+ if (!HeKEY_hek(&mh)) {
+ char *k;
+ New(54, k, HEK_BASESIZE + sizeof(SV*), char);
+ HeKEY_hek(&mh) = (HEK*)k;
+ }
+ HeSVKEY_set(&mh, keysv);
+ HeVAL(&mh) = sv;
+ return &mh;
+ }
+
+ 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, sizeof(HE*) * (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 = ENV_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;
+}
+
SV**
hv_store(hv,key,klen,val,hash)
HV *hv;
@@ -136,7 +237,6 @@ SV *val;
register U32 hash;
{
register XPVHV* xhv;
- register char *s;
register I32 i;
register HE *entry;
register HE **oentry;
@@ -147,46 +247,120 @@ register U32 hash;
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(hv)) {
mg_copy((SV*)hv, val, key, klen);
-#ifndef OVERLOAD
- if (!xhv->xhv_array)
- return 0;
-#else
- if (!xhv->xhv_array && (SvMAGIC(hv)->mg_type != 'A'
- || SvMAGIC(hv)->mg_moremagic))
- return 0;
+ if (!xhv->xhv_array
+ && (SvMAGIC(hv)->mg_moremagic
+ || (SvMAGIC(hv)->mg_type != 'E'
+#ifdef OVERLOAD
+ && SvMAGIC(hv)->mg_type != 'A'
#endif /* OVERLOAD */
+ )))
+ return 0;
+ }
+ if (!hash)
+ PERL_HASH(hash, key, klen);
+
+ if (!xhv->xhv_array)
+ Newz(505, xhv->xhv_array, sizeof(HE**) * (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);
}
- if (!hash) {
- i = klen;
- s = key;
- while (i--)
- hash = hash * 33 + *s++;
+
+ return &HeVAL(entry);
+}
+
+HE *
+hv_store_ent(hv,keysv,val,hash)
+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)) {
+ bool save_taint = tainted;
+ if (tainting)
+ 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
+ && (SvMAGIC(hv)->mg_moremagic
+ || (SvMAGIC(hv)->mg_type != 'E'
+#ifdef OVERLOAD
+ && SvMAGIC(hv)->mg_type != 'A'
+#endif /* OVERLOAD */
+ )))
+ return Nullhe;
}
+ key = SvPV(keysv, klen);
+
+ if (!hash)
+ PERL_HASH(hash, key, klen);
+
if (!xhv->xhv_array)
Newz(505, xhv->xhv_array, sizeof(HE**) * (xhv->xhv_max + 1), char);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
i = 1;
- for (entry = *oentry; entry; i=0, entry = entry->hent_next) {
- if (entry->hent_hash != hash) /* strings can't be equal */
+ for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
- if (entry->hent_klen != klen)
+ if (HeKLEN(entry) != klen)
continue;
- if (bcmp(entry->hent_key,key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- SvREFCNT_dec(entry->hent_val);
- entry->hent_val = val;
- return &entry->hent_val;
+ SvREFCNT_dec(HeVAL(entry));
+ HeVAL(entry) = val;
+ return entry;
}
entry = new_he();
- entry->hent_klen = klen;
- entry->hent_key = savepvn(key,klen);
- entry->hent_val = val;
- entry->hent_hash = hash;
- entry->hent_next = *oentry;
+ 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++;
@@ -196,7 +370,7 @@ register U32 hash;
hsplit(hv);
}
- return &entry->hent_val;
+ return entry;
}
SV *
@@ -207,9 +381,8 @@ U32 klen;
I32 flags;
{
register XPVHV* xhv;
- register char *s;
register I32 i;
- register I32 hash;
+ register U32 hash;
register HE *entry;
register HE **oentry;
SV *sv;
@@ -219,6 +392,9 @@ I32 flags;
if (SvRMAGICAL(hv)) {
sv = *hv_fetch(hv, key, klen, TRUE);
mg_clear(sv);
+ if (mg_find(sv, 's')) {
+ return Nullsv; /* %SIG elements cannot be deleted */
+ }
if (mg_find(sv, 'p')) {
sv_unmagic(sv, 'p'); /* No longer an element */
return sv;
@@ -227,33 +403,92 @@ I32 flags;
xhv = (XPVHV*)SvANY(hv);
if (!xhv->xhv_array)
return Nullsv;
- i = klen;
- hash = 0;
- s = key;
- while (i--)
- hash = hash * 33 + *s++;
+
+ PERL_HASH(hash, key, klen);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
entry = *oentry;
i = 1;
- for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) {
- if (entry->hent_hash != hash) /* strings can't be equal */
+ for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
- if (entry->hent_klen != klen)
+ if (HeKLEN(entry) != klen)
continue;
- if (bcmp(entry->hent_key,key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
- *oentry = entry->hent_next;
+ *oentry = HeNEXT(entry);
if (i && !*oentry)
xhv->xhv_fill--;
if (flags & G_DISCARD)
sv = Nullsv;
else
- sv = sv_mortalcopy(entry->hent_val);
+ sv = sv_mortalcopy(HeVAL(entry));
if (entry == xhv->xhv_eiter)
- entry->hent_klen = -1;
+ HvLAZYDEL_on(hv);
else
- he_free(entry);
+ hv_free_ent(hv, entry);
+ --xhv->xhv_keys;
+ return sv;
+ }
+ return Nullsv;
+}
+
+SV *
+hv_delete_ent(hv,keysv,flags,hash)
+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)) {
+ entry = hv_fetch_ent(hv, keysv, TRUE, hash);
+ sv = HeVAL(entry);
+ mg_clear(sv);
+ if (mg_find(sv, 'p')) {
+ sv_unmagic(sv, 'p'); /* No longer an element */
+ return sv;
+ }
+ }
+ 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;
}
@@ -267,9 +502,7 @@ char *key;
U32 klen;
{
register XPVHV* xhv;
- register char *s;
- register I32 i;
- register I32 hash;
+ register U32 hash;
register HE *entry;
SV *sv;
@@ -289,19 +522,62 @@ U32 klen;
if (!xhv->xhv_array)
return 0;
- i = klen;
- hash = 0;
- s = key;
- while (i--)
- hash = hash * 33 + *s++;
+ 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,keysv,hash)
+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')) {
+ 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);
+ }
+ }
+
+ 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 = entry->hent_next) {
- if (entry->hent_hash != hash) /* strings can't be equal */
+ for (; entry; entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
- if (entry->hent_klen != klen)
+ if (HeKLEN(entry) != klen)
continue;
- if (bcmp(entry->hent_key,key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
return TRUE;
}
@@ -357,16 +633,94 @@ HV *hv;
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 ((HeHASH(entry) & newsize) != i) {
+ *oentry = HeNEXT(entry);
+ HeNEXT(entry) = *b;
if (!*b)
xhv->xhv_fill++;
*b = entry;
continue;
}
else
- oentry = &entry->hent_next;
+ oentry = &HeNEXT(entry);
+ }
+ if (!*a) /* everything moved */
+ xhv->xhv_fill--;
+ }
+}
+
+void
+hv_ksplit(hv, newmax)
+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 HE **a;
+ 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 = (HE**)xhv->xhv_array;
+ if (a) {
+ nomemok = TRUE;
+#ifdef STRANGE_MALLOC
+ Renew(a, newsize, HE*);
+#else
+ i = newsize * sizeof(HE*);
+ j = MALLOC_OVERHEAD;
+ while (j - MALLOC_OVERHEAD < i)
+ j += j;
+ j -= MALLOC_OVERHEAD;
+ j /= sizeof(HE*);
+ assert(j >= newsize);
+ New(2, a, j, HE*);
+ Copy(xhv->xhv_array, a, oldsize, HE*);
+ if (oldsize >= 64 && !nice_chunk) {
+ nice_chunk = (char*)xhv->xhv_array;
+ nice_chunk_size = oldsize * sizeof(HE*) * 2 - MALLOC_OVERHEAD;
+ }
+ else
+ Safefree(xhv->xhv_array);
+#endif
+ nomemok = FALSE;
+ Zero(&a[oldsize], newsize-oldsize, HE*); /* zero 2nd half*/
+ }
+ else {
+ Newz(0, a, newsize, HE*);
+ }
+ xhv->xhv_max = --newsize;
+ xhv->xhv_array = (char*)a;
+ if (!xhv->xhv_fill) /* skip rest if no entries */
+ return;
+
+ for (i=0; i<oldsize; i++,a++) {
+ if (!*a) /* non-existent */
+ continue;
+ for (oentry = a, entry = *a; entry; entry = *oentry) {
+ if ((j = (HeHASH(entry) & newsize)) != i) {
+ j -= i;
+ *oentry = HeNEXT(entry);
+ if (!(HeNEXT(entry) = a[j]))
+ xhv->xhv_fill++;
+ a[j] = entry;
+ continue;
+ }
+ else
+ oentry = &HeNEXT(entry);
}
if (!*a) /* everything moved */
xhv->xhv_fill--;
@@ -384,6 +738,9 @@ newHV()
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;
@@ -392,25 +749,45 @@ newHV()
}
void
-he_free(hent)
-register HE *hent;
+hv_free_ent(hv, entry)
+HV *hv;
+register HE *entry;
{
- if (!hent)
+ if (!entry)
return;
- SvREFCNT_dec(hent->hent_val);
- Safefree(hent->hent_key);
- del_he(hent);
+ if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
+ sub_generation++; /* may be deletion of method from stash */
+ SvREFCNT_dec(HeVAL(entry));
+ 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
-he_delayfree(hent)
-register HE *hent;
+hv_delayfree_ent(hv, entry)
+HV *hv;
+register HE *entry;
{
- if (!hent)
+ if (!entry)
return;
- sv_2mortal(hent->hent_val); /* free between statements */
- Safefree(hent->hent_key);
- del_he(hent);
+ if (isGV(HeVAL(entry)) && GvCVu(HeVAL(entry)) && HvNAME(hv))
+ 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
@@ -436,8 +813,8 @@ hfreeentries(hv)
HV *hv;
{
register HE **array;
- register HE *hent;
- register HE *ohent = Null(HE*);
+ register HE *entry;
+ register HE *oentry = Null(HE*);
I32 riter;
I32 max;
@@ -449,17 +826,17 @@ HV *hv;
riter = 0;
max = HvMAX(hv);
array = HvARRAY(hv);
- hent = array[0];
+ entry = array[0];
for (;;) {
- if (hent) {
- ohent = hent;
- hent = hent->hent_next;
- he_free(ohent);
+ if (entry) {
+ oentry = entry;
+ entry = HeNEXT(entry);
+ hv_free_ent(hv, oentry);
}
- if (!hent) {
+ if (!entry) {
if (++riter > max)
break;
- hent = array[riter];
+ entry = array[riter];
}
}
(void)hv_iterinit(hv);
@@ -480,7 +857,7 @@ HV *hv;
HvNAME(hv) = 0;
}
xhv->xhv_array = 0;
- xhv->xhv_max = 7; /* it's a normal associative array */
+ xhv->xhv_max = 7; /* it's a normal hash */
xhv->xhv_fill = 0;
xhv->xhv_keys = 0;
@@ -492,13 +869,24 @@ I32
hv_iterinit(hv)
HV *hv;
{
- register XPVHV* xhv = (XPVHV*)SvANY(hv);
- HE *entry = xhv->xhv_eiter;
- if (entry && entry->hent_klen < 0) /* was deleted earlier? */
- he_free(entry);
+ 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_fill;
+ return xhv->xhv_fill; /* should be xhv->xhv_keys? May change later */
}
HE *
@@ -511,31 +899,36 @@ HV *hv;
MAGIC* mg;
if (!hv)
- croak("Bad associative array");
+ 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_usepvn(key, entry->hent_key, entry->hent_klen);
- entry->hent_key = 0;
+ sv_setsv(key, HeSVKEY_force(entry));
+ SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
}
else {
- xhv->xhv_eiter = entry = new_he();
+ 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)) {
- STRLEN len;
- entry->hent_key = SvPV_force(key, len);
- entry->hent_klen = len;
- SvPOK_off(key);
- SvPVX(key) = 0;
- return entry;
+ /* force key to stay around until next time */
+ HeSVKEY_set(entry, SvREFCNT_inc(key));
+ return entry; /* beware, hent_val is not set */
}
- if (entry->hent_val)
- SvREFCNT_dec(entry->hent_val);
+ if (HeVAL(entry))
+ SvREFCNT_dec(HeVAL(entry));
+ Safefree(HeKEY_hek(entry));
del_he(entry);
xhv->xhv_eiter = Null(HE*);
return Null(HE*);
@@ -543,21 +936,21 @@ HV *hv;
if (!xhv->xhv_array)
Newz(506,xhv->xhv_array, sizeof(HE*) * (xhv->xhv_max + 1), char);
- do {
- if (entry)
- entry = entry->hent_next;
- if (!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 (entry)
+ entry = HeNEXT(entry);
+ while (!entry) {
+ ++xhv->xhv_riter;
+ if (xhv->xhv_riter > xhv->xhv_max) {
+ xhv->xhv_riter = -1;
+ break;
}
- } while (!entry);
+ entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
+ }
- if (oldentry && oldentry->hent_klen < 0) /* was deleted earlier? */
- he_free(oldentry);
+ if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
+ HvLAZYDEL_off(hv);
+ hv_free_ent(hv, oldentry);
+ }
xhv->xhv_eiter = entry;
return entry;
@@ -568,8 +961,28 @@ hv_iterkey(entry,retlen)
register HE *entry;
I32 *retlen;
{
- *retlen = entry->hent_klen;
- return entry->hent_key;
+ 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(entry)
+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 *
@@ -580,11 +993,13 @@ register HE *entry;
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv,'P')) {
SV* sv = sv_newmortal();
- mg_copy((SV*)hv, sv, entry->hent_key, entry->hent_klen);
+ 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 entry->hent_val;
+ return HeVAL(entry);
}
SV *
@@ -608,3 +1023,112 @@ int how;
{
sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
}
+
+char*
+sharepvn(sv, len, hash)
+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(str, len, hash)
+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(strtab, tmpsv, FALSE, hash))) {
+ if (--*Svp == Nullsv)
+ hv_delete(strtab, str, len, G_DISCARD, hash);
+ } */
+ xhv = (XPVHV*)SvANY(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(str, len, hash)
+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(strtab, str, len, FALSE)))
+ hv_store(strtab, str, len, Nullsv, hash);
+ */
+ xhv = (XPVHV*)SvANY(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(strtab);
+ }
+ }
+
+ ++HeVAL(entry); /* use value slot as REFCNT */
+ return HeKEY_hek(entry);
+}
+
+
diff --git a/gnu/usr.bin/perl/hv.h b/gnu/usr.bin/perl/hv.h
index 49703632b86..20af4eab578 100644
--- a/gnu/usr.bin/perl/hv.h
+++ b/gnu/usr.bin/perl/hv.h
@@ -1,6 +1,6 @@
/* hv.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -8,13 +8,18 @@
*/
typedef struct he HE;
+typedef struct hek HEK;
struct he {
HE *hent_next;
- char *hent_key;
+ HEK *hent_hek;
SV *hent_val;
- U32 hent_hash;
- I32 hent_klen;
+};
+
+struct hek {
+ U32 hek_hash;
+ I32 hek_len;
+ char hek_key[1];
};
struct xpvhv {
@@ -32,6 +37,21 @@ struct xpvhv {
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
@@ -42,6 +62,14 @@ struct xpvhv {
#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: */
@@ -58,3 +86,34 @@ struct xpvhv {
*/
#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)))) : \
+ &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/gnu/usr.bin/perl/installhtml b/gnu/usr.bin/perl/installhtml
new file mode 100644
index 00000000000..b677cc29dbc
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/installman b/gnu/usr.bin/perl/installman
index 38bd0af10e8..4d74bcfea22 100644
--- a/gnu/usr.bin/perl/installman
+++ b/gnu/usr.bin/perl/installman
@@ -56,36 +56,69 @@ 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 {
- my($poddir, $mandir, $manext) = @_;
+ # $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 $poddir man pages.\n";
+ 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 "../pod/pod2man" || die "Executable pod/pod2man not found.\n";
+ -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 = "../perl -I ../lib ../pod/pod2man --section=$manext --official";
+ $pod2man = "$downdir/perl -I $downdir/lib $downdir/pod/pod2man --section=$manext --official";
- mkpath($mandir, 1, 0777); # In File::Path
+ 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.
- @modpods = ();
- find(\&lsmodpods, '.');
+ if ($script) {
+ @modpods = ($script);
+ } else {
+ @modpods = ();
+ find(\&lsmodpods, '.');
+ }
foreach $mod (@modpods) {
$manpage = $mod;
my $tmp;
@@ -96,7 +129,7 @@ sub runpod2man {
# Convert name from File/Basename.pm to File::Basename.3 format,
# if necessary.
$manpage =~ s#\.p(m|od)$##;
- if ($^O eq 'os2') {
+ if ($^O eq 'os2' || $^O eq 'amigaos') {
$manpage =~ s#/#.#g;
} else {
$manpage =~ s#/#::#g;
@@ -111,6 +144,7 @@ sub runpod2man {
}
}
chdir "$builddir" || die "Unable to cd back to $builddir directory!\n$!\n";
+ print STDERR "chdir $builddir\n";
}
sub lsmodpods {
@@ -154,7 +188,7 @@ 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 $nonono;
+ or warn "Couldn't unlink $name: $!\n" ) unless $notify;
}
return $cnt;
}
diff --git a/gnu/usr.bin/perl/installperl b/gnu/usr.bin/perl/installperl
index 60eb69b081c..1aea39e7e92 100644
--- a/gnu/usr.bin/perl/installperl
+++ b/gnu/usr.bin/perl/installperl
@@ -1,14 +1,26 @@
#!./perl
-# $OpenBSD: installperl,v 1.5 1997/07/24 21:12:15 kstailey Exp $
+# $OpenBSD: installperl,v 1.6 1997/07/24 21:18:44 kstailey Exp $
#
# This is hacked up, in order to support DESTDIR and INSTALL_STRIP.
#
-BEGIN { @INC=('./lib', '../lib') }
+BEGIN {
+ require 5.004;
+ @INC = 'lib';
+ $ENV{PERL5LIB} = 'lib';
+}
+
use File::Find;
-use File::Path qw(mkpath);
+use File::Compare;
+use File::Copy ();
+use File::Path ();
use Config;
-use subs qw(unlink rename link chmod);
+use subs qw(unlink link chmod cmd);
+
+# override the ones in the rest of the script
+sub mkpath {
+ File::Path::mkpath(@_) unless $nonono;
+}
$mainperldir = "/usr/bin";
$exe_ext = $Config{exe_ext};
@@ -21,18 +33,21 @@ while (@ARGV) {
umask 022;
-@scripts = qw(cppstdin
- utils/c2ph utils/h2ph utils/h2xs utils/pstruct
- utils/perlbug utils/perldoc
+@scripts = qw( utils/c2ph utils/h2ph utils/h2xs
+ utils/perlbug utils/perldoc utils/pl2pm utils/splain
x2p/s2p x2p/find2perl
pod/pod2man pod/pod2html pod/pod2latex pod/pod2text);
-# pod documentation now handled by separate installman script.
-# These two are archaic leftovers.
-#@manpages = qw(x2p/a2p.man x2p/s2p.man);
-
@pods = (<pod/*.pod>);
+%archpms = (Config => 1, FileHandle => 1, overload => 1);
+find(sub {
+ if ("$File::Find::dir/$_" =~ m{^ext/[^/]+/(.*)\.pm$}) {
+ (my $pm = $1) =~ s{^lib/}{};
+ $archpms{$pm} = 1;
+ }
+ }, 'ext');
+
$ver = $];
$release = substr($ver,0,3); # Not used presently.
$patchlevel = substr($ver,3,2);
@@ -41,9 +56,9 @@ die "Patchlevel of perl ($patchlevel)",
if $patchlevel != $Config{'PATCHLEVEL'};
$installdest = $ENV{"DESTDIR"};
+$installdest =~ s:/+$::;
if ($installdest ne '') {
- # Fetch some frequently-used items from %Config, prefixing them with
- # DESTDIR.
+ # Fetch some frequently-used items from %Config, prefixing with DESTDIR.
$installbin = "$installdest/$Config{installbin}";
$installscript = "$installdest/$Config{installscript}";
$installprivlib = "$installdest/$Config{installprivlib}";
@@ -54,18 +69,18 @@ if ($installdest ne '') {
# Also whack $mainperldir.
$mainperldir = "$installdest/$mainperldir";
} else {
- # Fetch some frequently-used items from %Config.
+ # Fetch some frequently-used items from %Config
$installbin = $Config{installbin};
$installscript = $Config{installscript};
$installprivlib = $Config{installprivlib};
$installarchlib = $Config{installarchlib};
$installsitelib = $Config{installsitelib};
$installsitearch = $Config{installsitearch};
+ $installman1dir = $Config{installman1dir};
}
+
$man1ext = $Config{man1ext};
-# Did we build libperl as a shared library?
-$d_shrplib = $Config{d_shrplib};
-$shrpdir = $Config{shrpdir};
+$libperl = $Config{libperl};
# Shared library and dynamic loading suffixes.
$so = $Config{so};
$dlext = $Config{dlext};
@@ -79,8 +94,8 @@ 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 || die "$installbin is not a directory\n";
--w $installbin || die "$installbin is not writable by you\n"
+-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";
@@ -89,91 +104,28 @@ if ($d_dosuid && $>) { die "You must run as root to install suidperl\n"; }
-x 't/TEST' || warn "WARNING: You've never run 'make test'!!!",
" (Installing anyway.)\n";
-if ($d_shrplib) {
- if (!<libperl*.$so*>) {
- warn "WARNING: Can't find libperl*.$so* to install into $shrpdir.",
- " (Installing other things anyway.)\n";
- } else {
- mkpath($shrpdir, 1, 0777);
- -w $shrpdir || $nonono || die "$shrpdir is not writable by you\n";
- &cmd("cp libperl*.$so* $shrpdir");
- }
-}
-
# First we install the version-numbered executables.
-$installcmd = $ENV{"INSTALL"}
+if (defined($ENV{"INSTALL"})) {
+ $installcmd = $ENV{"INSTALL"}
. " " . $ENV{"INSTALL_COPY"}
. " " . $ENV{"INSTALL_STRIP"};
-
-&safe_unlink("$installbin/perl$ver$exe_ext");
-&cmd("$installcmd perl$exe_ext $installbin/perl$ver$exe_ext");
-
-&safe_unlink("$installbin/sperl$ver$exe_ext");
-if ($d_dosuid) {
- &cmd("cp suidperl$exe_ext $installbin/sperl$ver$exe_ext");
- &chmod(04711, "$installbin/sperl$ver$exe_ext");
-}
-
-exit 0 if $versiononly;
-
-# Make links to ordinary names if installbin directory isn't current directory.
-
-if (! &samepath($installbin, '.')) {
- &safe_unlink("$installbin/perl$exe_ext", "$installbin/suidperl$exe_ext");
- &link("$installbin/perl$ver$exe_ext", "$installbin/perl$exe_ext");
- &link("$installbin/sperl$ver$exe_ext", "$installbin/suidperl$exe_ext")
- if $d_dosuid;
-}
-
-if (! &samepath($installbin, 'x2p')) {
- &safe_unlink("$installbin/a2p$exe_ext");
- &cmd("$installcmd x2p/a2p$exe_ext $installbin");
- &chmod(0755, "$installbin/a2p$exe_ext");
+} else {
+ $installcmd = "cp";
}
-# Install scripts.
-
-mkpath($installscript, 1, 0777);
+safe_unlink("$installbin/perl$ver$exe_ext");
+cmd("$installcmd perl$exe_ext $installbin/perl$ver$exe_ext");
+#copy("perl$exe_ext", "$installbin/perl$ver$exe_ext");
+chmod(0755, "$installbin/perl$ver$exe_ext");
-for (@scripts) {
- if (-f $_) { # cppstdin might not exist on this system.
- &cmd("cp $_ $installscript");
- s#.*/##; &chmod(0755, "$installscript/$_");
- }
-}
-
-# Install pod pages. Where? I guess in $installprivlib/pod.
-mkpath("${installprivlib}/pod", 1, 0777);
-foreach $file (@pods) {
- # $file is a name like pod/perl.pod
- cp_if_diff($file, "${installprivlib}/${file}");
+safe_unlink("$installbin/sperl$ver$exe_ext");
+if ($d_dosuid) {
+ cmd("$installcmd suidperl$exe_ext $installbin/sperl$ver$exe_ext");
+ #copy("suidperl$exe_ext", "$installbin/sperl$ver$exe_ext");
+ chmod(04711, "$installbin/sperl$ver$exe_ext");
}
-# Install old man pages.
-
-#if ($installman1dir ne '') {
-# mkpath($installman1dir, 1, 0777);
-#
-# if (! &samepath($installman1dir, '.')) {
-# for (@manpages) {
-# ($new = $_) =~ s/man$/$man1ext/;
-# $new =~ s#.*/##;
-# print STDERR " Installing $installman1dir/$new\n";
-# next if $nonono;
-# open(MI,$_) || warn "Can't open $_: $!\n";
-# open(MO,">$installman1dir/$new") ||
-# warn "Can't install $installman1dir/$new: $!\n";
-# print MO ".ds RP Release $release Patchlevel $patchlevel\n";
-# while (<MI>) {
-# print MO;
-# }
-# close MI;
-# close MO;
-# }
-# }
-#}
-
# Install library files.
$do_installarchlib = $do_installprivlib = 0;
@@ -184,8 +136,9 @@ mkpath($installsitelib, 1, 0777) if ($installsitelib);
mkpath($installsitearch, 1, 0777) if ($installsitearch);
if (chdir "lib") {
- $do_installarchlib = ! &samepath($installarchlib, '.');
- $do_installprivlib = ! &samepath($installprivlib, '.');
+ $do_installarchlib = ! samepath($installarchlib, '.');
+ $do_installprivlib = ! samepath($installprivlib, '.');
+ $do_installprivlib = 0 if $versiononly && !($installprivlib =~ m/\Q$]/);
if ($do_installarchlib || $do_installprivlib) {
find(\&installlib, '.');
@@ -198,73 +151,163 @@ else {
# Install header files and libraries.
mkpath("$installarchlib/CORE", 1, 0777);
-foreach $file (<*.h libperl*.*>) {
- cp_if_diff($file,"$installarchlib/CORE/$file");
- &chmod(0444,"$installarchlib/CORE/$file");
-}
+@corefiles = <*.h libperl*.*>;
# AIX needs perl.exp installed as well.
-cp_if_diff("perl.exp" ,"$installarchlib/CORE/perl.exp") if ($^O eq 'aix');
-
+push(@corefiles,'perl.exp') if $^O eq 'aix';
# If they have built sperl.o...
-cp_if_diff("sperl.o" ,"$installarchlib/CORE/sperl.o") if (-f 'sperl.o');
-
+push(@corefiles,'sperl.o') if -f 'sperl.o';
+foreach $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");
+}
# Offer to install perl in a "standard" location
$mainperl_is_instperl = 0;
-if (-w $mainperldir && ! &samepath($mainperldir, $installbin) && !$nonono) {
- # First make sure $mainperldir/perl is not already the same as
- # the perl we just installed
- if (-x "$mainperldir/perl$exe_ext") {
+if (!$versiononly && !$nonono && -t STDIN && -t STDERR
+ && -w $mainperldir && ! samepath($mainperldir, $installbin)) {
+ local($usrbinperl) = "$mainperldir/perl$exe_ext";
+ local($instperl) = "$installbin/perl$exe_ext";
+ local($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("$mainperldir/perl$exe_ext", "$installbin/perl$exe_ext") ||
+ samepath($usrbinperl, $instperl) ||
+ samepath($usrbinperl, $expinstperl) ||
(($binexp ne $installbin) &&
- (-l "$mainperldir/perl$exe_ext") &&
- ((readlink "$mainperldir/perl$exe_ext") eq "$binexp/perl$exe_ext"));
+ (-l $usrbinperl) &&
+ ((readlink $usrbinperl) eq $expinstperl));
}
if ((! $mainperl_is_instperl) &&
- (&yn("Many scripts expect perl to be installed as " .
- "$mainperldir/perl.\n" .
- "Do you wish to have $mainperldir/perl be the same as\n" .
- "$binexp/perl? [y] ")))
+ (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("$mainperldir/perl$exe_ext");
- eval 'link("$installbin/perl$exe_ext", "$mainperldir/perl$exe_ext")' ||
- eval 'symlink("$binexp/perl$exe_ext", "$mainperldir/perl$exe_ext")' ||
- &cmd("cp $installbin/perl$exe_ext $mainperldir$exe_ext");
+ unlink($usrbinperl);
+ 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, '.')) {
+ safe_unlink("$installbin/perl$exe_ext", "$installbin/suidperl$exe_ext");
+ link("$installbin/perl$ver$exe_ext", "$installbin/perl$exe_ext");
+ link("$installbin/sperl$ver$exe_ext", "$installbin/suidperl$exe_ext")
+ if $d_dosuid;
+}
+
+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");
+ link("$installscript/c2ph","$installscript/pstruct");
+}
+
+# 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 $file (@pods) {
+ # $file is a name like pod/perl.pod
+ copy_if_diff($file, "${installprivlib}/${file}");
+ }
+
+ # Link perldiag.pod into archlib
+ my ($from, $to) = ("${installprivlib}/pod/perldiag.pod",
+ "${installarchlib}/pod/perldiag.pod");
+ if (compare($from, $to) || $nonono) {
+ mkpath("${installarchlib}/pod", 1, 0777);
+ unlink($to);
+ link($from, $to);
+ }
+}
+
# 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.
-$dirsep = ($^O eq 'os2') ? ';' : ':' ;
-($path = $ENV{"PATH"}) =~ s:\\:/:g ;
-@path = split(/$dirsep/, $path);
-@otherperls = ();
-for (@path) {
- next unless m,^/,;
- next if ($_ eq $binexp);
- # Use &samepath here because some systems have other dirs linked
- # to $mainperldir (like SunOS)
- 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";
+if (!$versiononly) {
+
+ $dirsep = ($^O eq 'os2') ? ';' : ':' ;
+ ($path = $ENV{"PATH"}) =~ s:\\:/:g ;
+ @path = split(/$dirsep/, $path);
+ @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";
}
- print STDERR "\n";
+
}
print STDERR " Installation complete\n";
@@ -298,37 +341,28 @@ sub unlink {
}
sub safe_unlink {
- local(@names) = @_;
-
+ return if $nonono;
+ local @names = @_;
foreach $name (@names) {
next unless -e $name;
- next if $nonono;
chmod 0777, $name if $^O eq 'os2';
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";
- &rename($name, "$name.old") || warn "Couldn't rename $name: $!\n";
+ safe_rename($name, "$name.old")
+ or warn "Couldn't rename $name: $!\n";
}
}
}
-sub cmd {
- local($cmd) = @_;
- print STDERR " $cmd\n";
- unless ($nonono) {
- system $cmd;
- warn "Command failed!!!\n" if $?;
- }
-}
-
-sub rename {
+sub safe_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");
+ last if rename($to, "$to.$i");
}
warn("Cannot rename to `$to.$i': $!"), return 0
if $i >= 50; # Give up!
@@ -338,15 +372,33 @@ sub rename {
}
sub link {
- local($from,$to) = @_;
+ my($from,$to) = @_;
+ my($success) = 0;
print STDERR " ln $from $to\n";
eval {
- CORE::link($from,$to) || warn "Couldn't link $from to $to: $!\n" unless $nonono;
+ 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;
};
if ($@) {
- system( $cp, $from, $to )
- && warn "Couldn't copy $from to $to: $!\n" unless $nonono;
+ File::Copy::copy($from, $to)
+ ? $success++
+ : warn "Couldn't copy $from to $to: $!\n"
+ unless $nonono;
+ }
+ $success;
+}
+
+sub cmd {
+ my($cmd) = @_;
+ print STDERR " $cmd\n";
+ unless ($nonono) {
+ system $cmd;
+ warn "Command failed!!!\n" if $?;
}
}
@@ -354,8 +406,18 @@ 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 $nonono;
+ 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";
+ File::Copy::copy($from, $to)
+ || warn "Couldn't copy $from to $to: $!\n"
+ unless $nonono;
}
sub samepath {
@@ -375,8 +437,14 @@ sub samepath {
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};
@@ -384,7 +452,8 @@ sub installlib {
$name = "$dir/$name" if $dir ne '';
my $installlib = $installprivlib;
- if ((substr($dir, 0, 4) eq 'auto') || ($name eq 'Config.pm')) {
+ if ($dir =~ /^auto/ ||
+ ($name =~ /^(.*)\.(?:pm|pod)$/ && $archpms{$1})) {
$installlib = $installarchlib;
return unless $do_installarchlib;
} else {
@@ -392,27 +461,22 @@ sub installlib {
}
if (-f $_) {
- if (/\.al$/ || /\.ix$/) {
+ 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");
+ unlink("$installarchlib/$name");
}
- system "cmp", "-s", $_, "$installlib/$name";
- if ($?) {
- &unlink("$installlib/$name");
+ if (compare($_, "$installlib/$name") || $nonono) {
+ unlink("$installlib/$name");
mkpath("$installlib/$dir", 1, 0777);
- cp_if_diff($_, "$installlib/$name");
# HP-UX (at least) needs to maintain execute permissions
# on dynamically-loaded libraries.
- if ($name =~ /\.(so|$dlext)$/o) {
- &chmod(0555, "$installlib/$name");
- }
- else {
- &chmod(0444, "$installlib/$name");
- }
+ copy_if_diff($_, "$installlib/$name")
+ and chmod($name =~ /\.(so|$dlext)$/o ? 0555 : 0444,
+ "$installlib/$name");
}
} elsif (-d $_) {
mkpath("$installlib/$name", 1, 0777);
@@ -427,18 +491,22 @@ sub installlib {
# 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.
-sub cp_if_diff {
+# Return true if copying occurred.
+
+sub copy_if_diff {
my($from,$to)=@_;
-f $from || die "$0: $from not found";
- system "cmp", "-s", $from, $to;
- if ($?) {
- my ($atime, $mtime);
- unlink($to); # In case we don't have write permissions.
- cmd("cp $from $to");
- # Restore timestamps if it's a .a library.
- if ($to =~ /\.a$/) {
- ($atime, $mtime) = (stat $from)[8,9];
+ 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 && ($^O eq 'os2' || $to =~ /\.a$/)) {
+ my ($atime, $mtime) = (stat $from)[8,9];
utime $atime, $mtime, $to;
}
+ 1;
}
}
diff --git a/gnu/usr.bin/perl/interp.sym b/gnu/usr.bin/perl/interp.sym
index 801eb41fd9a..753f53dc45c 100644
--- a/gnu/usr.bin/perl/interp.sym
+++ b/gnu/usr.bin/perl/interp.sym
@@ -18,8 +18,10 @@ chopset
copline
curblock
curcop
+curcopdb
curcsv
curpm
+curstack
curstash
curstname
cxstack
@@ -29,7 +31,6 @@ dbargs
debdelim
debname
debstash
-debug
defgv
defoutgv
defstash
@@ -38,7 +39,6 @@ diehook
dirty
dlevel
dlmax
-do_undump
doextract
doswitches
dowarn
@@ -71,12 +71,14 @@ laststype
leftgv
lineary
localizing
+localpatches
main_cv
main_root
main_start
mainstack
maxscream
maxsysfd
+mess_sv
minus_F
minus_a
minus_c
@@ -101,13 +103,10 @@ origargv
origfilename
ors
orslen
-pad
-padname
parsehook
patchlevel
perldb
perl_destruct_level
-pidstatus
preambled
preambleav
preprocess
@@ -116,7 +115,6 @@ rightgv
rs
runlevel
sawampersand
-sawi
sawstudy
sawvec
screamfirst
@@ -128,13 +126,15 @@ sortcop
sortstack
sortstash
splitstr
-stack
+start_env
statcache
statgv
statname
statusvalue
+statusvalue_vms
stdingv
strchop
+strtab
sv_count
sv_objcount
sv_root
diff --git a/gnu/usr.bin/perl/keywords.h b/gnu/usr.bin/perl/keywords.h
index 8cb2748d75b..2be133b7480 100644
--- a/gnu/usr.bin/perl/keywords.h
+++ b/gnu/usr.bin/perl/keywords.h
@@ -1,245 +1,247 @@
#define KEY_NULL 0
-#define KEY___LINE__ 1
-#define KEY___FILE__ 2
-#define KEY___DATA__ 3
-#define KEY___END__ 4
-#define KEY_AUTOLOAD 5
-#define KEY_BEGIN 6
-#define KEY_CORE 7
-#define KEY_DESTROY 8
-#define KEY_END 9
-#define KEY_EQ 10
-#define KEY_GE 11
-#define KEY_GT 12
-#define KEY_LE 13
-#define KEY_LT 14
-#define KEY_NE 15
-#define KEY_abs 16
-#define KEY_accept 17
-#define KEY_alarm 18
-#define KEY_and 19
-#define KEY_atan2 20
-#define KEY_bind 21
-#define KEY_binmode 22
-#define KEY_bless 23
-#define KEY_caller 24
-#define KEY_chdir 25
-#define KEY_chmod 26
-#define KEY_chomp 27
-#define KEY_chop 28
-#define KEY_chown 29
-#define KEY_chr 30
-#define KEY_chroot 31
-#define KEY_close 32
-#define KEY_closedir 33
-#define KEY_cmp 34
-#define KEY_connect 35
-#define KEY_continue 36
-#define KEY_cos 37
-#define KEY_crypt 38
-#define KEY_dbmclose 39
-#define KEY_dbmopen 40
-#define KEY_defined 41
-#define KEY_delete 42
-#define KEY_die 43
-#define KEY_do 44
-#define KEY_dump 45
-#define KEY_each 46
-#define KEY_else 47
-#define KEY_elsif 48
-#define KEY_endgrent 49
-#define KEY_endhostent 50
-#define KEY_endnetent 51
-#define KEY_endprotoent 52
-#define KEY_endpwent 53
-#define KEY_endservent 54
-#define KEY_eof 55
-#define KEY_eq 56
-#define KEY_eval 57
-#define KEY_exec 58
-#define KEY_exists 59
-#define KEY_exit 60
-#define KEY_exp 61
-#define KEY_fcntl 62
-#define KEY_fileno 63
-#define KEY_flock 64
-#define KEY_for 65
-#define KEY_foreach 66
-#define KEY_fork 67
-#define KEY_format 68
-#define KEY_formline 69
-#define KEY_ge 70
-#define KEY_getc 71
-#define KEY_getgrent 72
-#define KEY_getgrgid 73
-#define KEY_getgrnam 74
-#define KEY_gethostbyaddr 75
-#define KEY_gethostbyname 76
-#define KEY_gethostent 77
-#define KEY_getlogin 78
-#define KEY_getnetbyaddr 79
-#define KEY_getnetbyname 80
-#define KEY_getnetent 81
-#define KEY_getpeername 82
-#define KEY_getpgrp 83
-#define KEY_getppid 84
-#define KEY_getpriority 85
-#define KEY_getprotobyname 86
-#define KEY_getprotobynumber 87
-#define KEY_getprotoent 88
-#define KEY_getpwent 89
-#define KEY_getpwnam 90
-#define KEY_getpwuid 91
-#define KEY_getservbyname 92
-#define KEY_getservbyport 93
-#define KEY_getservent 94
-#define KEY_getsockname 95
-#define KEY_getsockopt 96
-#define KEY_glob 97
-#define KEY_gmtime 98
-#define KEY_goto 99
-#define KEY_grep 100
-#define KEY_gt 101
-#define KEY_hex 102
-#define KEY_if 103
-#define KEY_index 104
-#define KEY_int 105
-#define KEY_ioctl 106
-#define KEY_join 107
-#define KEY_keys 108
-#define KEY_kill 109
-#define KEY_last 110
-#define KEY_lc 111
-#define KEY_lcfirst 112
-#define KEY_le 113
-#define KEY_length 114
-#define KEY_link 115
-#define KEY_listen 116
-#define KEY_local 117
-#define KEY_localtime 118
-#define KEY_log 119
-#define KEY_lstat 120
-#define KEY_lt 121
-#define KEY_m 122
-#define KEY_map 123
-#define KEY_mkdir 124
-#define KEY_msgctl 125
-#define KEY_msgget 126
-#define KEY_msgrcv 127
-#define KEY_msgsnd 128
-#define KEY_my 129
-#define KEY_ne 130
-#define KEY_next 131
-#define KEY_no 132
-#define KEY_not 133
-#define KEY_oct 134
-#define KEY_open 135
-#define KEY_opendir 136
-#define KEY_or 137
-#define KEY_ord 138
-#define KEY_pack 139
-#define KEY_package 140
-#define KEY_pipe 141
-#define KEY_pop 142
-#define KEY_pos 143
-#define KEY_print 144
-#define KEY_printf 145
-#define KEY_prototype 146
-#define KEY_push 147
-#define KEY_q 148
-#define KEY_qq 149
-#define KEY_quotemeta 150
-#define KEY_qw 151
-#define KEY_qx 152
-#define KEY_rand 153
-#define KEY_read 154
-#define KEY_readdir 155
-#define KEY_readline 156
-#define KEY_readlink 157
-#define KEY_readpipe 158
-#define KEY_recv 159
-#define KEY_redo 160
-#define KEY_ref 161
-#define KEY_rename 162
-#define KEY_require 163
-#define KEY_reset 164
-#define KEY_return 165
-#define KEY_reverse 166
-#define KEY_rewinddir 167
-#define KEY_rindex 168
-#define KEY_rmdir 169
-#define KEY_s 170
-#define KEY_scalar 171
-#define KEY_seek 172
-#define KEY_seekdir 173
-#define KEY_select 174
-#define KEY_semctl 175
-#define KEY_semget 176
-#define KEY_semop 177
-#define KEY_send 178
-#define KEY_setgrent 179
-#define KEY_sethostent 180
-#define KEY_setnetent 181
-#define KEY_setpgrp 182
-#define KEY_setpriority 183
-#define KEY_setprotoent 184
-#define KEY_setpwent 185
-#define KEY_setservent 186
-#define KEY_setsockopt 187
-#define KEY_shift 188
-#define KEY_shmctl 189
-#define KEY_shmget 190
-#define KEY_shmread 191
-#define KEY_shmwrite 192
-#define KEY_shutdown 193
-#define KEY_sin 194
-#define KEY_sleep 195
-#define KEY_socket 196
-#define KEY_socketpair 197
-#define KEY_sort 198
-#define KEY_splice 199
-#define KEY_split 200
-#define KEY_sprintf 201
-#define KEY_sqrt 202
-#define KEY_srand 203
-#define KEY_stat 204
-#define KEY_study 205
-#define KEY_sub 206
-#define KEY_substr 207
-#define KEY_symlink 208
-#define KEY_syscall 209
-#define KEY_sysopen 210
-#define KEY_sysread 211
-#define KEY_system 212
-#define KEY_syswrite 213
-#define KEY_tell 214
-#define KEY_telldir 215
-#define KEY_tie 216
-#define KEY_tied 217
-#define KEY_time 218
-#define KEY_times 219
-#define KEY_tr 220
-#define KEY_truncate 221
-#define KEY_uc 222
-#define KEY_ucfirst 223
-#define KEY_umask 224
-#define KEY_undef 225
-#define KEY_unless 226
-#define KEY_unlink 227
-#define KEY_unpack 228
-#define KEY_unshift 229
-#define KEY_untie 230
-#define KEY_until 231
-#define KEY_use 232
-#define KEY_utime 233
-#define KEY_values 234
-#define KEY_vec 235
-#define KEY_wait 236
-#define KEY_waitpid 237
-#define KEY_wantarray 238
-#define KEY_warn 239
-#define KEY_while 240
-#define KEY_write 241
-#define KEY_x 242
-#define KEY_xor 243
-#define KEY_y 244
+#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_LE 14
+#define KEY_LT 15
+#define KEY_NE 16
+#define KEY_abs 17
+#define KEY_accept 18
+#define KEY_alarm 19
+#define KEY_and 20
+#define KEY_atan2 21
+#define KEY_bind 22
+#define KEY_binmode 23
+#define KEY_bless 24
+#define KEY_caller 25
+#define KEY_chdir 26
+#define KEY_chmod 27
+#define KEY_chomp 28
+#define KEY_chop 29
+#define KEY_chown 30
+#define KEY_chr 31
+#define KEY_chroot 32
+#define KEY_close 33
+#define KEY_closedir 34
+#define KEY_cmp 35
+#define KEY_connect 36
+#define KEY_continue 37
+#define KEY_cos 38
+#define KEY_crypt 39
+#define KEY_dbmclose 40
+#define KEY_dbmopen 41
+#define KEY_defined 42
+#define KEY_delete 43
+#define KEY_die 44
+#define KEY_do 45
+#define KEY_dump 46
+#define KEY_each 47
+#define KEY_else 48
+#define KEY_elsif 49
+#define KEY_endgrent 50
+#define KEY_endhostent 51
+#define KEY_endnetent 52
+#define KEY_endprotoent 53
+#define KEY_endpwent 54
+#define KEY_endservent 55
+#define KEY_eof 56
+#define KEY_eq 57
+#define KEY_eval 58
+#define KEY_exec 59
+#define KEY_exists 60
+#define KEY_exit 61
+#define KEY_exp 62
+#define KEY_fcntl 63
+#define KEY_fileno 64
+#define KEY_flock 65
+#define KEY_for 66
+#define KEY_foreach 67
+#define KEY_fork 68
+#define KEY_format 69
+#define KEY_formline 70
+#define KEY_ge 71
+#define KEY_getc 72
+#define KEY_getgrent 73
+#define KEY_getgrgid 74
+#define KEY_getgrnam 75
+#define KEY_gethostbyaddr 76
+#define KEY_gethostbyname 77
+#define KEY_gethostent 78
+#define KEY_getlogin 79
+#define KEY_getnetbyaddr 80
+#define KEY_getnetbyname 81
+#define KEY_getnetent 82
+#define KEY_getpeername 83
+#define KEY_getpgrp 84
+#define KEY_getppid 85
+#define KEY_getpriority 86
+#define KEY_getprotobyname 87
+#define KEY_getprotobynumber 88
+#define KEY_getprotoent 89
+#define KEY_getpwent 90
+#define KEY_getpwnam 91
+#define KEY_getpwuid 92
+#define KEY_getservbyname 93
+#define KEY_getservbyport 94
+#define KEY_getservent 95
+#define KEY_getsockname 96
+#define KEY_getsockopt 97
+#define KEY_glob 98
+#define KEY_gmtime 99
+#define KEY_goto 100
+#define KEY_grep 101
+#define KEY_gt 102
+#define KEY_hex 103
+#define KEY_if 104
+#define KEY_index 105
+#define KEY_int 106
+#define KEY_ioctl 107
+#define KEY_join 108
+#define KEY_keys 109
+#define KEY_kill 110
+#define KEY_last 111
+#define KEY_lc 112
+#define KEY_lcfirst 113
+#define KEY_le 114
+#define KEY_length 115
+#define KEY_link 116
+#define KEY_listen 117
+#define KEY_local 118
+#define KEY_localtime 119
+#define KEY_log 120
+#define KEY_lstat 121
+#define KEY_lt 122
+#define KEY_m 123
+#define KEY_map 124
+#define KEY_mkdir 125
+#define KEY_msgctl 126
+#define KEY_msgget 127
+#define KEY_msgrcv 128
+#define KEY_msgsnd 129
+#define KEY_my 130
+#define KEY_ne 131
+#define KEY_next 132
+#define KEY_no 133
+#define KEY_not 134
+#define KEY_oct 135
+#define KEY_open 136
+#define KEY_opendir 137
+#define KEY_or 138
+#define KEY_ord 139
+#define KEY_pack 140
+#define KEY_package 141
+#define KEY_pipe 142
+#define KEY_pop 143
+#define KEY_pos 144
+#define KEY_print 145
+#define KEY_printf 146
+#define KEY_prototype 147
+#define KEY_push 148
+#define KEY_q 149
+#define KEY_qq 150
+#define KEY_quotemeta 151
+#define KEY_qw 152
+#define KEY_qx 153
+#define KEY_rand 154
+#define KEY_read 155
+#define KEY_readdir 156
+#define KEY_readline 157
+#define KEY_readlink 158
+#define KEY_readpipe 159
+#define KEY_recv 160
+#define KEY_redo 161
+#define KEY_ref 162
+#define KEY_rename 163
+#define KEY_require 164
+#define KEY_reset 165
+#define KEY_return 166
+#define KEY_reverse 167
+#define KEY_rewinddir 168
+#define KEY_rindex 169
+#define KEY_rmdir 170
+#define KEY_s 171
+#define KEY_scalar 172
+#define KEY_seek 173
+#define KEY_seekdir 174
+#define KEY_select 175
+#define KEY_semctl 176
+#define KEY_semget 177
+#define KEY_semop 178
+#define KEY_send 179
+#define KEY_setgrent 180
+#define KEY_sethostent 181
+#define KEY_setnetent 182
+#define KEY_setpgrp 183
+#define KEY_setpriority 184
+#define KEY_setprotoent 185
+#define KEY_setpwent 186
+#define KEY_setservent 187
+#define KEY_setsockopt 188
+#define KEY_shift 189
+#define KEY_shmctl 190
+#define KEY_shmget 191
+#define KEY_shmread 192
+#define KEY_shmwrite 193
+#define KEY_shutdown 194
+#define KEY_sin 195
+#define KEY_sleep 196
+#define KEY_socket 197
+#define KEY_socketpair 198
+#define KEY_sort 199
+#define KEY_splice 200
+#define KEY_split 201
+#define KEY_sprintf 202
+#define KEY_sqrt 203
+#define KEY_srand 204
+#define KEY_stat 205
+#define KEY_study 206
+#define KEY_sub 207
+#define KEY_substr 208
+#define KEY_symlink 209
+#define KEY_syscall 210
+#define KEY_sysopen 211
+#define KEY_sysread 212
+#define KEY_sysseek 213
+#define KEY_system 214
+#define KEY_syswrite 215
+#define KEY_tell 216
+#define KEY_telldir 217
+#define KEY_tie 218
+#define KEY_tied 219
+#define KEY_time 220
+#define KEY_times 221
+#define KEY_tr 222
+#define KEY_truncate 223
+#define KEY_uc 224
+#define KEY_ucfirst 225
+#define KEY_umask 226
+#define KEY_undef 227
+#define KEY_unless 228
+#define KEY_unlink 229
+#define KEY_unpack 230
+#define KEY_unshift 231
+#define KEY_untie 232
+#define KEY_until 233
+#define KEY_use 234
+#define KEY_utime 235
+#define KEY_values 236
+#define KEY_vec 237
+#define KEY_wait 238
+#define KEY_waitpid 239
+#define KEY_wantarray 240
+#define KEY_warn 241
+#define KEY_while 242
+#define KEY_write 243
+#define KEY_x 244
+#define KEY_xor 245
+#define KEY_y 246
diff --git a/gnu/usr.bin/perl/keywords.pl b/gnu/usr.bin/perl/keywords.pl
index 086a10956ab..aebb3ee2e7c 100644
--- a/gnu/usr.bin/perl/keywords.pl
+++ b/gnu/usr.bin/perl/keywords.pl
@@ -1,5 +1,6 @@
#!/usr/bin/perl
+unlink "keywords.h";
open(KW, ">keywords.h") || die "Can't create keywords.h: $!\n";
select KW;
@@ -24,8 +25,9 @@ sub tab {
__END__
NULL
-__LINE__
__FILE__
+__LINE__
+__PACKAGE__
__DATA__
__END__
AUTOLOAD
@@ -235,6 +237,7 @@ symlink
syscall
sysopen
sysread
+sysseek
system
syswrite
tell
diff --git a/gnu/usr.bin/perl/lib/AnyDBM_File.pm b/gnu/usr.bin/perl/lib/AnyDBM_File.pm
index 50acce412a4..aff3c7cdec9 100644
--- a/gnu/usr.bin/perl/lib/AnyDBM_File.pm
+++ b/gnu/usr.bin/perl/lib/AnyDBM_File.pm
@@ -1,18 +1,24 @@
package AnyDBM_File;
+use vars qw(@ISA);
@ISA = qw(NDBM_File DB_File GDBM_File SDBM_File ODBM_File) unless @ISA;
-eval { require NDBM_File } ||
-eval { require DB_File } ||
-eval { require GDBM_File } ||
-eval { require SDBM_File } ||
-eval { require ODBM_File };
+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, ODBM_File, SDBM_File, GDBM_File - various DBM implementations
+NDBM_File, DB_File, GDBM_File, SDBM_File, ODBM_File - various DBM implementations
=head1 SYNOPSIS
@@ -27,20 +33,14 @@ 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:
- @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File);
-
-Note, however, that an explicit use overrides the specified order:
-
- use GDBM_File;
- @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File);
-
-will only find GDBM_File.
+ 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;
+ tie %newhash, 'DB_File', $new_filename, O_CREAT|O_RDWR;
+ tie %oldhash, 'NDBM_File', $old_filename, 1, 0;
%newhash = %oldhash;
=head2 DBM Comparisons
diff --git a/gnu/usr.bin/perl/lib/AutoLoader.pm b/gnu/usr.bin/perl/lib/AutoLoader.pm
index 566ca8688e9..2773a90f10f 100644
--- a/gnu/usr.bin/perl/lib/AutoLoader.pm
+++ b/gnu/usr.bin/perl/lib/AutoLoader.pm
@@ -1,54 +1,67 @@
package AutoLoader;
-use Carp;
-$DB::sub = $DB::sub; # Avoid warning
-=head1 NAME
-
-AutoLoader - load functions only on demand
-
-=head1 SYNOPSIS
-
- package FOOBAR;
- use Exporter;
- use AutoLoader;
- @ISA = (Exporter, AutoLoader);
-
-=head1 DESCRIPTION
-
-This module tells its users that functions in the FOOBAR package are to be
-autoloaded from F<auto/$AUTOLOAD.al>. See L<perlsub/"Autoloading">.
+use vars qw(@EXPORT @EXPORT_OK);
-=cut
+BEGIN {
+ require Exporter;
+ @EXPORT = ();
+ @EXPORT_OK = qw(AUTOLOAD);
+}
AUTOLOAD {
- my $name = "auto/$AUTOLOAD.al";
- $name =~ s#::#/#g;
- eval {require $name};
+ my $name;
+ # 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 ($@) {
- # 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 {require $name};
- }
- elsif ($AUTOLOAD =~ /::DESTROY$/) {
- # eval "sub $AUTOLOAD {}";
+ if (substr($AUTOLOAD,-9) eq '::DESTROY') {
*$AUTOLOAD = sub {};
- }
- if ($@){
- $@ =~ s/ at .*\n//;
- croak $@;
+ } 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);
+ }
}
}
- $DB::sub = $AUTOLOAD; # Now debugger know where we are.
+ $@ = $save;
goto &$AUTOLOAD;
}
-
+
sub import {
- my ($callclass, $callfile, $callline,$path,$callpack) = caller(0);
- ($callpack = $callclass) =~ s#::#/#;
+ 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
@@ -59,17 +72,178 @@ sub import {
# $INC{POSIX.pm} is 'lib/POSIX.pm', and we want to require
# 'auto/POSIX/autosplit.ix' (without the leading 'lib').
#
- if (defined($path = $INC{$callpack . '.pm'})) {
+
+ (my $calldir = $callpkg) =~ s#::#/#;
+ my $path = $INC{$calldir . '.pm'};
+ if (defined($path)) {
# Try absolute path name.
- $path =~ s#^(.*)$callpack\.pm$#$1auto/$callpack/autosplit.ix#;
+ $path =~ s#^(.*)$calldir\.pm$#$1auto/$calldir/autosplit.ix#;
eval { require $path; };
# If that failed, try relative path with normal @INC searching.
if ($@) {
- $path ="auto/$callpack/autosplit.ix";
+ $path ="auto/$calldir/autosplit.ix";
eval { require $path; };
}
- carp $@ if ($@);
+ 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.
+
+=head1 SEE ALSO
+
+L<SelfLoader> - an autoloader that doesn't use external files.
+
+=cut
diff --git a/gnu/usr.bin/perl/lib/AutoSplit.pm b/gnu/usr.bin/perl/lib/AutoSplit.pm
index f9e3ad6dc4c..8019df7187b 100644
--- a/gnu/usr.bin/perl/lib/AutoSplit.pm
+++ b/gnu/usr.bin/perl/lib/AutoSplit.pm
@@ -5,6 +5,7 @@ require Exporter;
use Config;
use Carp;
+use File::Path qw(mkpath);
@ISA = qw(Exporter);
@EXPORT = qw(&autosplit &autosplit_lib_modules);
@@ -16,14 +17,81 @@ AutoSplit - split a package for autoloading
=head1 SYNOPSIS
- perl -e 'use AutoSplit; autosplit_modules(@ARGV)' ...
+ perl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
+
+ use AutoSplit; autosplit($file, $dir, $keep, $check, $modtime);
+
+for perl versions 5.002 and later:
+
+ perl -MAutoSplit -e 'autosplit($ARGV[0], $ARGV[1], $k, $chk, $modtime)' ...
=head1 DESCRIPTION
This function will split up your program into files that the AutoLoader
-module can handle. Normally only used to build autoloading Perl library
-modules, especially extensions (like POSIX). You should look at how
-they're built out for details.
+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. 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). 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. 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.
+
+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 special marker I<__END__> are split out into separate files. Some
+routines may be placed prior to this marker to force their immediate loading
+and parsing.
+
+=head1 CAVEATS
+
+Currently, C<AutoSplit> cannot handle multiple package specifications
+within one file.
+
+=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
@@ -53,12 +121,12 @@ sub autosplit{
# This function is used during perl building/installation
-# ./miniperl -e 'use AutoSplit; autosplit_modules(@ARGV)' ...
+# ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
sub autosplit_lib_modules{
my(@modules) = @_; # list of Module names
- foreach(@modules){
+ 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
@@ -79,17 +147,16 @@ sub autosplit_lib_modules{
sub autosplit_file{
my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_;
my(@names);
+ local($_);
# where to write output files
$autodir = "lib/auto" unless $autodir;
- ($autodir = VMS::Filespec::unixpath($autodir)) =~ s#/$## if $Is_VMS;
+ if ($Is_VMS) {
+ ($autodir = VMS::Filespec::unixpath($autodir)) =~ s{/$}{};
+ $filename = VMS::Filespec::unixify($filename); # may have dirs
+ }
unless (-d $autodir){
- local($", @p)="/";
- foreach(split(/\//,$autodir)){
- push(@p, $_);
- next if -d "@p/";
- mkdir("@p",0755) or die "AutoSplit unable to mkdir @p: $!";
- }
+ 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.
@@ -123,13 +190,20 @@ sub autosplit_file{
$package or die "Can't find 'package Name;' in $filename\n";
- my($modpname) = $package; $modpname =~ s#::#/#g;
- my($al_idx_file) = "$autodir/$modpname/$IndexFile";
+ my($modpname) = $package;
+ if ($^O eq 'MSWin32') {
+ $modpname =~ s#::#\\#g;
+ } else {
+ $modpname =~ s#::#/#g;
+ }
- die "Package $package does not match filename $filename"
- unless ($filename =~ m/$modpname.pm$/ or
+ die "Package $package ($modpname.pm) does not match filename $filename"
+ unless ($filename =~ m/\Q$modpname.pm\E$/ or
+ ($^O eq "msdos") 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){
@@ -144,12 +218,7 @@ sub autosplit_file{
if $Verbose;
unless (-d "$autodir/$modpname"){
- local($", @p)="/";
- foreach(split(/\//,"$autodir/$modpname")){
- push(@p, $_);
- next if -d "@p/";
- mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!";
- }
+ mkpath("$autodir/$modpname",0,0777);
}
# We must try to deal with some SVR3 systems with a limit of 14
@@ -180,14 +249,17 @@ sub autosplit_file{
open(OUT,">/dev/null") || open(OUT,">nla0:"); # avoid 'not opened' warning
my(@subnames, %proto);
+ my @cache = ();
+ my $caching = 1;
while (<IN>) {
+ next if /^=\w/ .. /^=cut/;
if (/^package ([\w:]+)\s*;/) {
warn "package $1; in AutoSplit section ignored. Not currently supported.";
}
if (/^sub\s+([\w:]+)(\s*\(.*?\))?/) {
print OUT "1;\n";
my $subname = $1;
- $proto{$1} = $2 or '';
+ $proto{$1} = $2 || '';
if ($subname =~ m/::/){
warn "subs with package names not currently supported in AutoSplit section";
}
@@ -207,10 +279,26 @@ sub autosplit_file{
print OUT "# NOTE: Derived from $filename. ",
"Changes made here will be lost.\n";
print OUT "package $package;\n\n";
+ 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;
}
- print OUT $_;
}
- print OUT "1;\n";
+ print OUT @cache,"1;\n";
close(OUT);
close(IN);
diff --git a/gnu/usr.bin/perl/lib/Benchmark.pm b/gnu/usr.bin/perl/lib/Benchmark.pm
index 9929e6e0be6..13acf869bc1 100644
--- a/gnu/usr.bin/perl/lib/Benchmark.pm
+++ b/gnu/usr.bin/perl/lib/Benchmark.pm
@@ -14,11 +14,18 @@ timeit - run a chunk of code and see how long it goes
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";
@@ -40,43 +47,70 @@ Returns the current time. Example:
# ... your code here ...
$t1 = new Benchmark;
$td = timediff($t1, $t0);
- print "the code took:",timestr($dt),"\n";
+ print "the code took:",timestr($td),"\n";
=item debug
Enables or disable debugging by setting the C<$Benchmark::Debug> flag:
- debug Benchmark 1;
+ debug Benchmark 1;
$t = timeit(10, ' 5 ** $Global ');
- debug Benchmark 0;
+ debug Benchmark 0;
=back
=head2 Standard Exports
-The following routines will be exported into your namespace
+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 time to run the loop, and
-the second is the code to run. CODE may be a string containing the code,
-a reference to the function to run, or a reference to a hash containing
-keys which are names and values which are more CODE specs.
+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.
+
+=item timethese ( COUNT, CODEHASHREF, [ STYLE ] )
-Side-effects: prints out noise to standard out.
+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
-Returns: a Benchmark object.
+ timethis(COUNT, VALUE, KEY, STYLE)
-=item timethis
+=item timediff ( T1, T2 )
-=item timethese
+Returns the difference between two Benchmark times as a Benchmark
+object suitable for passing to timestr().
-=item timediff
+=item timestr ( TIMEDIFF, [ STYLE, [ FORMAT ]] )
-=item timestr
+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
@@ -87,20 +121,31 @@ if you specifically ask that they be imported:
=over 10
-clearcache
+=item clearcache ( COUNT )
+
+Clear the cached time for COUNT rounds of the null loop.
+
+=item clearallcache ( )
-clearallcache
+Clear all cached times.
-disablecache
+=item disablecache ( )
-enablecache
+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:
+functions:
($real, $user, $system, $children_user, $children_system)
@@ -110,10 +155,6 @@ The timing is done using time(3) and times(3).
Code is executed in the caller's package.
-Enable debugging by:
-
- $Benchmark::debug = 1;
-
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.
@@ -122,10 +163,10 @@ The null loop times are cached, the key being the
number of rounds. The caching can be controlled using
calls like these:
- clearcache($key);
+ clearcache($key);
clearallcache();
- disablecache();
+ disablecache();
enablecache();
=head1 INHERITANCE
@@ -135,112 +176,36 @@ 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:
+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 < 0.
-
-More documentation is needed :-( especially for styles and formats.
+code and therefore the difference might end up being E<lt> 0.
=head1 AUTHORS
-Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi>,
-Tim Bunce <Tim.Bunce@ig.co.uk>
+Jarkko Hietaniemi <F<jhi@iki.fi>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>
=head1 MODIFICATION HISTORY
September 8th, 1994; by Tim Bunce.
-=cut
+March 28th, 1997; by Hugo van der Sanden: added support for code
+references and the already documented 'debug' method; revamped
+documentation.
-# Purpose: benchmark running times of code.
-#
-#
-# Usage - to time code snippets and print results:
-#
-# timethis($count, '...code...');
-#
-# prints:
-# timethis 100: 2 secs ( 0.23 usr 0.10 sys = 0.33 cpu)
-#
-#
-# timethese($count, {
-# Name1 => '...code1...',
-# Name2 => '...code2...',
-# ... });
-# prints:
-# Benchmark: timing 100 iterations of Name1, Name2...
-# Name1: 2 secs ( 0.50 usr 0.00 sys = 0.50 cpu)
-# Name2: 1 secs ( 0.48 usr 0.00 sys = 0.48 cpu)
-#
-# The default display style will automatically add child process
-# values if non-zero.
-#
-#
-# Usage - to time sections of your own code:
-#
-# use Benchmark;
-# $t0 = new Benchmark;
-# ... your code here ...
-# $t1 = new Benchmark;
-# $td = &timediff($t1, $t0);
-# print "the code took:",timestr($td),"\n";
-#
-# $t = &timeit($count, '...other code...')
-# print "$count loops of other code took:",timestr($t),"\n";
-#
-#
-# Data format:
-# 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).
-#
-# Internals:
-# The timing is done using time(3) and times(3).
-#
-# Code is executed in the callers package
-#
-# Enable debugging by: $Benchmark::debug = 1;
-#
-# The time of the null loop (a loop with the same
-# number of rounds but empty loop body) is substracted
-# 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
-# &clearcache($key); &clearallcache;
-# &disablecache; &enablecache;
-#
-# Caveats:
-#
-# 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 < 0
-#
-# More documentation is needed :-(
-# Especially for styles and formats.
-#
-# Authors: Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi>
-# Tim Bunce <Tim.Bunce@ig.co.uk>
-#
-#
-# Last updated: Sept 8th 94 by Tim Bunce
-#
+=cut
use Carp;
use Exporter;
@@ -263,76 +228,79 @@ sub init {
&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); print "new=@t\n" if $debug; bless \@t; }
+sub new { my @t = (time, times); 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{
+sub timediff {
my($a, $b) = @_;
- my(@r);
- for($i=0; $i < @$a; ++$i){
+ my @r;
+ for ($i=0; $i < @$a; ++$i) {
push(@r, $a->[$i] - $b->[$i]);
}
bless \@r;
}
-sub timestr{
+sub timestr {
my($tr, $style, $f) = @_;
- my(@t) = @$tr;
+ my @t = @$tr;
warn "bad time value" unless @t==5;
my($r, $pu, $ps, $cu, $cs) = @t;
my($pt, $ct, $t) = ($tr->cpu_p, $tr->cpu_c, $tr->cpu_a);
- $f = $defaultfmt unless $f;
+ $f = $defaultfmt unless defined $f;
# format a time in the required style, other formats may be added here
- $style = $defaultstyle unless $style;
- $style = ($ct>0) ? 'all' : 'noc' if $style=~/^auto$/;
- my($s) = "@t $style"; # default for unknown style
+ $style ||= $defaultstyle;
+ $style = ($ct>0) ? 'all' : 'noc' if $style eq 'auto';
+ my $s = "@t $style"; # default for unknown style
$s=sprintf("%2d secs (%$f usr %$f sys + %$f cusr %$f csys = %$f cpu)",
- @t,$t) if $style =~ /^all$/;
+ @t,$t) if $style eq 'all';
$s=sprintf("%2d secs (%$f usr %$f sys = %$f cpu)",
- $r,$pu,$ps,$pt) if $style =~ /^noc$/;
+ $r,$pu,$ps,$pt) if $style eq 'noc';
$s=sprintf("%2d secs (%$f cusr %$f csys = %$f cpu)",
- $r,$cu,$cs,$ct) if $style =~ /^nop$/;
+ $r,$cu,$cs,$ct) if $style eq 'nop';
$s;
}
-sub timedebug{
+
+sub timedebug {
my($msg, $t) = @_;
- print STDERR "$msg",timestr($t),"\n" if ($debug);
+ 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 "negativ loopcount $n" if $n<0;
- confess "Usage: runloop(number, string)" unless defined $c;
+ 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;
+ my($curpack) = caller(0);
+ my($i, $pack)= 0;
while (($pack) = caller(++$i)) {
last if $pack ne $curpack;
}
- my $subcode = "sub { package $pack; my(\$_i)=$n; while (\$_i--){$c;} }";
+ my $subcode = (ref $c eq 'CODE')
+ ? "sub { package $pack; my(\$_i)=$n; while (\$_i--){&\$c;} }"
+ : "sub { package $pack; my(\$_i)=$n; while (\$_i--){$c;} }";
my $subref = eval $subcode;
croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@;
- print STDERR "runloop $n '$subcode'\n" if ($debug);
+ print STDERR "runloop $n '$subcode'\n" if $debug;
$t0 = &new;
&$subref;
@@ -350,9 +318,9 @@ sub timeit {
printf STDERR "timeit $n $code\n" if $debug;
- if ($cache && exists $cache{$n}){
+ if ($cache && exists $cache{$n}) {
$wn = $cache{$n};
- }else{
+ } else {
$wn = &runloop($n, '');
$cache{$n} = $wn;
}
@@ -368,44 +336,38 @@ sub timeit {
$wd;
}
-
# --- Functions implementing high-level time-then-print utilities
sub timethis{
my($n, $code, $title, $style) = @_;
- my($t) = timeit($n, $code);
- local($|) = 1;
- $title = "timethis $n" unless $title;
- $style = "" unless $style;
+ my $t = timeit($n, $code);
+ local $| = 1;
+ $title = "timethis $n" unless defined $title;
+ $style = "" unless defined $style;
printf("%10s: ", $title);
print timestr($t, $style),"\n";
+
# 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
+ if $n < $min_count
|| ($t->real < 1 && $n < 1000)
- || $t->cpu_a < $min_cpu);
+ || $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(@all);
- my(@names) = sort keys %$alt;
- $style = "" unless $style;
+ my @names = sort keys %$alt;
+ $style = "" unless defined $style;
print "Benchmark: timing $n iterations of ",join(', ',@names),"...\n";
- foreach(@names){
- $t = timethis($n, $alt->{$_}, $_, $style);
- push(@all, $t);
- }
- # we could produce a summary from @all here
+
+ # we could save the results in an array and produce a summary here
# sum, min, max, avg etc etc
- @all;
+ map timethis($n, $alt->{$_}, $_, $style), @names;
}
-
1;
diff --git a/gnu/usr.bin/perl/lib/Bundle/CPAN.pm b/gnu/usr.bin/perl/lib/Bundle/CPAN.pm
new file mode 100644
index 00000000000..062aab287df
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Bundle/CPAN.pm
@@ -0,0 +1,43 @@
+package Bundle::CPAN;
+
+$VERSION = '0.03';
+
+1;
+
+__END__
+
+=head1 NAME
+
+Bundle::CPAN - A bundle to play with all the other modules on CPAN
+
+=head1 SYNOPSIS
+
+C<perl -MCPAN -e 'install Bundle::CPAN'>
+
+=head1 CONTENTS
+
+MD5
+
+Data::Dumper # Bundle::libnet may have problems to work without it
+
+Bundle::libnet
+
+Term::ReadKey
+
+Term::ReadLine::Perl # sorry, I'm discriminating the ::Gnu module
+
+CPAN::WAIT
+
+CPAN
+
+=head1 DESCRIPTION
+
+This bundle includes CPAN.pm as the base module and CPAN::WAIT, the
+first plugin for CPAN that was developed even before there was an API.
+
+After installing this bundle, it is recommended to quit the current
+session and start again in a new process to enable Term::ReadLine.
+
+=head1 AUTHOR
+
+Andreas König
diff --git a/gnu/usr.bin/perl/lib/CGI.pm b/gnu/usr.bin/perl/lib/CGI.pm
new file mode 100644
index 00000000000..9967a42cf67
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/CGI.pm
@@ -0,0 +1,5108 @@
+package CGI;
+require 5.001;
+
+# 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-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.
+
+# 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/
+
+# Set this to 1 to enable copious autoloader debugging messages
+$AUTOLOAD_DEBUG=0;
+
+# 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 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;
+
+$CGI::revision = '$Id: CGI.pm,v 1.1 1997/11/30 07:56:38 millert Exp $';
+$CGI::VERSION='2.36';
+
+# OVERRIDE THE OS HERE IF CGI.pm GUESSES WRONG
+# $OS = 'UNIX';
+# $OS = 'MACINTOSH';
+# $OS = 'WINDOWS';
+# $OS = 'VMS';
+# $OS = 'OS2';
+
+# HARD-CODED LOCATION FOR FILE UPLOAD TEMPORARY FILES.
+# UNCOMMENT THIS ONLY IF YOU KNOW WHAT YOU'RE DOING.
+# $TempFile::TMPDIRECTORY = '/usr/tmp';
+
+# ------------------ START OF THE LIBRARY ------------
+
+# 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=~/Mac/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};
+
+# Turn on NPH scripts by default when running under IIS server!
+$NPH++ 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/)) {
+ $NPH++;
+ $| = 1;
+ $SEQNO = 1;
+}
+
+# This is really "\r\n", but the meaning of \n is different
+# in MacPerl, so we resort to octal here.
+$CRLF = "\015\012";
+
+if ($needs_binmode) {
+ $CGI::DefaultClass->binmode(main::STDOUT);
+ $CGI::DefaultClass->binmode(main::STDIN);
+ $CGI::DefaultClass->binmode(main::STDERR);
+}
+
+# Cute feature, but it broke when the overload mechanism changed...
+# %OVERLOAD = ('""'=>'as_string');
+
+%EXPORT_TAGS = (
+ ':html2'=>[h1..h6,qw/p br hr ol ul li dl dt dd menu code var strong em
+ tt 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/],
+ ':html3'=>[qw/div table caption th td TR Tr super sub strike applet PARAM embed basefont style span/],
+ ':netscape'=>[qw/blink frameset frame script font 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
+ remote_user user_name header redirect import_names put/],
+ ':ssl' => [qw/https/],
+ ':cgi-lib' => [qw/ReadParse PrintHeader HtmlTop HtmlBot SplitParam/],
+ ':html' => [qw/:html2 :html3 :netscape/],
+ ':standard' => [qw/:html2 :form :cgi/],
+ ':all' => [qw/:html2 :html3 :netscape :form :cgi/]
+ );
+
+# to import symbols into caller
+sub import {
+ my $self = shift;
+ my ($callpack, $callfile, $callline) = caller;
+ foreach (@_) {
+ $NPH++, next if $_ eq ':nph';
+ $PRIVATE_TEMPFILES++, next if $_ eq ':private_tempfiles';
+ foreach (&expand_tags($_)) {
+ tr/a-zA-Z0-9_//cd; # don't allow weird function names
+ $EXPORT{$_}++;
+ }
+ }
+ # 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 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;
+ $CGI::DefaultClass->_reset_globals() if $MOD_PERL;
+ $initializer = to_filehandle($initializer) if $initializer;
+ $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];
+}
+
+#### 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;
+}
+
+sub self_or_default {
+ return @_ if defined($_[0]) && !ref($_[0]) && ($_[0] eq 'CGI');
+ unless (defined($_[0]) &&
+ ref($_[0]) &&
+ (ref($_[0]) eq 'CGI' ||
+ eval "\$_[0]->isaCGI()")) { # optimize for the common case
+ $CGI::DefaultClass->_reset_globals()
+ if defined($Q) && $MOD_PERL && $CGI::DefaultClass->_new_request();
+ $Q = $CGI::DefaultClass->new unless defined($Q);
+ unshift(@_,$Q);
+ }
+ return @_;
+}
+
+sub _new_request {
+ return undef unless (defined(Apache->seqno()) or eval { require Apache });
+ if (Apache->seqno() != $SEQNO) {
+ $SEQNO = Apache->seqno();
+ return 1;
+ } else {
+ return undef;
+ }
+}
+
+sub _reset_globals {
+ undef $Q;
+ undef @QUERY_PARAM;
+}
+
+sub self_or_CGI {
+ local $^W=0; # prevent a warning
+ if (defined($_[0]) &&
+ (substr(ref($_[0]),0,3) eq 'CGI'
+ || eval "\$_[0]->isaCGI()")) {
+ return @_;
+ } else {
+ return ($DefaultClass,@_);
+ }
+}
+
+sub isaCGI {
+ return 1;
+}
+
+#### Method: import_names
+# Import all parameters into the given namespace.
+# Assumes namespace 'Q' if not specified
+####
+sub import_names {
+ my($self,$namespace) = self_or_default(@_);
+ $namespace = 'Q' unless defined($namespace);
+ die "Can't import names into 'main'\n"
+ if $namespace eq 'main';
+ my($param,@value,$var);
+ foreach $param ($self->param) {
+ # protect against silly names
+ ($var = $param)=~tr/a-zA-Z0-9_/_/c;
+ $var = "${namespace}::$var";
+ @value = $self->param($param);
+ @{$var} = @value;
+ ${$var} = $value[0];
+ }
+}
+
+#### 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;
+}
+
+########################################
+# 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,@lines);
+ my($meth) = '';
+
+ # 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'});
+
+ # If initializer is defined, then read parameters
+ # from it.
+ METHOD: {
+ if (defined($initializer)) {
+
+ if (ref($initializer) && ref($initializer) eq 'HASH') {
+ foreach (keys %$initializer) {
+ $self->param('-name'=>$_,'-value'=>$initializer->{$_});
+ }
+ last METHOD;
+ }
+
+ $initializer = $$initializer if ref($initializer);
+ if (defined(fileno($initializer))) {
+ while (<$initializer>) {
+ chomp;
+ last if /^=/;
+ push(@lines,$_);
+ }
+ # massage back into standard format
+ if ("@lines" =~ /=/) {
+ $query_string=join("&",@lines);
+ } else {
+ $query_string=join("+",@lines);
+ }
+ last METHOD;
+ }
+ $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'};
+ last METHOD;
+ }
+
+ # If the method is POST, fetch the query from standard
+ # input.
+ if ($meth eq 'POST') {
+
+ if (defined($ENV{'CONTENT_TYPE'})
+ &&
+ $ENV{'CONTENT_TYPE'}=~m|^multipart/form-data|) {
+ my($boundary) = $ENV{'CONTENT_TYPE'}=~/boundary=(\S+)/;
+ $self->read_multipart($boundary,$ENV{'CONTENT_LENGTH'});
+
+ } else {
+
+ $self->read_from_client(\*STDIN,\$query_string,$ENV{'CONTENT_LENGTH'},0)
+ if $ENV{'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 .= ($query_string ? '&' : '') . $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'};
+ last METHOD;
+ }
+
+ # If neither is set, 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;
+ }
+
+ # We now have the query string in hand. We do slightly
+ # different things for keyword lists and parameter lists.
+ if ($query_string) {
+ 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 $string = shift;
+ if ($string && !ref($string)) {
+ my($package) = caller(1);
+ my($tmp) = $string=~/[':]/ ? $string : "$package\:\:$string";
+ return $tmp if defined(fileno($tmp));
+ }
+ return $string;
+}
+
+# Create a new multipart buffer
+sub new_MultipartBuffer {
+ my($self,$boundary,$length,$filehandle) = @_;
+ return MultipartBuffer->new($self,$boundary,$length,$filehandle);
+}
+
+# Read data from a file handle
+sub read_from_client {
+ my($self, $fh, $buff, $len, $offset) = @_;
+ local $^W=0; # prevent a warning
+ return read($fh, $$buff, $len, $offset);
+}
+
+# put a filehandle into binary mode (DOS)
+sub binmode {
+ binmode($_[1]);
+}
+
+# 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 {
+ my($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 {
+ my($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_keywordlist {
+ my($self,$tosplit) = @_;
+ $tosplit = &unescape($tosplit); # unescape the keywords
+ $tosplit=~tr/+/ /; # pluses to spaces
+ my(@keywords) = split(/\s+/,$tosplit);
+ return @keywords;
+}
+
+sub parse_params {
+ my($self,$tosplit) = @_;
+ my(@pairs) = split('&',$tosplit);
+ my($param,$value);
+ foreach (@pairs) {
+ ($param,$value) = split('=');
+ $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'}};
+}
+
+#### Method as_string
+#
+# synonym for "dump"
+####
+sub as_string {
+ &dump(@_);
+}
+
+sub AUTOLOAD {
+ print STDERR "CGI::AUTOLOAD for $AUTOLOAD\n" if $CGI::AUTOLOAD_DEBUG;
+ my($func) = $AUTOLOAD;
+ my($pack,$func_name) = $func=~/(.+)::([^:]+)$/;
+ $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 $@;
+ }
+ my($code) = $sub->{$func_name};
+
+ $code = "sub $AUTOLOAD { }" if (!$code and $func_name eq 'DESTROY');
+ if (!$code) {
+ if ($EXPORT{':any'} ||
+ $EXPORT{$func_name} ||
+ (%EXPORT_OK || grep(++$EXPORT_OK{$_},&expand_tags(':html')))
+ && $EXPORT_OK{$func_name}) {
+ $code = $sub->{'HTML_FUNC'};
+ $code=~s/func_name/$func_name/mg;
+ }
+ }
+ die "Undefined subroutine $AUTOLOAD\n" unless $code;
+ eval "package $pack; $code";
+ if ($@) {
+ $@ =~ s/ at .*\n//;
+ die $@;
+ }
+ goto &{"$pack\:\:$func_name"};
+}
+
+# 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;
+
+ return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-')
+ || $self->use_named_parameters;
+
+ my $i;
+ for ($i=0;$i<@param;$i+=2) {
+ $param[$i]=~s/^\-//; # get rid of initial - if present
+ $param[$i]=~tr/a-z/A-Z/; # parameters are upper case
+ }
+
+ my(%param) = @param; # convert into associative array
+ my(@return_array);
+
+ my($key)='';
+ foreach $key (@$order) {
+ my($value);
+ # this is an awful hack to fix spurious warnings when the
+ # -w switch is set.
+ if (ref($key) && ref($key) eq 'ARRAY') {
+ foreach (@$key) {
+ last if defined($value);
+ $value = $param{$_};
+ delete $param{$_};
+ }
+ } else {
+ $value = $param{$key};
+ delete $param{$key};
+ }
+ push(@return_array,$value);
+ }
+ push (@return_array,$self->make_attributes(\%param)) if %param;
+ return (@return_array);
+}
+
+###############################################################################
+################# 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
+
+'HTML_FUNC' => <<'END_OF_FUNC',
+sub func_name {
+
+ # 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' ||
+ eval "\$_[0]->isaCGI()"));
+
+ my($attr) = '';
+ if (ref($_[0]) && ref($_[0]) eq 'HASH') {
+ my(@attr) = CGI::make_attributes('',shift);
+ $attr = " @attr" if @attr;
+ }
+ my($tag,$untag) = ("\U<func_name\E$attr>","\U</func_name>\E");
+ return $tag unless @_;
+ if (ref($_[0]) eq 'ARRAY') {
+ my(@r);
+ foreach (@{$_[0]}) {
+ push(@r,"$tag$_$untag");
+ }
+ return "@r";
+ } else {
+ return "$tag@_$untag";
+ }
+}
+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 @values;
+ my(@result) = @{$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);
+}
+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 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
+
+#### 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
+ push(@att,$attr->{$_} ne '' ? qq/$key="$attr->{$_}"/ : qq/$key/);
+ }
+ return @att;
+}
+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: 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(@_);
+ my($param);
+ my($package) = caller;
+# Check that this still works!
+# $filehandle = $filehandle=~/[':]/ ? $filehandle : "$package\:\:$filehandle";
+ $filehandle = to_filehandle($filehandle);
+ 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: 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);
+
+ # rearrange() was designed for the HTML portion, so we
+ # need to fix it up a little.
+ foreach (@other) {
+ next unless my($header,$value) = /([^\s=]+)=(.+)/;
+ substr($header,1,1000)=~tr/A-Z/a-z/;
+ ($value)=$value=~/^"(.*)"$/;
+ $_ = "$header: $value";
+ }
+
+ $type = $type || 'text/html';
+
+ push(@header,'HTTP/1.0 ' . ($status || '200 OK')) if $nph || $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) ? @{$cookie} : $cookie;
+ foreach (@cookie) {
+ push(@header,"Set-cookie: $_");
+ }
+ }
+ # 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: " . &date(&expire_calc($expires),'http'))
+ if $expires;
+ push(@header,"Date: " . &date(&expire_calc(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);
+ return $header . "${CRLF}${CRLF}";
+}
+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([[URI,URL],TARGET,COOKIE,NPH],@p);
+ $url = $url || $self->self_url;
+ my(@o);
+ foreach (@other) { push(@o,split("=")); }
+ if($MOD_PERL or exists $self->{'.req'}) {
+ my $r = $self->{'.req'} || Apache->request;
+ $r->header_out(Location => $url);
+ $r->err_header_out(Location => $url);
+ $r->status(302);
+ return;
+ }
+ push(@o,
+ '-Status'=>'302 Found',
+ '-Location'=>$url,
+ '-URI'=>$url,
+ '-nph'=>($nph||$NPH));
+ push(@o,'-Target'=>$target) if $target;
+ push(@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,@other) =
+ $self->rearrange([TITLE,AUTHOR,BASE,XBASE,SCRIPT,NOSCRIPT,TARGET,META,HEAD,STYLE],@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->escapeHTML($author);
+ my(@result);
+ push(@result,'<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">');
+ push(@result,"<HTML><HEAD><TITLE>$title</TITLE>");
+ push(@result,"<LINK REV=MADE HREF=\"mailto:$author\">") if $author;
+
+ if ($base || $xbase || $target) {
+ my $href = $xbase || $self->url();
+ 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 various types of -style parameters
+ if ($style) {
+ if (ref($style)) {
+ my($src,$code,@other) =
+ $self->rearrange([SRC,CODE],
+ '-foo'=>'bar', # a trick to allow the '-' to be omitted
+ ref($style) eq 'ARRAY' ? @$style : %$style);
+ push(@result,qq/<LINK REL="stylesheet" HREF="$src">/) if $src;
+ push(@result,style($code)) if $code;
+ } else {
+ push(@result,style($style))
+ }
+ }
+
+ # handle -script parameter
+ if ($script) {
+ 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));
+ }
+
+ # 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: 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
+
+
+#### 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(@_);
+ 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="text" NAME="$name" VALUE="$current"$s$m$other>/;
+}
+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(@_);
+
+ my($name,$default,$size,$maxlength,$override,@other) =
+ $self->rearrange([NAME,[DEFAULT,VALUE],SIZE,MAXLENGTH,[OVERRIDE,FORCE]],@p);
+
+ $current = $override ? $default :
+ (defined($self->param($name)) ? $self->param($name) : $default);
+
+ $name = defined($name) ? $self->escapeHTML($name) : '';
+ my($s) = defined($size) ? qq/ SIZE=$size/ : '';
+ my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
+ $current = defined($current) ? $self->escapeHTML($current) : '';
+ $other = ' ' . join(" ",@other);
+ return qq/<INPUT TYPE="file" NAME="$name" VALUE="$current"$s$m$other>/;
+}
+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(@_);
+
+ 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);
+
+ $name = defined($name) ? $self->escapeHTML($name) : '';
+ $current = defined($current) ? $self->escapeHTML($current) : '';
+ my($s) = defined($size) ? qq/ SIZE=$size/ : '';
+ my($m) = defined($maxlength) ? qq/ MAXLENGTH=$maxlength/ : '';
+ my($other) = @other ? " @other" : '';
+ return qq/<INPUT TYPE="password" NAME="$name" VALUE="$current"$s$m$other>/;
+}
+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 $label;
+ $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: 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);
+
+ if (!$override && defined($self->param($name))) {
+ $value = $self->param($name) unless defined $value;
+ $checked = $self->param($name) eq $value ? ' CHECKED' : '';
+ } else {
+ $checked = $checked ? ' CHECKED' : '';
+ $value = defined $value ? $value : 'on';
+ }
+ 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);
+ my(@values) = $values ? @$values : $self->param($name);
+ my($other) = @other ? " @other" : '';
+ foreach (@values) {
+ $checked = $checked{$_} ? ' CHECKED' : '';
+ $label = '';
+ unless (defined($nolabels) && $nolabels) {
+ $label = $_;
+ $label = $labels->{$_} if defined($labels) && $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 $columns;
+ return _tableize($rows,$columns,$rowheaders,$colheaders,@elements);
+}
+END_OF_FUNC
+
+
+# Escape HTML -- used internally
+'escapeHTML' => <<'END_OF_FUNC',
+sub escapeHTML {
+ my($self,$toencode) = @_;
+ return undef unless defined($toencode);
+ return $toencode if $self->{'dontescape'};
+ $toencode=~s/&/&amp;/g;
+ $toencode=~s/\"/&quot;/g;
+ $toencode=~s/>/&gt;/g;
+ $toencode=~s/</&lt;/g;
+ return $toencode;
+}
+END_OF_FUNC
+
+
+# Internal procedure - don't use
+'_tableize' => <<'END_OF_FUNC',
+sub _tableize {
+ my($rows,$columns,$rowheaders,$colheaders,@elements) = @_;
+ my($result);
+
+ $rows = int(0.99 + @elements/$columns) unless $rows;
+ # rearrange into a pretty table
+ $result = "<TABLE>";
+ my($row,$column);
+ unshift(@$colheaders,'') if @$colheaders && @$rowheaders;
+ $result .= "<TR>" if @{$colheaders};
+ foreach (@{$colheaders}) {
+ $result .= "<TH>$_</TH>";
+ }
+ for ($row=0;$row<$rows;$row++) {
+ $result .= "<TR>";
+ $result .= "<TH>$rowheaders->[$row]</TH>" if @$rowheaders;
+ for ($column=0;$column<$columns;$column++) {
+ $result .= "<TD>" . $elements[$column*$rows + $row] . "</TD>";
+ }
+ $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 $checked;
+ $name=$self->escapeHTML($name);
+
+ my(@elements);
+ my(@values) = $values ? @$values : $self->param($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) && $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 $columns;
+ 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 ? @$values : $self->param($name);
+ $result = qq/<SELECT NAME="$name"$other>\n/;
+ foreach (@values) {
+ my($selectit) = defined($selected) ? ($selected eq $_ ? 'SELECTED' : '' ) : '';
+ my($label) = $_;
+ $label = $labels->{$_} if defined($labels) && $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);
+ my(@values) = $values ? @$values : $self->param($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) && $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 ( 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) = self_or_default(@_);
+ my($query_string) = $self->query_string;
+ my $protocol = $self->protocol();
+ my $name = "$protocol://" . $self->server_name;
+ $name .= ":" . $self->server_port
+ unless $self->server_port == 80;
+ $name .= $self->script_name;
+ $name .= $self->path_info if $self->path_info;
+ return $name unless $query_string;
+ return "$name?$query_string";
+}
+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) = self_or_default(@_);
+ my $protocol = $self->protocol();
+ my $name = "$protocol://" . $self->server_name;
+ $name .= ":" . $self->server_port
+ unless $self->server_port == 80;
+ $name .= $self->script_name;
+ return $name;
+}
+
+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',
+# temporary, for debugging.
+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);
+
+
+ # if no value is supplied, then we retrieve the
+ # value of the cookie, if any. For efficiency, we cache the parsed
+ # cookie in our state variables.
+ unless (defined($value)) {
+ unless ($self->{'.cookies'}) {
+ my(@pairs) = split("; ",$self->raw_cookie);
+ foreach (@pairs) {
+ my($key,$value) = split("=");
+ my(@values) = map unescape($_),split('&',$value);
+ $self->{'.cookies'}->{unescape($key)} = [@values];
+ }
+ }
+
+ # If no name is supplied, then retrieve the names of all our cookies.
+ return () unless $self->{'.cookies'};
+ return wantarray ? @{$self->{'.cookies'}->{$name}} : $self->{'.cookies'}->{$name}->[0]
+ if defined($name) && $name ne '';
+ return keys %{$self->{'.cookies'}};
+ }
+ my(@values);
+
+ # Pull out our parameters.
+ if (ref($value)) {
+ if (ref($value) eq 'ARRAY') {
+ @values = @$value;
+ } elsif (ref($value) eq 'HASH') {
+ @values = %$value;
+ }
+ } else {
+ @values = ($value);
+ }
+ @values = map escape($_),@values;
+
+ # I.E. requires the path to be present.
+ ($path = $ENV{'SCRIPT_NAME'})=~s![^/]+$!! unless $path;
+
+ my(@constant_values);
+ push(@constant_values,"domain=$domain") if $domain;
+ push(@constant_values,"path=$path") if $path;
+ push(@constant_values,"expires=".&date(&expire_calc($expires),'cookie'))
+ if $expires;
+ push(@constant_values,'secure') if $secure;
+
+ my($key) = &escape($name);
+ my($cookie) = join("=",$key,join("&",@values));
+ return join("; ",$cookie,@constant_values);
+}
+END_OF_FUNC
+
+
+# This internal routine creates an expires time exactly some number of
+# hours from the current time. It incorporates modifications from
+# Fisher Mark.
+'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 || ($time eq 'now')) {
+ $offset = 0;
+ } elsif ($time=~/^([+-]?\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.
+'date' => <<'END_OF_FUNC',
+sub date {
+ my($time,$format) = @_;
+ 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()
+ if ("$time" =~ m/^[^0-9]/o) {
+ return $time;
+ }
+
+ # 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
+
+###############################################
+# 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 {
+ return $ENV{'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: cookie
+# Returns the magic cookie for the session.
+# To set the magic cookie for new transations,
+# try print $q->header('-Set-cookie'=>'my cookie')
+####
+'raw_cookie' => <<'END_OF_FUNC',
+sub raw_cookie {
+ my($self) = self_or_CGI(@_);
+ 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 {
+ return http('host') || server_name();
+}
+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 $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 $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
+
+# -------------- 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->hidden('-name'=>'.cgifields',
+ '-values'=>[keys %{$self->{'.parametersToAdd'}}],
+ '-override'=>1);
+}
+END_OF_FUNC
+
+'read_from_cmdline' => <<'END_OF_FUNC',
+sub read_from_cmdline {
+ require "shellwords.pl";
+ my($input,@words);
+ my($query_string);
+ if (@ARGV) {
+ $input = join(" ",@ARGV);
+ } else {
+ print STDERR "(offline mode: enter name=value pairs on standard input)\n";
+ chomp(@lines = <>); # remove newlines
+ $input = join(" ",@lines);
+ }
+
+ # minimal handling of escape characters
+ $input=~s/\\=/%3D/g;
+ $input=~s/\\&/%26/g;
+
+ @words = &shellwords($input);
+ 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) = @_;
+ my($buffer) = $self->new_MultipartBuffer($boundary,$length);
+ return unless $buffer;
+ my(%header,$body);
+ while (!$buffer->eof) {
+ %header = $buffer->readHeader;
+ die "Malformed multipart POST\n" unless %header;
+
+ # In beta1 it was "Content-disposition". In beta2 it's "Content-Disposition"
+ # Sheesh.
+ my($key) = $header{'Content-disposition'} ? 'Content-disposition' : 'Content-Disposition';
+ my($param)= $header{$key}=~/ name="([^\"]*)"/;
+
+ # possible bug: our regular expression expects the filename= part to fall
+ # at the end of the line. Netscape doesn't escape quotation marks in file names!!!
+ my($filename) = $header{$key}=~/ 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;
+ }
+
+ # 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.
+ my($tmpfile) = new TempFile;
+ my $tmp = $tmpfile->as_string;
+
+ # Now create a new filehandle in the caller's namespace.
+ # The name of this filehandle just happens to be identical
+ # to the original filename (NOT the name of the temporary
+ # file, which is hidden!)
+ my($filehandle);
+ if ($filename=~/^[a-zA-Z_]/) {
+ my($frame,$cp)=(1);
+ do { $cp = caller($frame++); } until !eval("'$cp'->isaCGI()");
+ $filehandle = "$cp\:\:$filename";
+ } else {
+ $filehandle = "\:\:$filename";
+ }
+
+ # potential security problem -- this type of line can clobber
+ # tempfile, and can be abused by malicious users.
+ # open ($filehandle,">$tmp") || die "CGI open of $tmpfile: $!\n";
+
+ # This technique causes open to fail if file already exists.
+ unless (defined(&O_RDWR)) {
+ require Fcntl;
+ import Fcntl qw/O_RDWR O_CREAT O_EXCL/;
+ }
+ sysopen($filehandle,$tmp,&O_RDWR|&O_CREAT|&O_EXCL) || die "CGI open of $tmp: $!\n";
+ unlink($tmp) if $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;
+ }
+
+ seek($filehandle,0,0); #rewind file
+ push(@{$self->{$param}},$filename);
+
+ # Under Unix, it would be safe to let the temporary file
+ # be deleted immediately. However, I fear that other operating
+ # systems are not so forgiving. Therefore we save a reference
+ # to the temporary file in the CGI object so that the file
+ # isn't unlinked until the CGI object itself goes out of
+ # scope. This is a bit hacky, but it has the interesting side
+ # effect that one can access the name of the tmpfile by
+ # asking for $query->{$query->param('foo')}, where 'foo'
+ # is the name of the file upload field.
+ $self->{'.tmpfiles'}->{$filename}= {
+ name=>($PRIVATE_TEMPFILES ? '' : $tmpfile),
+ info=>{%header}
+ }
+ }
+}
+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
+
+);
+END_OF_AUTOLOAD
+;
+
+# Globals and stubs for other packages that we use
+package MultipartBuffer;
+
+# how many bytes to read at a time. We use
+# a 5K buffer by default.
+$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;
+
+###############################################################################
+################# 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) = @_;
+ 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
+ $boundary = "--$boundary";
+ # Read the topmost (boundary) line plus the CRLF
+ my($null) = '';
+ $length -= $interface->read_from_client($IN,\$null,length($boundary)+2,0);
+ } 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;
+
+ return bless $self,ref $package || $package;
+}
+END_OF_FUNC
+
+'readHeader' => <<'END_OF_FUNC',
+sub readHeader {
+ my($self) = @_;
+ my($end);
+ my($ok) = 0;
+ my($bad) = 0;
+ do {
+ $self->fillBuffer($FILLUNIT);
+ $ok++ if ($end = index($self->{BUFFER},"${CRLF}${CRLF}")) >= 0;
+ $ok++ if $self->{BUFFER} eq '';
+ $bad++ if !$ok && $self->{LENGTH} <= 0;
+ $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;
+ while ($header=~/^([\w-]+): (.*)$CRLF/mog) {
+ $return{$1}=$2;
+ }
+ 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;
+unless ($TMPDIRECTORY) {
+ @TEMP=("${SL}usr${SL}tmp","${SL}var${SL}tmp","${SL}tmp","${SL}temp","${SL}Temporary Items");
+ foreach (@TEMP) {
+ do {$TMPDIRECTORY = $_; last} if -d $_ && -w _;
+ }
+}
+
+$TMPDIRECTORY = "." unless $TMPDIRECTORY;
+$SEQUENCE="CGItemp${$}0000";
+
+# 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) = @_;
+ $SEQUENCE++;
+ my $directory = "${TMPDIRECTORY}${SL}${SEQUENCE}";
+ 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::FILLUNIT;
+ $TempFile::SEQUENCE;
+EOF
+ ;
+}
+
+$revision;
+
+__END__
+
+=head1 NAME
+
+CGI - Simple Common Gateway Interface Class
+
+=head1 SYNOPSIS
+
+ use CGI;
+ # the rest is too complicated for a synopsis; keep reading
+
+=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 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 INSTALLATION
+
+CGI is a part of the base Perl installation. However, you may need
+to install a newer version someday. Therefore:
+
+To install this package, just change to the directory in which this
+file is found and type the following:
+
+ perl Makefile.PL
+ make
+ make install
+
+This will copy CGI.pm to your perl library directory for use by all
+perl scripts. You probably must be root to do this. Now you can
+load the CGI routines in your Perl scripts with the line:
+
+ use CGI;
+
+If you don't have sufficient privileges to install CGI.pm in the Perl
+library directory, you can put CGI.pm into some convenient spot, such
+as your home directory, or in cgi-bin itself and prefix all Perl
+scripts that call it with something along the lines of the following
+preamble:
+
+ use lib '/home/davis/lib';
+ use CGI;
+
+If you are using a version of perl earlier than 5.002 (such as NT perl), use
+this instead:
+
+ BEGIN {
+ unshift(@INC,'/home/davis/lib');
+ }
+ use CGI;
+
+The CGI distribution also comes with a cute module called L<CGI::Carp>.
+It redefines the die(), warn(), confess() and croak() error routines
+so that they write nicely formatted error messages into the server's
+error log (or to the output stream of your choice). This avoids long
+hours of groping through the error and access logs, trying to figure
+out which CGI script is generating error messages. If you choose,
+you can even have fatal error messages echoed to the browser to avoid
+the annoying and uninformative "Server Error" message.
+
+=head1 DESCRIPTION
+
+=head2 CREATING A NEW QUERY OBJECT:
+
+ $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 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');
+
+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.
+
+=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.
+
+=head2 SAVING THE STATE OF THE FORM 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.
+
+=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 don't want to get the whole query string, call
+the method url() to return just the URL for the script:
+
+ $myself = $query->url;
+ print "<A HREF=$myself>No query string in this baby!</A>\n";
+
+You can also retrieve the unprocessed query string with query_string():
+
+ $the_string = $query->query_string;
+
+=head2 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.
+
+=head2 CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS
+
+In versions of CGI.pm prior to 2.0, it could get difficult to remember
+the proper order of arguments in CGI function calls that accepted five
+or six different arguments. As of 2.0, there's a better way to pass
+arguments to the various CGI functions. In this style, you pass a
+series of name=>argument pairs, like this:
+
+ $field = $query->radio_group(-name=>'OS',
+ -values=>[Unix,Windows,Macintosh],
+ -default=>'Unix');
+
+The advantages of this style are that you don't have to remember the
+exact order of the arguments, and if you leave out a parameter, in
+most cases it will default to some reasonable value. If you provide
+a parameter that the method doesn't recognize, it will usually do
+something useful with it, such as incorporating it into the HTML form
+tag. For example if Netscape decides next week to add a new
+JUSTIFICATION parameter to the text field tags, you can start using
+the feature without waiting for a new version of CGI.pm:
+
+ $field = $query->textfield(-name=>'State',
+ -default=>'gaseous',
+ -justification=>'RIGHT');
+
+This will result in an HTML tag that looks like this:
+
+ <INPUT TYPE="textfield" NAME="State" VALUE="gaseous"
+ JUSTIFICATION="RIGHT">
+
+Parameter names are case insensitive: you can use -name, or -Name or
+-NAME. You don't have to use the hyphen if 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');
+
+Actually, CGI.pm only looks for a hyphen in the first parameter. So
+you can leave it off subsequent parameters if you like. Something to
+be wary of is the potential that a string constant like "values" will
+collide with a keyword (and in fact it does!) While Perl usually
+figures out when you're referring to a function and when you're
+referring to a string, you probably should put quotation marks around
+all string constants just to play it safe.
+
+=head2 CREATING THE HTTP HEADER:
+
+ 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. If you want to
+add additional fields to the header, just tack them on to the end:
+
+ print $query->header('text/html','200 OK','Content-Length: 3002');
+
+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
+parameters will be stripped of their initial hyphens and turned into
+header fields, allowing you to specify any HTTP header you desire.
+
+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-96 00:40:33 GMT at the indicated time & date
+
+(CGI::expires() is the static function call used internally that turns
+relative time intervals into HTTP dates. You can call it directly if
+you wish.)
+
+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 INSTRUCTION
+
+ print $query->redirect('http://somewhere.else/in/movie/land');
+
+redirects the browser elsewhere. 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 use named parameters:
+
+ 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 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');
+
+ -or-
+
+ print $query->start_html('Secrets of the Pyramids',
+ 'fred@capricorn.org','true',
+ 'BGCOLOR="blue"');
+
+This will return 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.
+
+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->header(-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->header(-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> 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;"'
+ );
+
+
+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.
+
+=head1 CREATING 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>
+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>
+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>
+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 Gold, 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>
+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>, 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>, 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<-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
+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."
+
+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.
+
+=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 CREATING HTML ELEMENTS
+
+In addition to its shortcuts for creating form elements, CGI.pm
+defines general HTML shortcut methods as well. 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.
+
+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 shortcuts; # IMPORT HTML SHORTCUTS
+ 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;
+ # gives "<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");
+ # gives "<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");
+ # gives <a href="fred.html",target="_new">Open a new frame</a>
+
+You are free to use CGI.pm-style dashes in front of the attribute
+names if you prefer:
+
+ print img {-src=>'fred.gif',-align=>'LEFT'};
+ # gives <img ALIGN="LEFT" SRC="fred.gif">
+
+=head2 Generating new HTML tags
+
+Since no mere mortal can keep up with Netscape and Microsoft as they
+battle it out for control of HTML, the code that generates HTML tags
+is general and extensible. You can create new HTML tags freely just
+by referring to them on the import line:
+
+ use CGI shortcuts,winkin,blinkin,nod;
+
+Now, in addition to the standard CGI shortcuts, you've created HTML
+tags named "winkin", "blinkin" and "nod". You can use them like this:
+
+ print blinkin {color=>'blue',rate=>'fast'},"Yahoo!";
+ # <blinkin COLOR="blue" RATE="fast">Yahoo!</blinkin>
+
+=head1 IMPORTING CGI METHOD CALLS INTO YOUR NAME SPACE
+
+As a convenience, you can import most of the CGI method calls directly
+into your name space. The syntax for doing this is:
+
+ 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');
+
+You can import groups of methods by referring to a number of special
+names:
+
+=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<shortcuts>
+
+Import all HTML-generating shortcuts (i.e. 'html2' + 'html3' +
+'netscape')...
+
+=item B<standard>
+
+Import "standard" features, 'html2', '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
+
+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 standard,html2;
+ 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;
+
+=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 ":nph" to 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=&gt;1);
+
+=back
+
+=head1 AUTHOR INFORMATION
+
+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.
+
+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 ...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/gnu/usr.bin/perl/lib/CGI/Apache.pm b/gnu/usr.bin/perl/lib/CGI/Apache.pm
new file mode 100644
index 00000000000..6ea7523c571
--- /dev/null
+++ b/gnu/usr.bin/perl/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 König E<lt>a.koenig@mind.deE<gt>, modified by Lincoln Stein <lt>lstein@genome.wi.mit.edu<gt>
+
+=cut
diff --git a/gnu/usr.bin/perl/lib/CGI/Carp.pm b/gnu/usr.bin/perl/lib/CGI/Carp.pm
new file mode 100644
index 00000000000..4cd79467fd8
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/CGI/Carp.pm
@@ -0,0 +1,242 @@
+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
+
+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).
+
+=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.
+
+=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);
+
+$main::SIG{__WARN__}=\&CGI::Carp::warn;
+$main::SIG{__DIE__}=\&CGI::Carp::die;
+$CGI::Carp::VERSION = '1.06';
+
+# fancy import routine detects and handles 'errorWrap' specially.
+sub import {
+ my $pkg = shift;
+ my(%routines);
+ grep($routines{$_}++,@_);
+ $WRAP++ if $routines{'fatalsToBrowser'};
+ my($oldlevel) = $Exporter::ExportLevel;
+ $Exporter::ExportLevel = 1;
+ Exporter::import($pkg,keys %routines);
+ $Exporter::ExportLevel = $oldlevel;
+}
+
+# These are the originals
+sub realwarn { warn(@_); }
+sub realdie { 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;
+}
+
+sub die {
+ my $message = shift;
+ my $time = scalar(localtime);
+ my($file,$line,$id) = id(1);
+ return undef if $file=~/^\(eval/;
+ $message .= " at $file line $line.\n" unless $message=~/\n$/;
+ &fatalsToBrowser($message) if $WRAP;
+ my $stamp = stamp;
+ $message=~s/^/$stamp/gm;
+ realdie $message;
+}
+
+# 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) = @_;
+ $in = $$in if ref($in); # compatability with Marc's method;
+ my($no) = fileno($in);
+ unless (defined($no)) {
+ my($package) = caller;
+ my($handle) = $in=~/[':]/ ? $in : "$package\:\:$in";
+ $no = fileno($handle);
+ }
+ die "Invalid filehandle $in\n" unless $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;
+ print STDOUT "Content-type: text/html\n\n";
+ print STDOUT <<END;
+<H1>Software error:</H1>
+<CODE>$msg</CODE>
+<P>
+Please send mail to this site's webmaster for help.
+END
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/CGI/Fast.pm b/gnu/usr.bin/perl/lib/CGI/Fast.pm
new file mode 100644
index 00000000000..03b54072c96
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/CGI/Push.pm b/gnu/usr.bin/perl/lib/CGI/Push.pm
new file mode 100644
index 00000000000..4390d0383e6
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/CGI/Push.pm
@@ -0,0 +1,239 @@
+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.00';
+use CGI;
+@ISA = ('CGI');
+
+# add do_push() to exported tags
+push(@{$CGI::EXPORT_TAGS{':standard'}},'do_push');
+
+sub do_push {
+ my ($self,@p) = CGI::self_or_CGI(@_);
+
+ # unbuffer output
+ $| = 1;
+ srand;
+ my ($random) = 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);
+
+ 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";
+ print @contents,"$CGI::CRLF";
+ print "${boundary}$CGI::CRLF";
+ do_sleep($delay) if $delay;
+ }
+ print "Content-type: ${type}$CGI::CRLF$CGI::CRLF",
+ &$last_page($self,++$COUNTER),
+ "$CGI::CRLF${boundary}$CGI::CRLF"
+ if $last_page && ref($last_page) eq 'CODE';
+}
+
+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);
+ }
+}
+
+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";
+ }
+
+=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". Currently, server push of heterogeneous
+document types is not supported.
+
+=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
+
+=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/gnu/usr.bin/perl/lib/CGI/Switch.pm b/gnu/usr.bin/perl/lib/CGI/Switch.pm
new file mode 100644
index 00000000000..420fff7643c
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/CGI/Switch.pm
@@ -0,0 +1,78 @@
+package CGI::Switch;
+use Carp;
+use strict;
+use vars qw($VERSION @Pref);
+$VERSION = '0.05';
+@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";
+}
+
+# there's a trick in Lincoln's package that determines the calling
+# package. The reason is to have a filehandle with the same name as
+# the filename. To tell this trick that we are not the calling
+# package we have to follow this dirty convention. It's a questionable
+# trick imho, but for now I want to have something working
+sub isaCGI { 1 }
+
+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 König E<lt>a.koenig@mind.deE<gt>
+
+=cut
diff --git a/gnu/usr.bin/perl/lib/CPAN.pm b/gnu/usr.bin/perl/lib/CPAN.pm
new file mode 100644
index 00000000000..2b0f6cce5dd
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/CPAN.pm
@@ -0,0 +1,3985 @@
+package CPAN;
+use vars qw{$Try_autoload $Revision
+ $META $Signal $Cwd $End
+ $Suppress_readline %Dontload
+ $Frontend
+ };
+
+$VERSION = '1.3102';
+
+# $Id: CPAN.pm,v 1.1 1997/11/30 07:56:39 millert Exp $
+
+# only used during development:
+$Revision = "";
+# $Revision = "[".substr(q$Revision: 1.1 $, 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
+ );
+
+$CPAN::DEBUG ||= 0;
+$CPAN::Signal ||= 0;
+$CPAN::Frontend ||= "CPAN::Shell";
+
+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)?$/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 {
+ &cleanup, $CPAN::Frontend->mydie("Goodbye\n") if $Signal;
+ }
+}
+
+package CPAN::CacheMgr;
+use vars qw($Du);
+@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(@_);
+ $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;
+
+$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 {
+ my $s = $Signal == 2 ? "a second" : "another";
+ &cleanup, $CPAN::Frontend->mydie("Got $s SIGINT") if $Signal;
+ $Signal = 1;
+ };
+ $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::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 check {
+# my($self,@dirs) = @_;
+# return unless -d $self->{ID};
+# my $dir;
+# @dirs = $self->dirs unless @dirs;
+# for $dir (@dirs) {
+# $self->disk_usage($dir);
+# }
+# }
+
+#-> sub CPAN::CacheMgr::clean_cache ;
+#=# sub clean_cache {
+#=# my $self = shift;
+#=# my $dir;
+#=# while ($self->{DU} > $self->{'MAX'} and $dir = shift @{$self->{FIFO}}) {
+#=# $self->force_clean_cache($dir);
+#=# }
+#=# $self->debug("leaving clean_cache with $self->{DU}") if $CPAN::DEBUG;
+#=# }
+
+#-> 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) = @_;
+# if (! defined $dir or $dir eq "") {
+# $self->debug("Cannot determine disk usage for some reason") if $CPAN::DEBUG;
+# return;
+# }
+ return if $self->{SIZE}{$dir};
+ local($Du) = 0;
+ find(
+ sub {
+ return if -l $_;
+ $Du += -s _;
+ },
+ $dir
+ );
+ $self->{SIZE}{$dir} = $Du/1024/1024;
+ push @{$self->{FIFO}}, $dir;
+ $self->debug("measured $dir is $Du") if $CPAN::DEBUG;
+ $self->{DU} += $Du/1024/1024;
+ if ($self->{DU} > $self->{'MAX'} ) {
+ my($toremove) = shift @{$self->{FIFO}};
+ $CPAN::Frontend->myprint(sprintf(
+ "...Hold on a sec... ".
+ "cleaning from cache ".
+ "(%.1f>%.1f MB): $toremove\n",
+ $self->{DU}, $self->{'MAX'})
+ );
+ $self->force_clean_cache($toremove);
+ }
+ $self->{DU};
+}
+
+#-> sub CPAN::CacheMgr::force_clean_cache ;
+sub force_clean_cache {
+ my($self,$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;
+ $self->debug("dir [$self->{ID}]") if $CPAN::DEBUG;
+ my $e;
+ for $e ($self->entries) {
+ next if $e eq ".." || $e eq ".";
+ $self->disk_usage($e);
+ }
+ $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
+ unshift @INC, MM->catdir($ENV{HOME},".cpan") unless $dot_cpan++;
+ eval {require CPAN::MyConfig;}; # where you can override
+ # system wide settings
+ 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 (
+ $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
+});
+ }
+}
+
+#-> 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:\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);
+ 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 "" };
+ }
+ }
+ for my $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 ;
+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::|) {
+ $obj = $CPAN::META->instance('CPAN::Bundle',$s);
+ } else {
+ $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
+ $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;
+}
+
+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|://([^/]+)|;
+ my $host = $1;
+ require Net::Ping;
+ return 1 unless $Net::Ping::VERSION >= 2;
+ my $p;
+ eval {$p = Net::Ping->new("icmp");};
+ eval {$p = Net::Ping->new("tcp");} if $@;
+ $CPAN::Frontend->mydie($@) if $@;
+ return $p->ping($host, 3);
+}
+
+#-> 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);
+#line 1621
+ $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
+ 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];
+ 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;
+ system("$CPAN::Config->{gzip} -dc $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 &&
+ system("$CPAN::Config->{gzip} -d $aslocal.gz")==0) {
+ $Thesite = $i;
+ return $aslocal;
+ } else {
+ next HOSTEASY ;
+ }
+ } else {
+ next HOSTEASY ;
+ }
+ }
+ 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:
+ $aslocal
+");
+ $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
+ $gz
+");
+ if (CPAN::FTP->ftp_get($host,
+ $dir,
+ "$getfile.gz",
+ $gz) &&
+ system("$CPAN::Config->{gzip} -d $gz")==0 ){
+ $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];
+ unless ($self->is_reachable($url)) {
+ $CPAN::Frontend->myprint("Skipping $url (not reachable)\n");
+ next;
+ }
+ $url .= "/" unless substr($url,-1) eq "/";
+ $url .= $file;
+ my($host,$dir,$getfile);
+ if ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ ($host,$dir,$getfile) = ($1,$2,$3);
+ } 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
+ $system =
+ "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed";
+ if (system($system) == 0) {
+ rename $aslocal_uncompressed, $aslocal;
+ } else {
+ $system =
+ "$CPAN::Config->{'gzip'} $aslocal_uncompressed";
+ system($system);
+ }
+ $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
+ $system =
+ "$CPAN::Config->{'gzip'} -dt $aslocal_uncompressed.gz";
+ $CPAN::Frontend->mywarn("system[$system]");
+ if (system($system) == 0) {
+ $system = "$CPAN::Config->{'gzip'} -dc ".
+ "$aslocal_uncompressed.gz > $aslocal";
+ $CPAN::Frontend->mywarn("system[$system]");
+ system($system);
+ } 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];
+ 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
+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;
+ my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
+ $CPAN::Frontend->myprint("Going to read $index_target\n");
+ my $fh = FileHandle->new("$pipe|");
+ 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;
+ }
+ $fh->close;
+ $? and Carp::croak "FAILED $pipe: exit status [$?]";
+}
+
+#-> sub CPAN::Index::rd_modpacks ;
+sub rd_modpacks {
+ my($cl,$index_target) = @_;
+ return unless defined $index_target;
+ my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
+ $CPAN::Frontend->myprint("Going to read $index_target\n");
+ my $fh = FileHandle->new("$pipe|");
+ while (<$fh>) {
+ last if /^\s*$/;
+ }
+ while (<$fh>) {
+ chomp;
+ my($mod,$version,$dist) = split;
+### $version =~ s/^\+//;
+
+ # if it as a bundle, instatiate a bundle object
+ my($bundle,$id,$userid);
+
+ if ($mod eq '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 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){
+ # determine the author
+ ($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;
+ }
+ $fh->close;
+ $? and Carp::croak "FAILED $pipe: exit status [$?]";
+}
+
+#-> sub CPAN::Index::rd_modlist ;
+sub rd_modlist {
+ my($cl,$index_target) = @_;
+ return unless defined $index_target;
+ my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
+ $CPAN::Frontend->myprint("Going to read $index_target\n");
+ my $fh = FileHandle->new("$pipe|");
+ my $eval;
+ while (<$fh>) {
+ if (/^Date:\s+(.*)/){
+ return if $date_of_03 eq $1;
+ ($date_of_03) = $1;
+ }
+ last if /^\s*$/;
+ }
+ local($/) = undef;
+ $eval = <$fh>;
+ $fh->close;
+ $eval .= q{CPAN::Modulelist->data;};
+ local($^W) = 0;
+ my($comp) = Safe->new("CPAN::Safe1");
+ 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 = "";
+ $_ eq "CPAN_USERID" and $extra = " (".$self->author.")";
+ if (ref($self->{$_}) eq "ARRAY") { # Should we setup a 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;
+ } 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.\n}.
+ qq{ Writing one on our own (calling it $cf)\n});
+ }
+ }
+ }
+ return $self;
+}
+
+sub untar_me {
+ my($self,$local_file) = @_;
+ $self->{archived} = "tar";
+ my $system = "$CPAN::Config->{gzip} --decompress --stdout " .
+ "$local_file | $CPAN::Config->{tar} xvf -";
+ if (system($system)== 0) {
+ $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)$//;
+ my $system = "$CPAN::Config->{gzip} --decompress --stdout ".
+ "$local_file > $to";
+ if (system($system) == 0) {
+ $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) {
+ my @system = ($CPAN::Config->{gzip}, '--decompress', $lc_file);
+ system(@system) == 0 or die "Could not uncompress $lc_file";
+ $lc_file =~ s/\.gz$//;
+ } 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 ($cksum->{$basename}->{md5}) {
+ $self->debug("Found checksum for $basename:" .
+ "$cksum->{$basename}->{md5}\n") if $CPAN::DEBUG;
+ my $pipe = "$CPAN::Config->{gzip} --decompress ".
+ "--stdout $file|";
+ if (
+ open($fh, $file) &&
+ binmode $fh &&
+ $self->eq_MD5($fh,$cksum->{$basename}->{md5})
+ or
+ open($fh, $pipe) &&
+ binmode $fh &&
+ $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'})
+ ){
+ $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;
+ $md5->addfile($fh);
+ my $hexdigest = $md5->hexdigest;
+ $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 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);
+ $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}";
+ }
+ {
+ 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
+ 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 {
+ $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 { shift->rematein('install',@_); }
+#-> 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)) {
+ push @m, sprintf(
+ $sprintf2,
+ 'CPAN_USERID',
+ $userid,
+ $author->fullname
+ );
+ }
+ }
+ 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 && ! exists $self->{MANPAGE}) {
+ my $fh = FileHandle->new($local_file)
+ or Carp::croak("Couldn't open $local_file: $!");
+ my $inpod = 0;
+ my(@result);
+ 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;
+ $self->{MANPAGE} = join " ", @result;
+ }
+ 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 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;
+ unless (defined $fullname) {
+ $CPAN::Frontend->mywarn(qq{Full name of author }.
+ qq{$self->{userid} not known});
+ return "Contact Author $self->{userid}";
+ }
+ return "Contact Author $self->{userid} ($fullname)"
+ } 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;
+ return if $cpan_file eq "N/A";
+ return if $cpan_file =~ /^Contact Author/;
+ 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;
+}
+#-> 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;
+
+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 most fun if
+you install Term::ReadKey and Term::ReadLine to enjoy both history and
+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 matching exact
+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 regualar 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, we display the result
+of 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 do indeed exist just as written above. Each of them
+takes any number of arguments and investigates for each what it might
+be. Is it a distribution file (recognized by embedded slashes), this
+file is being processed. Is it a module, CPAN determines the
+distribution file where this module is included and processes that.
+
+Any C<make>, C<test>, and C<readme> are run unconditionally. A
+
+ install <distribution_file>
+
+also is run unconditionally. But for
+
+ install <module>
+
+CPAN checks if an install is actually needed for it and prints
+I<Foo up to date> in case 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 first argument the
+method to invoke (currently: make, test, or 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
+ [...]
+
+=item readme, look module or distribution
+
+These two commands take only one argument, be it a module or a
+distribution file. C<readme> displays 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.
+
+=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. 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
+will be glad to run recompile in 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 hierarchie does
+matter for both users and programmer. CPAN.pm deals with above
+mentioned four classes, and all those classes share a set of
+methods. It is a classical single polymorphism that 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 not always is the default
+distribution for a given module the really hottest and newest. 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 in there. 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, 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
+(eg. 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.
+
+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 by 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 byproduct 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 how 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 that
+ 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 where keep the source (if we do)
+ make location of external program make
+ 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)
+
+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.
+
+=head1 AUTHOR
+
+Andreas König E<lt>a.koenig@mind.deE<gt>
+
+=head1 SEE ALSO
+
+perl(1), CPAN::Nox(3)
+
+=cut
+
diff --git a/gnu/usr.bin/perl/lib/CPAN/FirstTime.pm b/gnu/usr.bin/perl/lib/CPAN/FirstTime.pm
new file mode 100644
index 00000000000..ae09240c0f3
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/CPAN/FirstTime.pm
@@ -0,0 +1,402 @@
+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::Path ();
+use vars qw($VERSION);
+$VERSION = substr q$Revision: 1.1 $, 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($\) = "";
+
+ my($ans,$default,$local,$cont,$url,$expected_size);
+
+ #
+ # Files, directories
+ #
+
+ print qq{
+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 $prog;
+ for $prog (qw/gzip tar unzip make lynx ncftp ftp/){
+ my $path = $CPAN::Config->{$prog} || "";
+ if (MM->file_name_is_absolute($path)) {
+ warn "Warning: configured $path does not exist\n" unless -e $path;
+ $path = "";
+ } else {
+ $path = '';
+ }
+ $path ||= find_exe($prog,[@path]);
+ warn "Warning: $prog not found in PATH\n" unless -e $path;
+ $ans = prompt("Where is your $prog program?",$path) || $path;
+ $CPAN::Config->{$prog} = $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};
+ $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 inacivity during Makefile.PL?",$default);
+
+
+ #
+ # MIRRORED.BY
+ #
+
+ $local = 'MIRRORED.BY';
+ $local = MM->catfile($CPAN::Config->{keep_source_where},"MIRRORED.BY") unless -f $local;
+ if (@{$CPAN::Config->{urllist}||[]}) {
+ print qq{
+I found a list of URLs in CPAN::Config and will use this.
+You can change it later with the 'o conf urllist' command.
+
+}
+ } elsif (
+ -s $local
+ &&
+ -M $local < 30
+ ) {
+ read_mirrored_by($local);
+ } else {
+ $CPAN::Config->{urllist} ||= [];
+ while (! @{$CPAN::Config->{urllist}}) {
+ my($input) = prompt(qq{
+We need to know the URL of your favorite CPAN site.
+Please enter it here:});
+ $input =~ s/\s//g;
+ next unless $input;
+ my($wanted) = "MIRRORED.BY";
+ print qq{
+Testing "$input" ...
+};
+ push @{$CPAN::Config->{urllist}}, $input;
+ CPAN::FTP->localize($wanted,$local,"force");
+ if (-s $local) {
+ print qq{
+"$input" seems to work
+};
+ } else {
+ my $ans = prompt(qq{$input doesn\'t seem to work. Keep it in the list?},"n");
+ last unless $ans =~ /^n/i;
+ pop @{$CPAN::Config->{urllist}};
+ }
+ }
+ }
+
+ 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;
+ }
+
+ 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);
+ }
+
+ # 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 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 (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(
+ " %-18s (%2d) %s\n",
+ $country,
+ ++$item,
+ $url
+ );
+ if ($cont =~ /^\[/) {
+ $previous_best ||= $item;
+ }
+ push @valid, $all{$cont}{$country}{$url};
+ $fh->print($t);
+ }
+ }
+ }
+ }
+ $fh->close;
+ $previous_best ||= 1;
+ $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 (@{$CPAN::Config->{urllist}} && $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/gnu/usr.bin/perl/lib/CPAN/Nox.pm b/gnu/usr.bin/perl/lib/CPAN/Nox.pm
new file mode 100644
index 00000000000..23ad760b87b
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/CPAN/Nox.pm
@@ -0,0 +1,33 @@
+BEGIN{$CPAN::Suppress_readline=1 unless defined $CPAN::term;}
+
+use CPAN;
+
+$CPAN::META->has_inst('MD5','no');
+$CPAN::META->has_inst('LWP','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/gnu/usr.bin/perl/lib/Carp.pm b/gnu/usr.bin/perl/lib/Carp.pm
index f30bd24135c..685a7933d05 100644
--- a/gnu/usr.bin/perl/lib/Carp.pm
+++ b/gnu/usr.bin/perl/lib/Carp.pm
@@ -2,9 +2,12 @@ package Carp;
=head1 NAME
-carp - warn of errors (from perspective of caller)
+carp - warn of errors (from perspective of caller)
-croak - die 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
@@ -13,6 +16,9 @@ confess - die of errors with stack backtrace
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
@@ -22,24 +28,55 @@ 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 implements handy routines for modules that wish to throw
-# exceptions outside of the current package.
+# This package is heavily used. Be small. Be fast. Be good.
$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.
require Exporter;
-@ISA = Exporter;
+@ISA = ('Exporter');
@EXPORT = qw(confess croak carp);
+@EXPORT_OK = qw(cluck verbose);
+@EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
+
+sub export_fail {
+ shift;
+ if ($_[0] eq 'verbose') {
+ local $^W = 0;
+ *shortmess = \&longmess;
+ shift;
+ }
+ return @_;
+}
+
sub longmess {
- my $error = shift;
+ my $error = join '', @_;
my $mess = "";
my $i = 1 + $CarpLevel;
- my ($pack,$file,$line,$sub,$eval,$require);
- while (($pack,$file,$line,$sub,undef,undef,$eval,$require) = caller($i++)) {
+ my ($pack,$file,$line,$sub,$hargs,$eval,$require);
+ my (@a);
+ while (do { { package DB; @a = caller($i++) } } ) {
+ ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
if ($error =~ m/\n$/) {
$mess .= $error;
} else {
@@ -47,7 +84,7 @@ sub longmess {
if ($require) {
$sub = "require $eval";
} else {
- $eval =~ s/[\\\']/\\$&/g;
+ $eval =~ s/([\\\'])/\\$1/g;
if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
substr($eval,$MaxEvalLen) = '...';
}
@@ -56,35 +93,84 @@ sub longmess {
} elsif ($sub eq '(eval)') {
$sub = 'eval {...}';
}
+ if ($hargs) {
+ @a = @DB::args; # must get local copy of args
+ if ($MaxArgNums and @a > $MaxArgNums) {
+ $#a = $MaxArgNums;
+ $a[$#a] = "...";
+ }
+ for (@a) {
+ $_ = "undef", next unless defined $_;
+ if (ref $_) {
+ $_ .= '';
+ s/'/\\'/g;
+ }
+ else {
+ s/'/\\'/g;
+ substr($_,$MaxArgLen) = '...'
+ if $MaxArgLen and $MaxArgLen < length;
+ }
+ $_ = "'$_'" unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ $sub .= '(' . join(', ', @a) . ')';
+ }
$mess .= "\t$sub " if $error eq "called";
$mess .= "$error at $file line $line\n";
}
$error = "called";
}
- $mess || $error;
+ # this kludge circumvents die's incorrect handling of NUL
+ my $msg = \($mess || $error);
+ $$msg =~ tr/\0//d;
+ $$msg;
}
sub shortmess { # Short-circuit &longmess if called via multiple packages
- my $error = $_[0]; # Instead of "shift"
- my ($curpack) = caller(1);
+ my $error = join '', @_;
+ my ($prevpack) = caller(1);
my $extra = $CarpLevel;
my $i = 2;
my ($pack,$file,$line);
+ my %isa = ($prevpack,1);
+
+ @isa{@{"${prevpack}::ISA"}} = ()
+ if(defined @{"${prevpack}::ISA"});
+
while (($pack,$file,$line) = caller($i++)) {
- if ($pack ne $curpack) {
- if ($extra-- > 0) {
- $curpack = $pack;
- }
- else {
- return "$error at $file line $line\n";
- }
+ if(defined @{$pack . "::ISA"}) {
+ my @i = @{$pack . "::ISA"};
+ my %i;
+ @i{@i} = ();
+ @isa{@i,$pack} = ()
+ if(exists $i{$prevpack} || exists $isa{$pack});
+ }
+
+ next
+ if(exists $isa{$pack});
+
+ if ($extra-- > 0) {
+ %isa = ($pack,1);
+ @isa{@{$pack . "::ISA"}} = ()
+ if(defined @{$pack . "::ISA"});
+ }
+ else {
+ # this kludge circumvents die's incorrect handling of NUL
+ (my $msg = "$error at $file line $line\n") =~ tr/\0//d;
+ return $msg;
}
}
+ continue {
+ $prevpack = $pack;
+ }
+
goto &longmess;
}
sub confess { die longmess @_; }
sub croak { die shortmess @_; }
sub carp { warn shortmess @_; }
+sub cluck { warn longmess @_; }
1;
diff --git a/gnu/usr.bin/perl/lib/Class/Struct.pm b/gnu/usr.bin/perl/lib/Class/Struct.pm
new file mode 100644
index 00000000000..09ab196254e
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Class/Struct.pm
@@ -0,0 +1,479 @@
+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 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], '$type');\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/gnu/usr.bin/perl/lib/Cwd.pm b/gnu/usr.bin/perl/lib/Cwd.pm
index bee2e179aef..3bd0085c730 100644
--- a/gnu/usr.bin/perl/lib/Cwd.pm
+++ b/gnu/usr.bin/perl/lib/Cwd.pm
@@ -1,6 +1,5 @@
package Cwd;
require 5.000;
-require Exporter;
=head1 NAME
@@ -27,33 +26,49 @@ The getcwd() function re-implements the getcwd(3) (or getwd(3)) functions
in Perl.
The fastcwd() function looks the same as getcwd(), but runs faster.
-It's also more dangerous because you might conceivably chdir() out of a
-directory that you can't chdir() back into.
+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 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.
+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 it all packages which use chdir import it from Cwd.
+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.00';
+
+require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(cwd getcwd fastcwd fastgetcwd);
-@EXPORT_OK = qw(chdir);
+@EXPORT_OK = qw(chdir abs_path fast_abs_path);
+
-# use strict;
+# The 'natural and safe form' for UNIX (pwd may be setuid root)
-sub _backtick_pwd { # 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().
@@ -94,7 +109,7 @@ sub getcwd
}
if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
{
- $dir = '';
+ $dir = undef;
}
else
{
@@ -108,7 +123,7 @@ sub getcwd
}
unless (@tst = lstat("$dotdots/$dir"))
{
- warn "lstat($dotdots/$dir): $!";
+ # warn "lstat($dotdots/$dir): $!";
# Just because you can't lstat this directory
# doesn't mean you'll never find the right one.
# closedir(PARENT);
@@ -118,10 +133,10 @@ sub getcwd
while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
$tst[1] != $pst[1]);
}
- $cwd = "$dir/$cwd";
+ $cwd = (defined $dir ? "$dir" : "" ) . "/$cwd" ;
closedir(PARENT);
- } while ($dir);
- chop($cwd); # drop the trailing /
+ } while (defined $dir);
+ chop($cwd) unless $cwd eq '/'; # drop the trailing /
$cwd;
}
@@ -133,33 +148,45 @@ sub getcwd
#
# 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);
- ($cdev, $cino) = stat('.');
+ my($orig_cdev, $orig_cino) = stat('.');
+ ($cdev, $cino) = ($orig_cdev, $orig_cino);
for (;;) {
my $direntry;
($odev, $oino) = ($cdev, $cino);
- chdir('..');
+ chdir('..') || return undef;
($cdev, $cino) = stat('.');
last if $odev == $cdev && $oino == $cino;
- opendir(DIR, '.');
+ opendir(DIR, '.') || return undef;
for (;;) {
$direntry = readdir(DIR);
+ last unless defined $direntry;
next if $direntry eq '.';
next if $direntry eq '..';
- last unless defined $direntry;
($tdev, $tino) = lstat($direntry);
last unless $tdev != $odev || $tino != $oino;
}
closedir(DIR);
+ return undef unless defined $direntry; # should never happen
unshift(@path, $direntry);
}
- chdir($path = '/' . join('/', @path));
+ $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
+ chdir($path) || return undef;
+ ($cdev, $cino) = stat('.');
+ die "Unstable directory path, current directory changed unexpectedly"
+ if $cdev != $orig_cdev || $cino != $orig_cino;
$path;
}
@@ -172,7 +199,7 @@ sub fastcwd {
my $chdir_init = 0;
sub chdir_init {
- if ($ENV{'PWD'} and $^O ne 'os2') {
+ if ($ENV{'PWD'} and $^O ne 'os2' and $^O ne 'msdos') {
my($dd,$di) = stat('.');
my($pd,$pi) = stat($ENV{'PWD'});
if (!defined $dd or !defined $pd or $di != $pi or $dd != $pd) {
@@ -216,20 +243,94 @@ sub chdir {
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 = '';
+ }
+ 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 = "$dir/$cwd";
+ closedir(PARENT);
+ } while ($dir);
+ chop($cwd); # drop the trailing /
+ $cwd;
+}
+
+sub fast_abs_path {
+ my $cwd = getcwd();
+ my $path = shift || '.';
+ chdir($path) || croak "Cannot chdir to $path:$!";
+ my $realpath = getcwd();
+ 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
+# 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'}
+ 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'};
@@ -237,27 +338,59 @@ sub _os2_cwd {
return $ENV{'PWD'};
}
-my($oldw) = $^W;
-$^W = 0; # assignments trigger 'subroutine redefined' warning
-if ($^O eq 'VMS') {
-
- *cwd = \&_vms_cwd;
- *getcwd = \&_vms_cwd;
- *fastcwd = \&_vms_cwd;
- *fastgetcwd = \&_vms_cwd;
+sub _win32_cwd {
+ $ENV{'PWD'} = Win32::GetCurrentDirectory();
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
}
-elsif ($^O eq 'NT') {
- *getcwd = \&cwd;
- *fastgetcwd = \&cwd;
+*_NT_cwd = \&_win32_cwd if (!defined &_NT_cwd &&
+ defined &Win32::GetCurrentDirectory);
+
+*_NT_cwd = \&_os2_cwd unless defined &_NT_cwd;
+
+sub _msdos_cwd {
+ $ENV{'PWD'} = `command /c cd`;
+ chop $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
}
-elsif ($^O eq 'os2') {
- *cwd = \&_os2_cwd;
- *getcwd = \&_os2_cwd;
- *fastgetcwd = \&_os2_cwd;
- *fastcwd = \&_os2_cwd;
+
+{
+ 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 'msdos') {
+ *cwd = \&_msdos_cwd;
+ *getcwd = \&_msdos_cwd;
+ *fastgetcwd = \&_msdos_cwd;
+ *fastcwd = \&_msdos_cwd;
+ *abs_path = \&fast_abs_path;
+ }
}
-$^W = $oldw;
# package main; eval join('',<DATA>) || die $@; # quick test
diff --git a/gnu/usr.bin/perl/lib/Devel/SelfStubber.pm b/gnu/usr.bin/perl/lib/Devel/SelfStubber.pm
index fc7ee4b5110..4c2d0395803 100644
--- a/gnu/usr.bin/perl/lib/Devel/SelfStubber.pm
+++ b/gnu/usr.bin/perl/lib/Devel/SelfStubber.pm
@@ -35,7 +35,7 @@ sub stub {
$fh = "${module}::DATA";
open($fh,$mod_file) || die "Unable to open $mod_file";
- while($line = <$fh> and $line !~ m/^__DATA__/) {
+ while(defined ($line = <$fh>) and $line !~ m/^__DATA__/) {
push(@BEFORE_DATA,$line);
$line =~ /use\s+SelfLoader/ && $found_selfloader++;
}
@@ -45,7 +45,7 @@ sub stub {
$self->_load_stubs($module);
if ( fileno($fh) ) {
$end = 1;
- while($line = <$fh>) {
+ while(defined($line = <$fh>)) {
push(@AFTER_DATA,$line);
}
}
@@ -118,7 +118,7 @@ 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->load_stubs()';, but you may wish to
+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
diff --git a/gnu/usr.bin/perl/lib/English.pm b/gnu/usr.bin/perl/lib/English.pm
index ce4520a8911..bbb6bd7b280 100644
--- a/gnu/usr.bin/perl/lib/English.pm
+++ b/gnu/usr.bin/perl/lib/English.pm
@@ -92,7 +92,7 @@ sub import {
*OSNAME
);
-# The ground of all being.
+# The ground of all being. @ARG is deprecated (5.005 makes @_ lexical)
*ARG = *_ ;
@@ -138,8 +138,8 @@ sub import {
*CHILD_ERROR = *? ;
*OS_ERROR = *! ;
- *EXTENDED_OS_ERROR = *^E ;
*ERRNO = *! ;
+ *EXTENDED_OS_ERROR = *^E ;
*EVAL_ERROR = *@ ;
# Process info.
diff --git a/gnu/usr.bin/perl/lib/Env.pm b/gnu/usr.bin/perl/lib/Env.pm
index 0e790754a82..f2fe4af422e 100644
--- a/gnu/usr.bin/perl/lib/Env.pm
+++ b/gnu/usr.bin/perl/lib/Env.pm
@@ -11,10 +11,9 @@ Env - perl module that imports environment variables
=head1 DESCRIPTION
-Perl maintains environment variables in a pseudo-associative-array
-named %ENV. For when this access method is inconvenient, the Perl
-module C<Env> allows environment variables to be treated as simple
-variables.
+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
@@ -39,7 +38,7 @@ the environment, assign it the undefined value
=head1 AUTHOR
-Chip Salzenberg <chip@fin.uucp>
+Chip Salzenberg E<lt>F<chip@fin.uucp>E<gt>
=cut
@@ -47,7 +46,11 @@ sub import {
my ($callpack) = caller(0);
my $pack = shift;
my @vars = @_ ? @_ : keys(%ENV);
+ return unless @vars;
+ eval "package $callpack; use vars qw("
+ . join(' ', map { '$'.$_ } @vars) . ")";
+ die $@ if $@;
foreach (@vars) {
tie ${"${callpack}::$_"}, Env, $_ if /^[A-Za-z_]\w*$/;
}
diff --git a/gnu/usr.bin/perl/lib/Exporter.pm b/gnu/usr.bin/perl/lib/Exporter.pm
index 343b9fbd174..3f42e407e0b 100644
--- a/gnu/usr.bin/perl/lib/Exporter.pm
+++ b/gnu/usr.bin/perl/lib/Exporter.pm
@@ -2,21 +2,31 @@ 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;
-require Carp;
-
sub export {
# First make import warnings look like they're coming from the "use".
local $SIG{__WARN__} = sub {
my $text = shift;
- $text =~ s/ at \S*Exporter.pm line \d+.*\n//;
- local $Carp::CarpLevel = 1; # ignore package calling us too.
- Carp::carp($text);
+ 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 "(.*?)::"/;
};
@@ -91,13 +101,23 @@ sub export {
@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}) {
- warn qq["$sym" is not exported by the $pkg module];
+ require Carp;
+ Carp::carp(qq["$sym" is not exported by the $pkg module]);
$oops++;
}
}
}
- Carp::croak("Can't continue after import errors") if $oops;
+ if ($oops) {
+ require Carp;
+ Carp::croak("Can't continue after import errors");
+ }
}
else {
@imports = @exports;
@@ -118,10 +138,14 @@ sub export {
if (@failed) {
@failed = $pkg->export_fail(@failed);
foreach $sym (@failed) {
- warn qq["$sym" is not implemented by the $pkg module ],
- "on this architecture";
+ 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");
}
- Carp::croak("Can't continue after import errors") if @failed;
}
}
@@ -139,10 +163,19 @@ sub export {
$type eq '@' ? \@{"${pkg}::$sym"} :
$type eq '%' ? \%{"${pkg}::$sym"} :
$type eq '*' ? *{"${pkg}::$sym"} :
- Carp::croak("Can't export symbol: $type$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);
@@ -150,6 +183,7 @@ sub import {
}
+
# Utility functions
sub _push_tags {
@@ -159,8 +193,11 @@ sub _push_tags {
push(@{"${pkg}::$var"},
map { $export_tags{$_} ? @{$export_tags{$_}} : scalar(++$nontag,$_) }
(@$syms) ? @$syms : keys %export_tags);
- # This may change to a die one day
- Carp::carp("Some names are not tags") if $nontag and $^W;
+ 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", \@_) }
@@ -170,15 +207,21 @@ 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"} || "(undef)";
- Carp::croak("$pkg $wanted required--this is only version $version")
- if $version < $wanted;
+ 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;
}
@@ -235,7 +278,7 @@ In other files which wish to use ModuleName:
=head1 DESCRIPTION
The Exporter module implements a default C<import> method which
-many modules choose inherit rather than implement their own.
+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
@@ -254,7 +297,7 @@ 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->method)
+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.
@@ -315,10 +358,57 @@ 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->require_version($value). This can
+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.
@@ -339,7 +429,7 @@ 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
+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:
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Command.pm b/gnu/usr.bin/perl/lib/ExtUtils/Command.pm
new file mode 100644
index 00000000000..d37d0f3c25e
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/ExtUtils/Command.pm
@@ -0,0 +1,208 @@
+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();
+ while (@ARGV)
+ {
+ my $file = shift(@ARGV);
+ open(FILE,">>$file") || die "Cannot write $file:$!";
+ close(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/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm b/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm
new file mode 100644
index 00000000000..04ce1763da7
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/ExtUtils/Embed.pm
@@ -0,0 +1,486 @@
+# $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 xsinit {
+ my($file, $std, $mods) = @_;
+ my($fh,@mods,%seen);
+ $file ||= "perlxsi.c";
+
+ 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 _((void));\n\n";
+ print $fh &xsi_protos(@mods);
+
+ print $fh "\nEXTERN_C void\nxs_init()\n{\n";
+ print $fh &xsi_body(@mods);
+ print $fh "}\n";
+
+}
+
+sub xsi_header {
+ return <<EOF;
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include <EXTERN.h>
+#include <perl.h>
+
+#ifdef __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);
+
+ foreach $_ (@exts){
+ my($pname) = canon('/', $_);
+ my($mname, $cname);
+ ($mname = $pname) =~ s!/!::!g;
+ ($cname = $pname) =~ s!/!__!g;
+ my($ccode) = "EXTERN_C void boot_${cname} _((CV* cv));\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/gnu/usr.bin/perl/lib/ExtUtils/Install.pm b/gnu/usr.bin/perl/lib/ExtUtils/Install.pm
index 5a0ed7ab2ca..2c1dd8ae341 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/Install.pm
+++ b/gnu/usr.bin/perl/lib/ExtUtils/Install.pm
@@ -1,18 +1,18 @@
package ExtUtils::Install;
-$VERSION = substr q$Revision: 1.1.1.1 $, 10;
-# $Id: Install.pm,v 1.1.1.1 1996/08/19 10:12:39 downsj Exp $
+$VERSION = substr q$Revision: 1.2 $, 10;
+# $Date: 1997/11/30 07:57:24 $
use Exporter;
use Carp ();
-use Config ();
+use Config qw(%Config);
use vars qw(@ISA @EXPORT $VERSION);
@ISA = ('Exporter');
-@EXPORT = ('install','uninstall','pm_to_blib');
+@EXPORT = ('install','uninstall','pm_to_blib', 'install_default');
$Is_VMS = $^O eq 'VMS';
my $splitchar = $^O eq 'VMS' ? '|' : $^O eq 'os2' ? ';' : ':';
-my @PERL_ENV_LIB = split $splitchar, defined $ENV{'PERL5LIB'} ? $ENV{'PERL5LIB'} : $ENV{'PERLLIB'};
+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 );
@@ -34,16 +34,12 @@ sub install {
use File::Copy qw(copy);
use File::Find qw(find);
use File::Path qw(mkpath);
- # The following lines were needed with AutoLoader (left for the record)
- # my $my_req = $self->catfile(qw(auto ExtUtils Install my_cmp.al));
- # require $my_req;
- # $my_req = $self->catfile(qw(auto ExtUtils Install forceunlink.al));
- # require $my_req; # Hairy, but for the first
- # time use we are in a different directory when autoload happens, so
- # the relativ path to ./blib is ill.
+ use File::Compare qw(compare);
my(%hash) = %$hash;
- my(%pack, %write, $dir);
+ my(%pack, %write, $dir, $warn_permissions);
+ # -w doesn't work reliably on FAT dirs
+ $warn_permissions++ if $^O eq 'MSWin32';
local(*DIR, *P);
for (qw/read write/) {
$pack{$_}=$hash{$_};
@@ -59,7 +55,8 @@ sub install {
if (-w $hash{$source_dir_or_file} || mkpath($hash{$source_dir_or_file})) {
last;
} else {
- Carp::croak("You do not have permissions to install into $hash{$source_dir_or_file}");
+ warn "Warning: You do not have permissions to install into $hash{$source_dir_or_file}"
+ unless $warn_permissions++;
}
}
closedir DIR;
@@ -100,7 +97,7 @@ sub install {
my $diff = 0;
if ( -f $targetfile && -s _ == $size) {
# We have a good chance, we can skip this one
- $diff = my_cmp($_,$targetfile);
+ $diff = compare($_,$targetfile);
} else {
print "$_ differs\n" if $verbose>1;
$diff++;
@@ -148,30 +145,26 @@ sub install {
}
}
-sub my_cmp {
- my($one,$two) = @_;
- local(*F,*T);
- my $diff = 0;
- open T, $two or return 1;
- open F, $one or Carp::croak("Couldn't open $one: $!");
- my($fr, $tr, $fbuf, $tbuf, $size);
- $size = 1024;
- # print "Reading $one\n";
- while ( $fr = read(F,$fbuf,$size)) {
- unless (
- $tr = read(T,$tbuf,$size) and
- $tbuf eq $fbuf
- ){
- # print "diff ";
- $diff++;
- last;
- }
- # print "$fr/$tr ";
- }
- # print "\n";
- close F;
- close T;
- $diff;
+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 => $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 {
@@ -196,7 +189,7 @@ sub inc_uninstall {
my $MY = {};
bless $MY, 'MY';
my %seen_dir = ();
- foreach $dir (@INC, @PERL_ENV_LIB, @Config::Config{qw/archlibexp privlibexp sitearchexp sitelibexp/}) {
+ 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);
@@ -208,7 +201,7 @@ sub inc_uninstall {
my $diff = 0;
if ( -f $targetfile && -s _ == -s $file) {
# We have a good chance, we can skip this one
- $diff = my_cmp($file,$targetfile);
+ $diff = compare($file,$targetfile);
} else {
print "#$file and $targetfile differ\n" if $verbose>1;
$diff++;
@@ -235,15 +228,27 @@ sub pm_to_blib {
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 (my_cmp($_,$fromto->{$_})){
+ unless (compare($_,$fromto->{$_})){
print "Skip $fromto->{$_} (unchanged)\n";
next;
}
@@ -253,7 +258,9 @@ sub pm_to_blib {
mkpath(dirname($fromto->{$_}),0,0755);
}
copy($_,$fromto->{$_});
- chmod(0444 | ( (stat)[2] & 0111 ? 0111 : 0 ),$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);
@@ -318,12 +325,26 @@ 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 $hashref->{write}. If there is
-another file named by $hashref->{read}, the contents of this file will
+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.
@@ -334,4 +355,3 @@ the extension pm are autosplit. Second argument is the autosplit
directory.
=cut
-
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm b/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm
index 103aa167be3..5b4d6abecb4 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm
+++ b/gnu/usr.bin/perl/lib/ExtUtils/Liblist.pm
@@ -1,17 +1,21 @@
package ExtUtils::Liblist;
-
+use vars qw($VERSION);
# Broken out of MakeMaker from version 4.11
-$ExtUtils::Liblist::VERSION = substr q$Revision: 1.1.1.1 $, 10;
+$VERSION = substr q$Revision: 1.2 $, 10;
use Config;
use Cwd 'cwd';
use File::Basename;
-my $Config_libext = $Config{lib_ext} || ".a";
-
sub ext {
- my($self,$potential_libs, $Verbose) = @_;
+ 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.
@@ -20,15 +24,16 @@ sub ext {
$potential_libs .= $Config{libs};
}
return ("", "", "", "") unless $potential_libs;
- print STDOUT "Potential libraries are '$potential_libs':\n" if $Verbose;
+ 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
- # its home is in <distribution>/ext/util
my(@searchpath); # from "-L/path" entries in $potential_libs
my(@libpath) = split " ", $Config{'libpth'};
@@ -43,12 +48,12 @@ sub ext {
if ($thislib =~ s/^(-[LR])//){ # save path flag type
my($ptype) = $1;
unless (-d $thislib){
- print STDOUT "$ptype$thislib ignored, directory does not exist\n"
- if $Verbose;
+ warn "$ptype$thislib ignored, directory does not exist\n"
+ if $verbose;
next;
}
unless ($self->file_name_is_absolute($thislib)) {
- print STDOUT "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n";
+ warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n";
$thislib = $self->catdir($pwd,$thislib);
}
push(@searchpath, $thislib);
@@ -59,7 +64,7 @@ sub ext {
# Handle possible library arguments.
unless ($thislib =~ s/^-l//){
- print STDOUT "Unrecognized argument in LIBS ignored: '$thislib'\n";
+ warn "Unrecognized argument in LIBS ignored: '$thislib'\n";
next;
}
@@ -72,7 +77,8 @@ sub ext {
# 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,"^lib$thislib\.$so\.[0-9]+")){
+ 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
@@ -118,10 +124,10 @@ sub ext {
#
# , the compilation tools expand the environment variables.)
} else {
- print STDOUT "$thislib not found in $thispth\n" if $Verbose;
+ warn "$thislib not found in $thispth\n" if $verbose;
next;
}
- print STDOUT "'-l$thislib' found at $fullname\n" if $Verbose;
+ 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++;
@@ -135,15 +141,18 @@ sub ext {
# 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 all the math
- # is also in libsys_s
+ # We have to special-case the NeXT, because math and ndbm
+ # are both in libsys_s
unless ($in_perl ||
- ($^O eq 'next' && $thislib eq 'm') ){
+ ($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|dl_dld/){
+ 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
@@ -164,13 +173,223 @@ sub ext {
}
last; # found one here so don't bother looking further
}
- print STDOUT "Warning (will try anyway): No library found for -l$thislib\n"
+ 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 {
+ 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($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;
+
+ # compute $extralibs from $potential_libs
+
+ my(@searchpath); # from "-L/path" entries in $potential_libs
+ my(@libpath) = split " ", $libpth;
+ my(@extralibs);
+ my($fullname, $thislib, $thispth);
+ my($pwd) = cwd(); # from Cwd.pm
+ my($lib) = '';
+ my($found) = 0;
+
+ foreach $thislib (split ' ', $potential_libs){
+
+ # Handle possible linker path arguments.
+ if ($thislib =~ s/^-L// and not -d $thislib) {
+ warn "-L$thislib ignored, directory does not exist\n"
+ if $verbose;
+ next;
+ }
+ elsif (-d $thislib) {
+ unless ($self->file_name_is_absolute($thislib)) {
+ warn "Warning: -L$thislib changed to -L$pwd/$thislib\n";
+ $thislib = $self->catdir($pwd,$thislib);
+ }
+ push(@searchpath, $thislib);
+ next;
+ }
+
+ # Handle possible library arguments.
+ $thislib =~ s/^-l//;
+ $thislib .= $libext if $thislib !~ /\Q$libext\E$/i;
+
+ my($found_lib)=0;
+ foreach $thispth (@searchpath, @libpath){
+ unless (-f ($fullname="$thispth\\$thislib")) {
+ warn "$thislib not found in $thispth\n" if $verbose;
+ next;
+ }
+ warn "'$thislib' found at $fullname\n" if $verbose;
+ $found++;
+ $found_lib++;
+ push(@extralibs, $fullname);
+ last;
+ }
+ warn "Note (probably harmless): "
+ ."No library found for '$thislib'\n"
+ unless $found_lib>0;
+ }
+ return ('','','','') unless $found;
+ $lib = join(' ',@extralibs);
+ warn "Result: $lib\n" if $verbose;
+ wantarray ? ($lib, '', $lib, '') : $lib;
+}
+
+
+sub _vms_ext {
+ my($self, $potential_libs,$verbose) = @_;
+ return ('', '', '', '') unless $potential_libs;
+
+ my(@dirs,@libs,$dir,$lib,%sh,%olb,%obj);
+ 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);
+ warn "Result: $lib\n" if $verbose;
+ wantarray ? ($lib, '', $lib, '') : $lib;
+}
+
1;
__END__
@@ -183,7 +402,7 @@ ExtUtils::Liblist - determine libraries to use and how to use them
C<require ExtUtils::Liblist;>
-C<ExtUtils::Liblist::ext($potential_libs, $Verbose);>
+C<ExtUtils::Liblist::ext($self, $potential_libs, $verbose);>
=head1 DESCRIPTION
@@ -194,7 +413,9 @@ 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.
+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:
@@ -244,11 +465,107 @@ object file. This list is used to create a .bs (bootstrap) file.
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 and EXTRALIBS are always identical under VMS, and BSLOADLIBS
+and LD_RIN_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 *
+
+Input library and path specifications are accepted with or without the
+C<-l> and C<-L> prefices used by Unix linkers. C<-lfoo> specifies the
+library C<foo.lib> and C<-Ls:ome\dir> specifies a directory to look for
+the libraries that follow. 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. The C<$Config{lib_ext}> suffix will
+be appended to any entries that are not directories and don't already
+have the suffix. 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 *
+
+Entries cannot be plain object files, as many Win32 compilers will
+not handle object files in the place of libraries.
+
+=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.
+You may specify an entry that matches C</:nodefault/i> in
+C<$potential_libs> to disable the appending of default libraries
+found in C<$Config{libs}> (this should be only needed very rarely).
+
+=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).
+
+=back
+
+
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
-
-
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm
index 1a1f8b16a04..65abfc2d99c 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm
+++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_OS2.pm
@@ -54,6 +54,17 @@ sub file_name_is_absolute {
$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__
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm
index 332a6c6912c..b308c4aad6f 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm
+++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_Unix.pm
@@ -1,18 +1,22 @@
package ExtUtils::MM_Unix;
-$VERSION = substr q$Revision: 1.2 $, 10;
-# $Id: MM_Unix.pm,v 1.2 1996/10/04 08:51:44 downsj Exp $
-
-require Exporter;
+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
+ $Verbose %pm %static $Xsubpp_Version);
+
+$VERSION = substr q$Revision: 1.3 $, 10;
+# $Id: MM_Unix.pm,v 1.3 1997/11/30 07:57:26 millert Exp $
Exporter::import('ExtUtils::MakeMaker',
qw( $Verbose &neatvalue));
-$Is_OS2 = $^O =~ m|^os/?2$|i;
-$Is_Mac = $^O eq "MacOS";
+$Is_OS2 = $^O eq 'os2';
+$Is_Mac = $^O eq 'MacOS';
+$Is_Win32 = $^O eq 'MSWin32';
if ($Is_VMS = $^O eq 'VMS') {
require VMS::Filespec;
@@ -40,8 +44,8 @@ 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 primitiv methods, and if it is not
-possible to do so, let's work it out how to achieve that gain.
+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
@@ -97,12 +101,12 @@ sub catdir {
my @args = @_;
for (@args) {
# append a slash to each argument unless it has one there
- $_ .= "/" unless substr($_,length($_)-1,1) eq "/";
+ $_ .= "/" if $_ eq '' or substr($_,-1) ne "/";
}
my $result = join('', @args);
# remove a trailing slash unless we are root
- substr($result,length($result)-1,1) = ""
- if length($result) > 1 && substr($result,length($result)-1,1) eq "/";
+ substr($result,-1) = ""
+ if length($result) > 1 && substr($result,-1) eq "/";
$result;
}
@@ -173,9 +177,11 @@ 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 ;
@@ -198,6 +204,7 @@ 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 ;
@@ -227,13 +234,18 @@ sub ExtUtils::MM_Unix::xsubpp_version ;
package ExtUtils::MM_Unix;
-#use SelfLoader;
+use SelfLoader;
1;
-#__DATA__
+
+__DATA__
+
+=back
=head2 SelfLoaded methods
+=over 2
+
=item c_o (o)
Defines the suffix rules to compile different flavors of C files to
@@ -250,10 +262,12 @@ sub c_o {
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'; # Case-specific
+ push @m, '
.cpp$(OBJ_EXT):
$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cpp
@@ -385,7 +399,7 @@ clean ::
');
# clean subdirectories first
for $dir (@{$self->{DIR}}) {
- push @m, "\t-cd $dir && test -f $self->{MAKEFILE} && \$(MAKE) clean\n";
+ push @m, "\t-cd $dir && \$(TEST_F) $self->{MAKEFILE} && \$(MAKE) clean\n";
}
my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files
@@ -399,7 +413,7 @@ clean ::
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 2>/dev/null\n");
+ "\t-$self->{MV} $self->{MAKEFILE} $self->{MAKEFILE}.old \$(DEV_NULL)\n");
push(@m,
"\t$attribs{POSTOP}\n") if $attribs{POSTOP};
join("", @m);
@@ -486,7 +500,7 @@ sub constants {
AR_STATIC_ARGS NAME DISTNAME NAME_SYM VERSION
VERSION_SYM XS_VERSION INST_BIN INST_EXE INST_LIB
- INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS
+ INST_ARCHLIB INST_SCRIPT PREFIX INSTALLDIRS
INSTALLPRIVLIB INSTALLARCHLIB INSTALLSITELIB
INSTALLSITEARCH INSTALLBIN INSTALLSCRIPT PERL_LIB
PERL_ARCHLIB SITELIBEXP SITEARCHEXP LIBPERL_A MYEXTLIB
@@ -590,20 +604,11 @@ INST_BOOT =
';
}
- if ($Is_OS2) {
- $tmp = "$self->{BASEEXT}.def";
- } else {
- $tmp = "";
- }
+ $tmp = $self->export_list;
push @m, "
EXPORT_LIST = $tmp
";
-
- if ($Is_OS2) {
- $tmp = "\$(PERL_INC)/libperl\$(LIB_EXT)";
- } else {
- $tmp = "";
- }
+ $tmp = $self->perl_archive;
push @m, "
PERL_ARCHIVE = $tmp
";
@@ -659,12 +664,17 @@ sub dir_target {
# too often :)
my($self,@dirs) = @_;
- my(@m,$dir);
+ my(@m,$dir,$targdir);
foreach $dir (@dirs) {
my($src) = $self->catfile($self->{PERL_INC},'perl.h');
my($targ) = $self->catfile($dir,'.exists');
- my($targdir) = $targ; # Necessary because catfile may have
- $targdir =~ s:/?.exists$::; # adapted syntax of $dir to target OS
+ # 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
@@ -703,7 +713,7 @@ sub dist {
my($to_unix) = $attribs{TO_UNIX} || ($Is_OS2
? "$self->{NOECHO}"
- . 'test -f tmp.zip && $(RM) tmp.zip;'
+ . '$(TEST_F) tmp.zip && $(RM) tmp.zip;'
. ' $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM) tmp.zip'
: "$self->{NOECHO}\$(NOOP)");
@@ -747,20 +757,20 @@ distclean :: realclean distcheck
push @m, q{
distcheck :
- $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&fullcheck";' \\
- -e 'fullcheck();'
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=fullcheck \\
+ -e fullcheck
};
push @m, q{
skipcheck :
- $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&skipcheck";' \\
- -e 'skipcheck();'
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=skipcheck \\
+ -e skipcheck
};
push @m, q{
manifest :
- $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&mkmanifest";' \\
- -e 'mkmanifest();'
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=mkmanifest \\
+ -e mkmanifest
};
join "", @m;
}
@@ -776,8 +786,8 @@ sub dist_ci {
my @m;
push @m, q{
ci :
- $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -e 'use ExtUtils::Manifest "&maniread";' \\
- -e '@all = keys %{ maniread() };' \\
+ $(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");'
};
@@ -844,7 +854,7 @@ sub dist_dir {
distdir :
$(RM_RF) $(DISTVNAME)
$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Manifest=manicopy,maniread \\
- -e 'manicopy(maniread(),"$(DISTVNAME)", "$(DIST_CP)");'
+ -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');"
};
join "", @m;
}
@@ -945,8 +955,8 @@ BOOTSTRAP = '."$self->{BASEEXT}.bs".'
$(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)" \
- -e \'use ExtUtils::Mkbootstrap;\' \
- -e \'Mkbootstrap("$(BASEEXT)","$(BSLOADLIBS)");\'
+ -MExtUtils::Mkbootstrap \
+ -e "Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');"
'.$self->{NOECHO}.'$(TOUCH) $(BOOTSTRAP)
$(CHMOD) 644 $@
@@ -990,7 +1000,14 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists
push(@m,' $(RANLIB) '."$ldfrom\n");
}
$ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf');
- push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ $(LDDLFLAGS) '.$ldfrom.
+
+ # 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');
+
+ push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ '.$ldrun.' $(LDDLFLAGS) '.$ldfrom.
' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)');
push @m, '
$(CHMOD) 755 $@
@@ -1026,7 +1043,7 @@ sub extliblist {
=item file_name_is_absolute
-Takes as argument a path and returns true, it it is an absolute path.
+Takes as argument a path and returns true, if it is an absolute path.
=cut
@@ -1054,7 +1071,7 @@ in these dirs:
foreach $dir (@$dirs){
next unless defined $dir; # $self->{PERL_SRC} may be undefined
foreach $name (@$names){
- my $abs;
+ my ($abs, $val);
if ($self->file_name_is_absolute($name)) { # /foo/bar
$abs = $name;
} elsif ($self->canonpath($name) eq $self->canonpath(basename($name))) { # foo
@@ -1065,9 +1082,12 @@ in these dirs:
print "Checking $abs\n" if ($trace >= 2);
next unless $self->maybe_command($abs);
print "Executing $abs\n" if ($trace >= 2);
- if (`$abs -e 'require $ver; print "VER_OK\n" ' 2>&1` =~ /VER_OK/) {
+ $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";
}
}
}
@@ -1075,12 +1095,99 @@ in these dirs:
0; # false and not empty
}
+=back
+
=head2 Methods to actually produce chunks of text for the Makefile
-The methods here are called in the order specified by
-@ExtUtils::MakeMaker::MM_Sections. This manpage reflects the order as
-well as possible. Some methods call each other, so in doubt refer to
-the code.
+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;
+ 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
+};
+ } else {
+ warn "Can't find $cmd in PATH, $file unchanged"
+ if $Verbose;
+ next;
+ }
+
+ unless ( rename($file, "$file.bak") ) {
+ warn "Can't modify $file";
+ next;
+ }
+ unless ( open(FIXOUT,">$file") ) {
+ warn "Can't create new $file: $!\n";
+ next;
+ }
+ my($dev,$ino,$mode) = stat FIXIN;
+ $mode = 0755 unless $dev;
+ chmod $mode, $file;
+
+ # Print out the new #! line (or equivalent).
+ local $\;
+ undef $/;
+ print FIXOUT $shb, <FIXIN>;
+ close FIXIN;
+ close FIXOUT;
+ unlink "$file.bak";
+ } continue {
+ chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
+ system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';;
+ }
+}
=item force (o)
@@ -1092,6 +1199,7 @@ sub force {
my($self) = shift;
'# Phony target to force checking subdirectories.
FORCE:
+ '.$self->{NOECHO}.'$(NOOP)
';
}
@@ -1147,6 +1255,7 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
$ignore{'test.pl'} = 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){
@@ -1222,9 +1331,10 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
}
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:);
+ $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
@@ -1256,7 +1366,6 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
# my $fh = new FileHandle;
local *FH;
my($ispod)=0;
- # one day test, if $/ can be set to '' safely (is the bug fixed that was in 5.001m?)
# if ($fh->open("<$name")) {
if (open(FH,"<$name")) {
# while (<$fh>) {
@@ -1273,7 +1382,9 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
$ispod = 1;
}
if( $ispod ) {
- $manifypods{$name} = $self->catfile('$(INST_MAN1DIR)',basename($name).'.$(MAN1EXT)');
+ $manifypods{$name} =
+ $self->catfile('$(INST_MAN1DIR)',
+ basename($name).'.$(MAN1EXT)');
}
}
}
@@ -1336,7 +1447,7 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
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, MAP_TARGET,
+PREFIX, CONFIG, AR, AR_STATIC_ARGS, LD, OBJ_EXT, LIB_EXT, EXE_EXT, MAP_TARGET,
LIBPERL_A, VERSION_FROM, VERSION, DISTNAME, VERSION_SYM.
=cut
@@ -1367,14 +1478,11 @@ sub init_main {
# It may also edit @modparts if required.
if (defined &DynaLoader::mod2fname) {
$modfname = &DynaLoader::mod2fname(\@modparts);
- } elsif ($Is_OS2) { # Need manual correction if run with miniperl:-(
- $modfname = substr($modfname, 0, 7) . '_';
}
-
($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!([\w:]+::)?(\w+)$! ;
- if (defined &DynaLoader::mod2fname or $Is_OS2) {
+ if (defined &DynaLoader::mod2fname) {
# As of 5.001m, dl_os2 appends '_'
$self->{DLBASE} = $modfname;
} else {
@@ -1412,10 +1520,21 @@ sub init_main {
if ($self->{PERL_SRC}){
$self->{PERL_LIB} ||= $self->catdir("$self->{PERL_SRC}","lib");
$self->{PERL_ARCHLIB} = $self->{PERL_LIB};
- $self->{PERL_INC} = $self->{PERL_SRC};
- # catch a situation that has occurred a few times in the past:
+ $self->{PERL_INC} = ($Is_Win32) ? $self->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC};
- warn <<EOM unless (-s $self->catfile($self->{PERL_SRC},'cflags') or $Is_VMS && -s $self->catfile($self->{PERL_SRC},'perlshr_attr.opt') or $Is_Mac);
+ # 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.
@@ -1427,26 +1546,27 @@ usually without extra arguments.
It is recommended that you unpack and build additional extensions away
from the perl source tree.
-EOM
+};
+ }
} 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;
- die <<EOM unless (-f ($perl_h = $self->catfile($self->{PERL_INC},"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. You can say:
-
- $^X Makefile.PL PERL_SRC=/path/to/perl/source/directory
-
-if you have not yet installed perl but still want to build this
-extension now.
-(You get this message, because MakeMaker could not find "$perl_h")
-EOM
+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();
@@ -1476,13 +1596,20 @@ EOM
$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
+ # 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.
@@ -1510,23 +1637,67 @@ EOM
# 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($prefix) = $Config{'prefix'};
- $prefix = VMS::Filespec::unixify($prefix) if $Is_VMS;
- unless ($self->{PREFIX}){
- $self->{PREFIX} = $prefix;
+ 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);
+ }
}
- my($install_variable);
+ $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/
-
- INSTALLPRIVLIB INSTALLARCHLIB INSTALLBIN
- INSTALLMAN1DIR INSTALLMAN3DIR INSTALLSCRIPT
- INSTALLSITELIB INSTALLSITEARCH
-
+ INSTALLMAN1DIR
+ INSTALLMAN3DIR
/) {
- $self->prefixify($install_variable,$prefix,q[$(PREFIX)]);
+ $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}
@@ -1623,9 +1794,9 @@ EOM
foreach $component ($self->{PERL_SRC}, $self->path(), $Config::Config{binexp}) {
push @defpath, $component if defined $component;
}
- $self->{PERL} =
+ $self->{PERL} ||=
$self->find_perl(5.0, [ $^X, 'miniperl','perl','perl5',"perl$]" ],
- \@defpath, $Verbose ) unless ($self->{PERL});
+ \@defpath, $Verbose );
# don't check if perl is executable, maybe they have decided to
# supply switches with perl
@@ -1638,7 +1809,7 @@ EOM
Initializes EXTRALIBS, BSLOADLIBS, LDLOADLIBS, LIBS, LD_RUN_PATH,
OBJECT, BOOTDEP, PERLMAINCC, LDFROM, LINKTYPE, NOOP, FIRST_MAKEFILE,
-MAKEFILE, NOECHO, RM_F, RM_RF, TOUCH, CP, MV, CHMOD, UMASK_NULL
+MAKEFILE, NOECHO, RM_F, RM_RF, TEST_F, TOUCH, CP, MV, CHMOD, UMASK_NULL
=cut
@@ -1652,7 +1823,7 @@ sub init_others { # --- Initialize Other Attributes
# May check $Config{libs} too, thus not empty.
$self->{LIBS}=[''] unless $self->{LIBS};
- $self->{LIBS}=[$self->{LIBS}] if ref \$self->{LIBS} eq SCALAR;
+ $self->{LIBS}=[$self->{LIBS}] if ref \$self->{LIBS} eq 'SCALAR';
$self->{LD_RUN_PATH} = "";
my($libs);
foreach $libs ( @{$self->{LIBS}} ){
@@ -1688,7 +1859,7 @@ sub init_others { # --- Initialize Other Attributes
};
# These get overridden for VMS and maybe some other systems
- $self->{NOOP} ||= "sh -c true";
+ $self->{NOOP} ||= '$(SHELL) -c true';
$self->{FIRST_MAKEFILE} ||= "Makefile";
$self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
$self->{MAKE_APERL_FILE} ||= "Makefile.aperl";
@@ -1696,10 +1867,12 @@ sub init_others { # --- Initialize Other Attributes
$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)
@@ -1762,7 +1935,7 @@ pure_site_install ::
doc_perl_install ::
}.$self->{NOECHO}.q{$(DOC_INSTALL) \
- "$(NAME)" \
+ "Module" "$(NAME)" \
"installed into" "$(INSTALLPRIVLIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
@@ -1771,7 +1944,7 @@ doc_perl_install ::
doc_site_install ::
}.$self->{NOECHO}.q{$(DOC_INSTALL) \
- "Module $(NAME)" \
+ "Module" "$(NAME)" \
"installed into" "$(INSTALLSITELIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
@@ -1815,22 +1988,27 @@ sub installbin {
$fromto{$from}=$to;
}
@to = values %fromto;
- push(@m, "
+ push(@m, qq{
EXE_FILES = @{$self->{EXE_FILES}}
+FIXIN = \$(PERL) -I\$(PERL_ARCHLIB) -I\$(PERL_LIB) -MExtUtils::MakeMaker \\
+ -e "MY->fixin(shift)"
+
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} $todir/.exists
+$to: $from $self->{MAKEFILE} " . $self->catdir($todir,'.exists') . "
$self->{NOECHO}$self->{RM_F} $to
$self->{CP} $from $to
+ \$(FIXIN) $to
";
}
join "", @m;
@@ -1910,6 +2088,10 @@ sub macro {
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 {
@@ -1958,13 +2140,15 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
$cccmd = $self->const_cccmd($libperl);
$cccmd =~ s/^CCCMD\s*=\s*//;
$cccmd =~ s/\$\(INC\)/ -I$self->{PERL_INC} /;
- $cccmd .= " $Config::Config{cccdlflags}" if ($Config::Config{d_shrplib});
+ $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);
@@ -1972,6 +2156,8 @@ $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
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;
@@ -2055,6 +2241,16 @@ MAP_PRELIBS = $Config::Config{libs} $Config::Config{cryptlib}
$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"
@@ -2075,10 +2271,17 @@ MAP_LIBPERL = $libperl
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';
- push @m, "
+ # 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) \$(MAP_LIBPERL) \$(MAP_STATIC) `cat \$(INST_ARCHAUTODIR)/extralibs.all` \$(MAP_PRELIBS)
+ \$(MAP_LINKCMD) -o \$\@ \$(OPTIMIZE) $tmp/perlmain\$(OBJ_EXT) $ldfrom $llibperl \$(MAP_STATIC) `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'
@@ -2091,8 +2294,8 @@ $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c
push @m, qq{
$tmp/perlmain.c: $makefilename}, q{
}.$self->{NOECHO}.q{echo Writing $@
- }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -e 'use ExtUtils::Miniperl; \\
- writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)' > $@.tmp && mv $@.tmp $@
+ }.$self->{NOECHO}.q{$(PERL) $(MAP_PERLINC) -MExtUtils::Miniperl \\
+ -e "writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)" > $@t && $(MV) $@t $@
};
@@ -2100,7 +2303,7 @@ $tmp/perlmain.c: $makefilename}, q{
doc_inst_perl:
}.$self->{NOECHO}.q{echo Appending installation info to $(INSTALLARCHLIB)/perllocal.pod
}.$self->{NOECHO}.q{$(DOC_INSTALL) \
- "Perl binary $(MAP_TARGET)" \
+ "Perl binary" "$(MAP_TARGET)" \
MAP_STATIC "$(MAP_STATIC)" \
MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \
MAP_LIBPERL "$(MAP_LIBPERL)" \
@@ -2145,11 +2348,12 @@ $(OBJECT) : $(FIRST_MAKEFILE)
}.$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{mv }."$self->{MAKEFILE} $self->{MAKEFILE}.old".q{
- -$(MAKE) -f }.$self->{MAKEFILE}.q{.old clean >/dev/null 2>&1 || true
+ -}.$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
+ }.$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.
@@ -2318,14 +2522,21 @@ sub parse_version {
$inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;
next if $inpod;
chop;
- next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/;
- local $ExtUtils::MakeMaker::module_version_variable = $1;
- my($thispackage) = $2 || $current_package;
- $thispackage =~ s/:+$//;
- my($eval) = "$_;";
- eval $eval;
+ # 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 = $ {$ExtUtils::MakeMaker::module_version_variable} || 0;
+ $result = "undef" unless defined $result;
last;
}
close FH;
@@ -2345,12 +2556,14 @@ sub pasthru {
my(@m,$key);
my(@pasthru);
+ my($sep) = $Is_VMS ? ',' : '';
+ $sep .= "\\\n\t";
- foreach $key (qw(LIBPERL_A LINKTYPE PREFIX OPTIMIZE)){
+ foreach $key (qw(LIB LIBPERL_A LINKTYPE PREFIX OPTIMIZE)){
push @pasthru, "$key=\"\$($key)\"";
}
- push @m, "\nPASTHRU = ", join ("\\\n\t", @pasthru), "\n";
+ push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n";
join "", @m;
}
@@ -2366,6 +2579,8 @@ sub path {
my $path = $ENV{PATH};
$path =~ s:\\:/:g if $Is_OS2;
my @path = split $path_sep, $path;
+ foreach(@path) { $_ = '.' if $_ eq '' }
+ @path;
}
=item perl_script
@@ -2430,7 +2645,7 @@ $(OBJECT) : $(PERL_HDRS)
=item pm_to_blib
Defines target that copies all files in the hash PM to their
-destination and autosplits them. See L<ExtUtils::Install/pm_to_blib>
+destination and autosplits them. See L<ExtUtils::Install/DESCRIPTION>
=cut
@@ -2441,7 +2656,7 @@ sub pm_to_blib {
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{")'
+ -e "pm_to_blib({qw{$(PM_TO_BLIB)}},'}.$autodir.q{')"
}.$self->{NOECHO}.q{$(TOUCH) $@
};
}
@@ -2460,7 +2675,7 @@ sub post_constants{
=item post_initialize (o)
-Returns an ampty string per default. Used in Makefile.PLs to add some
+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
@@ -2512,6 +2727,7 @@ sub processPL {
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
@@ -2534,7 +2750,7 @@ sub realclean {
realclean purge :: clean
');
# realclean subdirectories first (already cleaned)
- my $sub = "\t-cd %s && test -f %s && \$(MAKE) %s realclean\n";
+ 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}",''));
@@ -2544,9 +2760,7 @@ realclean purge :: clean
push(@m, " $self->{RM_F} \$(INST_DYNAMIC) \$(INST_BOOT)\n");
push(@m, " $self->{RM_F} \$(INST_STATIC)\n");
}
- if ( values %{$self->{PM}} ){
- push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n");
- }
+ push(@m, " $self->{RM_F} " . join(" ", values %{$self->{PM}}) . "\n");
my(@otherfiles) = ($self->{MAKEFILE},
"$self->{MAKEFILE}.old"); # Makefiles last
push(@otherfiles, $attribs{FILES}) if $attribs{FILES};
@@ -2611,14 +2825,14 @@ END
push @m,
q{ $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@
- }.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld
$(CHMOD) 755 $@
+ }.$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}."\n\n"
- if $self->{PERL_SRC};
+ # 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);
@@ -2722,27 +2936,32 @@ sub test {
# --- Test and Installation Sections ---
my($self, %attribs) = @_;
- my($tests) = $attribs{TESTS} || (-d "t" ? "t/*.t" : "");
+ 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",
+ 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)', $tests)) if $tests;
- push(@m, $self->test_via_script('$(FULLPERL)', 'test.pl')) if -f "test.pl";
+ 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");
@@ -2754,8 +2973,8 @@ test :: \$(TEST_TYPE)
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, $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)'));
@@ -2775,7 +2994,8 @@ Helper method to write the test targets
sub test_via_harness {
my($self, $perl, $tests) = @_;
- "\tPERL_DL_NONLAZY=1 $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";
+ $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)
@@ -2786,7 +3006,8 @@ Other helper method for test.
sub test_via_script {
my($self, $perl, $script) = @_;
- qq{\tPERL_DL_NONLAZY=1 $perl}.q{ -I$(INST_ARCHLIB) -I$(INST_LIB) -I$(PERL_ARCHLIB) -I$(PERL_LIB) }.qq{$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
};
}
@@ -2825,27 +3046,23 @@ sub tools_other {
SHELL = $bin_sh
};
- for (qw/ CHMOD CP LD MV NOOP RM_F RM_RF TOUCH UMASK_NULL / ) {
+ 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) -wle '$$"="/"; foreach $$p (@ARGV){' \\
--e 'next if -d $$p; my(@p); foreach(split(/\//,$$p)){' \\
--e 'push(@p,$$_); next if -d "@p/"; print "mkdir @p" if 0;' \\
--e 'mkdir("@p",0777)||die $$! } } exit 0;'
+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) -we 'open F, ">$$ARGV[1]"; close F;' \\
--e 'utime ((stat("$$ARGV[0]"))[8,9], $$ARGV[1])'
+EQUALIZE_TIMESTAMP = $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) -MExtUtils::Command -e eqtime
};
+
return join "", @m if $self->{PARENT};
push @m, q{
@@ -2860,16 +3077,18 @@ UNINST=0
VERBINST=1
MOD_INSTALL = $(PERL) -I$(INST_LIB) -I$(PERL_LIB) -MExtUtils::Install \
--e 'install({@ARGV},"$(VERBINST)",0,"$(UNINST)");'
+-e "install({@ARGV},'$(VERBINST)',0,'$(UNINST)');"
-DOC_INSTALL = $(PERL) -e '$$\="\n\n";print "=head3 ", scalar(localtime), ": C<", shift, ">";' \
+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);'
-
+-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;
@@ -2997,10 +3216,15 @@ sub top_targets {
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)
@@ -3055,7 +3279,7 @@ help:
Version_check:
}.$self->{NOECHO}.q{$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) \
-MExtUtils::MakeMaker=Version_check \
- -e 'Version_check("$(MM_VERSION)")'
+ -e "Version_check('$(MM_VERSION)')"
};
join('',@m);
@@ -3087,7 +3311,7 @@ sub xs_c {
return '' unless $self->needs_linking();
'
.xs.c:
- $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >$*.tc && mv $*.tc $@
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >$*.tc && $(MV) $*.tc $@
';
}
@@ -3103,13 +3327,41 @@ sub xs_o { # many makes are too dumb to use xs_c then c_o
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
+ $(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
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm
index 9a382284d11..dc3b4ceca64 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm
+++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_VMS.pm
@@ -6,14 +6,18 @@
# Author: Charles Bailey bailey@genetics.upenn.edu
package ExtUtils::MM_VMS;
-$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.35 (23-Jun-1996)';
-unshift @MM::ISA, 'ExtUtils::MM_VMS';
+use Carp qw( &carp );
use Config;
require Exporter;
use VMS::Filespec;
use File::Basename;
+use vars qw($Revision);
+$Revision = '5.3901 (6-Mar-1997)';
+
+unshift @MM::ISA, 'ExtUtils::MM_VMS';
+
Exporter::import('ExtUtils::MakeMaker', '$Verbose', '&neatvalue');
=head1 NAME
@@ -32,6 +36,8 @@ the semantics.
=head2 Methods always loaded
+=over
+
=item eliminate_macros
Expands MM[KS]/Make macros in a text string, using the contents of
@@ -47,16 +53,23 @@ sub eliminate_macros {
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);
- ($macro = unixify($self->{$macro})) =~ s#/$##;
+ if (ref $self->{$macro}) {
+ carp "Can't expand macro containing " . ref $self->{$macro};
+ $npath = "$head\cB$macro\cB$tail";
+ $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;
}
@@ -83,7 +96,7 @@ sub fixpath {
}
my($fixedpath,$prefix,$name);
- if ($path =~ m#^\$\(.+\)$# || $path =~ m#[/:>\]]#) {
+ if ($path =~ m#^\$\([^\)]+\)$# || $path =~ m#[/:>\]]#) {
if ($force_path or $path =~ /(?:DIR\)|\])$/) {
$fixedpath = vmspath($self->eliminate_macros($path));
}
@@ -92,7 +105,9 @@ sub fixpath {
}
}
elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) {
- my($vmspre) = vmspath($self->{$prefix}) || ''; # is it a dir or just a name?
+ 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;
}
@@ -102,6 +117,8 @@ sub fixpath {
}
# Convert names without directory or type to paths
if (!$force_path and $fixedpath !~ /[:>(.\]]/) { $fixedpath = vmspath($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;
}
@@ -123,9 +140,12 @@ sub catdir {
my($spath,$sdir) = ($path,$dir);
$spath =~ s/.dir$//; $sdir =~ s/.dir$//;
$sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
- $rslt = vmspath($self->eliminate_macros($spath)."/$sdir");
+ $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
+ }
+ else {
+ if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
+ else { $rslt = vmspath($dir); }
}
- else { $rslt = vmspath($dir); }
print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
$rslt;
}
@@ -157,6 +177,30 @@ sub catfile {
$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.
@@ -189,6 +233,7 @@ sub updir {
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;
@@ -199,7 +244,6 @@ 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::const_loadlibs;
sub ExtUtils::MM_VMS::cflags;
sub ExtUtils::MM_VMS::const_cccmd;
sub ExtUtils::MM_VMS::pm_to_blib;
@@ -263,6 +307,17 @@ sub AUTOLOAD {
#__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
@@ -271,6 +326,8 @@ 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
@@ -284,12 +341,24 @@ package name.
sub guess_name {
my($self) = @_;
- my($defname,$defpm);
+ 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) {
@@ -317,13 +386,14 @@ invoke Perl images.
=cut
-sub find_perl{
+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($absb) = file_name_is_absolute($a);
- my($absb) = file_name_is_absolute($b);
+ @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;
@@ -332,9 +402,16 @@ sub find_perl{
# executable that's less likely to be from an old installation.
@snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename
my($bb) = $b =~ m!([^:>\]/]+)$!;
- substr($ba,0,1) cmp substr($bb,0,1)
- or -1*(length($ba) <=> length($bb)) } @$names;
- if ($trace){
+ 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";
@@ -342,6 +419,14 @@ sub find_perl{
}
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)); }
@@ -349,12 +434,18 @@ sub find_perl{
}
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"
+ return "MCR $vmsfile";
}
}
print STDOUT "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n";
@@ -378,22 +469,32 @@ sub path {
Follows VMS naming conventions for executable files.
If the name passed in doesn't exactly match an executable file,
-appends F<.Exe> to check for executable image, and F<.Com> to check
-for DCL procedure. If this fails, checks F<Sys$Share:> for an
-executable file having the name specified. Finally, appends F<.Exe>
-and checks again.
+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 _;
- return "$file.exe" if -x "$file.exe";
- return "$file.com" if -x "$file.com";
+ my(@dirs) = ('');
+ my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
+ my($dir,$ext);
if ($file !~ m![/:>\]]!) {
- my($shrfile) = 'Sys$Share:' . $file;
- return $file if -x $shrfile && ! -d _;
- return "$file.exe" if -x "$shrfile.exe";
+ 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;
}
@@ -424,7 +525,7 @@ sub maybe_command_in_dirs { # $ver is optional argument if looking for perl
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;
+ print "Using $abs\n" if $trace;
return $abs;
}
} else { # Do not look for perl
@@ -436,8 +537,8 @@ sub maybe_command_in_dirs { # $ver is optional argument if looking for perl
=item perl_script (override)
-If name passed in doesn't specify a readable file, appends F<.pl> and
-tries again, since it's customary to have file types on all files
+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
@@ -445,7 +546,8 @@ under VMS.
sub perl_script {
my($self,$file) = @_;
return $file if -r $file && ! -d _;
- return "$file.pl" if -r "$file.pl" && ! -d _;
+ return "$file.com" if -r "$file.com";
+ return "$file.pl" if -r "$file.pl";
return '';
}
@@ -456,8 +558,10 @@ Checks for VMS directory spec as well as Unix separators.
=cut
sub file_name_is_absolute {
- my($self,$file);
- $file =~ m!^/! or $file =~ m![:<\[][^.\-]!;
+ 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
@@ -483,7 +587,7 @@ off to the default MM_Unix method.
sub init_others {
my($self) = @_;
- $self->{NOOP} = "\t@ Continue";
+ $self->{NOOP} = 'Continue';
$self->{FIRST_MAKEFILE} ||= 'Descrip.MMS';
$self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS';
$self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
@@ -494,7 +598,7 @@ sub init_others {
$self->{CHMOD} = '$(PERL) -e "chmod @ARGV"'; # expect Unix syntax from MakeMaker
$self->{CP} = 'Copy/NoConfirm';
$self->{MV} = 'Rename/NoConfirm';
- $self->{UMASK_NULL} = "\t!";
+ $self->{UMASK_NULL} = '! ';
&ExtUtils::MM_Unix::init_others;
}
@@ -514,29 +618,24 @@ sub constants {
my(@defs) = split(/\s+/,$self->{DEFINE});
foreach $def (@defs) {
next unless $def;
- $def =~ s/^-D//;
- $def = "\"$def\"" if $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} = map($self->fixpath($_),split(/,?\s+/,$self->{OBJECT}));
+ $self->{OBJECT} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{OBJECT})));
}
$self->{LDFROM} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{LDFROM})));
- if ($self->{'INC'} && $self->{INC} !~ m!/Include=!i) {
- my(@val) = ( '/Include=(' );
- my(@includes) = split(/\s+/,$self->{INC});
- my($plural);
- foreach (@includes) {
- s/^-I//;
- push @val,', ' if $plural++;
- push @val,$self->fixpath($_,1);
- }
- $self->{INC} = join('',@val,')');
- }
# Fix up directory specs
$self->{ROOTEXT} = $self->{ROOTEXT} ? $self->fixpath($self->{ROOTEXT},1)
@@ -593,8 +692,14 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision
];
for $tmp (qw/
- FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
- LDFROM LINKTYPE
+ FULLEXT VERSION_FROM OBJECT LDFROM
+ / ) {
+ next unless defined $self->{$tmp};
+ push @m, "$tmp = ",$self->fixpath($self->{$tmp}),"\n";
+ }
+
+ for $tmp (qw/
+ BASEEXT PARENT_NAME DLBASE INC DEFINE LINKTYPE
/ ) {
next unless defined $self->{$tmp};
push @m, "$tmp = $self->{$tmp}\n";
@@ -621,12 +726,12 @@ MM_VMS_REVISION = $ExtUtils::MM_VMS::Revision
push @m,'
# Handy lists of source code files:
-XS_FILES = ',join(', ', sort keys %{$self->{XS}}),'
-C_FILES = ',join(', ', @{$self->{C}}),'
-O_FILES = ',join(', ', @{$self->{O_FILES}} ),'
-H_FILES = ',join(', ', @{$self->{H}}),'
-MAN1PODS = ',join(', ', sort keys %{$self->{MAN1PODS}}),'
-MAN3PODS = ',join(', ', sort keys %{$self->{MAN3PODS}}),'
+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}}),'
';
@@ -638,18 +743,19 @@ MAN3PODS = ',join(', ', sort keys %{$self->{MAN3PODS}}),'
}
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'} = $self->catdir($self->{INST_LIB},$self->{ROOTEXT})),"
-INST_ARCHLIBDIR = ",($self->{'INST_ARCHLIBDIR'} = $self->catdir($self->{INST_ARCHLIB},$self->{ROOTEXT})),"
+INST_LIBDIR = $self->{INST_LIBDIR}
+INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR}
-INST_AUTODIR = ",($self->{'INST_AUTODIR'} = $self->catdir($self->{INST_LIB},'auto',$self->{FULLEXT})),'
-INST_ARCHAUTODIR = ',($self->{'INST_ARCHAUTODIR'} = $self->catdir($self->{INST_ARCHLIB},'auto',$self->{FULLEXT})),'
-';
+INST_AUTODIR = $self->{INST_AUTODIR}
+INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR}
+";
if ($self->has_link_code()) {
push @m,'
@@ -663,79 +769,27 @@ INST_STATIC =
INST_DYNAMIC =
INST_BOOT =
EXPORT_LIST = $(BASEEXT).opt
-PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : 'Sys$Share:PerlShr.Exe'),'
+PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : "Sys\$Share:PerlShr.$Config{'dlext'}"),'
';
}
$self->{TO_INST_PM} = [ sort keys %{$self->{PM}} ];
$self->{PM_TO_BLIB} = [ %{$self->{PM}} ];
push @m,'
-TO_INST_PM = ',join(', ',@{$self->{TO_INST_PM}}),'
+TO_INST_PM = ',$self->wraplist(', ',@{$self->{TO_INST_PM}}),'
-PM_TO_BLIB = ',join(', ',@{$self->{PM_TO_BLIB}}),'
+PM_TO_BLIB = ',$self->wraplist(', ',@{$self->{PM_TO_BLIB}}),'
';
join('',@m);
}
-=item const_loadlibs (override)
-
-Basically a stub which passes through library specfications provided
-by the caller. Will be updated or removed when VMS support is added
-to ExtUtils::Liblist.
-
-=cut
-
-sub const_loadlibs{
- my($self) = @_;
- my (@m);
- push @m, "
-# $self->{NAME} might depend on some other libraries.
-# (These comments may need revising:)
-#
-# Dependent libraries can be linked in one of three ways:
-#
-# 1. (For static extensions) by the ld command when the perl binary
-# is linked with the extension library. See EXTRALIBS below.
-#
-# 2. (For dynamic extensions) by the ld command when the shared
-# object is built/linked. See LDLOADLIBS below.
-#
-# 3. (For dynamic extensions) by the DynaLoader when the shared
-# object is loaded. See BSLOADLIBS below.
-#
-# 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.
-#
-# LDLOADLIBS = 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.
-#
-# 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.
-#
-EXTRALIBS = ",map($self->fixpath($_) . ' ',$self->{'EXTRALIBS'}),"
-BSLOADLIBS = ",map($self->fixpath($_) . ' ',$self->{'BSLOADLIBS'}),"
-LDLOADLIBS = ",map($self->fixpath($_) . ' ',$self->{'LDLOADLIBS'}),"\n";
-
- 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, and do the same with /Includes, since some C
-compilers pay attention to only one instance of these qualifiers
-on the command line.
+/Defines into one, since some C compilers pay attention to only one
+instance of this qualifier on the command line.
=cut
@@ -780,10 +834,7 @@ sub cflags {
$incstr .= ', '.$self->fixpath($_,1);
}
}
- if ($quals =~ m:(.*)/include=\(?([^\(\/\)\s]+)\)?(.*):i) {
- $quals = "$1$incstr,$2)$3";
- }
- else { $quals .= "$incstr)"; }
+ $quals .= "$incstr)";
$optimize = '/Debug/NoOptimize'
if ($self->{OPTIMIZE} =~ /-g/ or $self->{OPTIMIZE} =~ m!/Debug!i);
@@ -800,7 +851,7 @@ LARGE =
=item const_cccmd (override)
Adds directives to point C preprocessor to the right place when
-handling #include <sys/foo.h> directives. Also constructs CC
+handling #include E<lt>sys/foo.hE<gt> directives. Also constructs CC
command line a bit differently than MM_Unix method.
=cut
@@ -851,25 +902,31 @@ sub pm_to_blib {
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 : $(TO_INST_PM)
- },$self->{NOECHO},q{$(PERL) -e "print '},shift(@files),q{ },shift(@files),q{'" >.MM_tmp
+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$self->{NOECHO}\$(PERL) -e \"print '$line'\" >>.MM_tmp\n");
+ push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n");
$line = '';
}
}
- push(@m,"\t$self->{NOECHO}\$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $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[
- $self->{NOECHO}Delete/NoLog/NoConfirm .MM_tmp;
- $self->{NOECHO}\$(TOUCH) pm_to_blib.ts
+ \$(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
+ \$(NOECHO) \$(TOUCH) pm_to_blib.ts
]);
join('',@m);
@@ -948,8 +1005,8 @@ XSUBPPARGS = @tmargs
=item xsubpp_version (override)
-Test xsubpp exit status according to VMS rules ($sts & 1 ==> good)
-rather than Unix rules ($sts == 0 ==> good).
+Test xsubpp exit status according to VMS rules ($sts & 1 ==E<gt> good)
+rather than Unix rules ($sts == 0 ==E<gt> good).
=cut
@@ -966,7 +1023,10 @@ sub xsubpp_version
my $command = "$self->{PERL} \"-I$self->{PERL_LIB}\" $xsubpp -v";
print "Running: $command\n" if $Verbose;
$version = `$command` ;
- warn "Running '$command' exits with status " . $? unless ($? & 1);
+ if ($?) {
+ use vmsish 'status';
+ warn "Running '$command' exits with status $?";
+ }
chop $version ;
return $1 if $version =~ /^xsubpp version (.*)/ ;
@@ -993,7 +1053,10 @@ EOM
$command = "$self->{PERL} $xsubpp $file";
print "Running: $command\n" if $Verbose;
my $text = `$command` ;
- warn "Running '$command' exits with status " . $? unless ($? & 1);
+ if ($?) {
+ use vmsish 'status';
+ warn "Running '$command' exits with status $?";
+ }
unlink $file ;
# gets 1.2 -> 1.92 and 2.000a1
@@ -1034,15 +1097,17 @@ 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 '=head3 ',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);"
+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);"
!);
}
@@ -1056,12 +1121,17 @@ default MM_Unix method.
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);
}
@@ -1130,27 +1200,27 @@ sub top_targets {
my(@m);
push @m, '
all :: pure_all manifypods
- $(NOOP)
+ $(NOECHO) $(NOOP)
pure_all :: config pm_to_blib subdirs linkext
- $(NOOP)
+ $(NOECHO) $(NOOP)
subdirs :: $(MYEXTLIB)
- $(NOOP)
+ $(NOECHO) $(NOOP)
config :: $(MAKEFILE) $(INST_LIBDIR).exists
- $(NOOP)
+ $(NOECHO) $(NOOP)
config :: $(INST_ARCHAUTODIR).exists
- $(NOOP)
+ $(NOECHO) $(NOOP)
config :: $(INST_AUTODIR).exists
- $(NOOP)
+ $(NOECHO) $(NOOP)
';
push @m, q{
config :: Version_check
- $(NOOP)
+ $(NOECHO) $(NOOP)
} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC};
@@ -1159,14 +1229,14 @@ config :: Version_check
if (%{$self->{MAN1PODS}}) {
push @m, q[
config :: $(INST_MAN1DIR).exists
- $(NOOP)
+ $(NOECHO) $(NOOP)
];
push @m, $self->dir_target(qw[$(INST_MAN1DIR)]);
}
if (%{$self->{MAN3PODS}}) {
push @m, q[
config :: $(INST_MAN3DIR).exists
- $(NOOP)
+ $(NOECHO) $(NOOP)
];
push @m, $self->dir_target(qw[$(INST_MAN3DIR)]);
}
@@ -1182,7 +1252,7 @@ help :
push @m, q{
Version_check :
- },$self->{NOECHO},q{$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -
+ $(NOECHO) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -
"-MExtUtils::MakeMaker=Version_check" -e "&Version_check('$(MM_VERSION)')"
};
@@ -1210,12 +1280,12 @@ sub dlsyms {
unless ($self->{SKIPHASH}{'dynamic'}) {
push(@m,'
dynamic :: rtls.opt $(INST_ARCHAUTODIR)$(BASEEXT).opt
- $(NOOP)
+ $(NOECHO) $(NOOP)
');
if ($srcdir) {
my($popt) = $self->catfile($srcdir,'perlshr.opt');
my($lopt) = $self->catfile($srcdir,'crtl.opt');
- push(@m,"# Depend on $(BASEEXT).opt to insure we copy here *after* autogenerating (wrong) rtls.opt in Mksymlists
+ push(@m,"# Depend on \$(BASEEXT).opt to insure we copy here *after* autogenerating (wrong) rtls.opt in Mksymlists
rtls.opt : $popt $lopt \$(BASEEXT).opt
Copy/Log $popt Sys\$Disk:[]rtls.opt
Append/Log $lopt Sys\$Disk:[]rtls.opt
@@ -1232,7 +1302,7 @@ rtls.opt : $(BASEEXT).opt
push(@m,'
static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
- $(NOOP)
+ $(NOECHO) $(NOOP)
') unless $self->{SKIPHASH}{'static'};
push(@m,'
@@ -1246,7 +1316,21 @@ $(BASEEXT).opt : Makefile.PL
$(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)
@@ -1272,7 +1356,8 @@ INST_DYNAMIC_DEP = $inst_dynamic_dep
";
push @m, '
$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt rtls.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
- ',$self->{NOECHO},'$(MKPATH) $(INST_ARCHAUTODIR)
+ $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR)
+ $(NOECHO) If F$TrnLNm("PerlShr").eqs."" Then Define/NoLog/User PerlShr Sys$Share:PerlShr.',$Config{'dlext'},'
Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,rtls.opt/Option,$(PERL_INC)perlshr_attr.opt/Option
';
@@ -1298,13 +1383,13 @@ BOOTSTRAP = '."$self->{BASEEXT}.bs".'
# 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
- '.$self->{NOECHO}.'Write Sys$Output "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))"
- '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -
+ $(NOECHO) $(SAY) "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))"
+ $(NOECHO) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -
-e "use ExtUtils::Mkbootstrap; Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');"
- '.$self->{NOECHO}.' $(TOUCH) $(MMS$TARGET)
+ $(NOECHO) $(TOUCH) $(MMS$TARGET)
$(INST_BOOT) : $(BOOTSTRAP) $(INST_ARCHAUTODIR).exists
- '.$self->{NOECHO}.'$(RM_RF) $(INST_BOOT)
+ $(NOECHO) $(RM_RF) $(INST_BOOT)
- $(CP) $(BOOTSTRAP) $(INST_BOOT)
';
}
@@ -1321,7 +1406,7 @@ sub static_lib {
return '
$(INST_STATIC) :
- $(NOOP)
+ $(NOECHO) $(NOOP)
' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB});
my(@m);
@@ -1338,7 +1423,7 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
push(@m,'
If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)
Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)
- ',$self->{NOECHO},'$(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq[$(EXTRALIBS)\n];close F;"
+ $(NOECHO) $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq{$(EXTRALIBS)\n};close F;"
');
push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
join('',@m);
@@ -1358,8 +1443,8 @@ $(INST_STATIC) : $(OBJECT) $(MYEXTLIB)
#
# push(@m, "
# $inst : $dist \$(MAKEFILE) ${instdir}.exists \$(INST_ARCHAUTODIR).exists
-# ",' ',$self->{NOECHO},'$(RM_F) $(MMS$TARGET)
-# ',$self->{NOECHO},'$(CP) ',"$dist $inst",'
+# ",' $(NOECHO) $(RM_F) $(MMS$TARGET)
+# $(NOECHO) $(CP) ',"$dist $inst",'
# $(CHMOD) 644 $(MMS$TARGET)
# ');
# push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ',
@@ -1380,7 +1465,7 @@ to specify fallback location at build time if we can't find pod2man.
sub manifypods {
my($self, %attribs) = @_;
- return "\nmanifypods :\n\t\$(NOOP)\n" unless %{$self->{MAN3PODS}} or %{$self->{MAN1PODS}};
+ return "\nmanifypods :\n\t\$(NOECHO) \$(NOOP)\n" unless %{$self->{MAN3PODS}} or %{$self->{MAN1PODS}};
my($dist);
my($pod2man_exe);
if (defined $self->{PERL_SRC}) {
@@ -1388,8 +1473,7 @@ sub manifypods {
} else {
$pod2man_exe = $self->catfile($Config{scriptdirexp},'pod2man');
}
- if ($pod2man_exe = $self->perl_script($pod2man_exe)) { $found_pod2man = 1; }
- else {
+ if (not ($pod2man_exe = $self->perl_script($pod2man_exe))) {
# No pod2man but some MAN3PODS to be installed
print <<END;
@@ -1406,9 +1490,7 @@ 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 : ";
- push @m, join " ", keys %{$self->{MAN1PODS}}, keys %{$self->{MAN3PODS}};
- push(@m,"\n");
+ push @m, "\nmanifypods : \$(MAN1PODS) \$(MAN3PODS)\n";
if (%{$self->{MAN1PODS}} || %{$self->{MAN3PODS}}) {
my($pod);
foreach $pod (sort keys %{$self->{MAN1PODS}}) {
@@ -1434,12 +1516,14 @@ sub processPL {
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 :: $self->{PL_FILES}->{$plfile}
- \$(NOOP)
+all :: $vmsfile
+ \$(NOECHO) \$(NOOP)
-$self->{PL_FILES}->{$plfile} :: $plfile
-",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $plfile
+$vmsfile :: $vmsplfile
+",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $vmsplfile
";
}
join "", @m;
@@ -1458,19 +1542,20 @@ sub installbin {
return '' unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY";
return '' unless @{$self->{EXE_FILES}};
my(@m, $from, $to, %fromto, @to, $line);
- for $from (@{$self->{EXE_FILES}}) {
+ 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}=$to;
+ $fromto{$from} = vmsify($to);
}
- @to = values %fromto;
+ @to = values %fromto;
push @m, "
-EXE_FILES = @{$self->{EXE_FILES}}
+EXE_FILES = @exefiles
all :: @to
- \$(NOOP)
+ \$(NOECHO) \$(NOOP)
realclean ::
";
@@ -1514,7 +1599,7 @@ sub subdir_x {
subdirs ::
olddef = F$Environment("Default")
Set Default ',$subdir,'
- - $(MMS) all $(USEMACROS)$(PASTHRU)$(MACROEND)
+ - $(MMS)$(MMSQUALIFIERS) all $(USEMACROS)$(PASTHRU)$(MACROEND)
Set Default \'olddef\'
';
join('',@m);
@@ -1538,14 +1623,26 @@ clean ::
';
foreach $dir (@{$self->{DIR}}) { # clean subdirectories first
my($vmsdir) = $self->fixpath($dir,1);
- push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)") Then \\',"\n\t",
- '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS) clean`;"',"\n");
+ 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
+ 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
- push(@otherfiles, $attribs{FILES}) if $attribs{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, $attribs{FILES}); }
+ }
+ }
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);
@@ -1558,7 +1655,7 @@ clean ::
}
else { $line .= " $file"; }
}
- push @m, "\t\$(RM_RF) $line\n" if line;
+ push @m, "\t\$(RM_RF) $line\n" if $line;
push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP};
join('', @m);
}
@@ -1579,7 +1676,7 @@ 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) realclean`;"',"\n");
+ '$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS)$(MMSQUALIFIERS) realclean`;"',"\n");
}
push @m,' $(RM_RF) $(INST_AUTODIR) $(INST_ARCHAUTODIR)
';
@@ -1604,9 +1701,18 @@ realclean :: clean
else { $line .= " $file"; }
}
push @m, "\t\$(RM_F) $line\n" if $line;
- if ($attribs{FILES} && ref $attribs{FILES} eq 'ARRAY') {
+ 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, $attribs{FILES}); }
+ }
$line = '';
- foreach $file (@{$attribs{'FILES'}}) {
+ foreach $file (@allfiles) {
$file = $self->fixpath($file);
if (length($line) + length($file) > 80) {
push @m, "\t\$(RM_RF) $line\n";
@@ -1630,13 +1736,13 @@ sub dist_basics {
my($self) = @_;
'
distclean :: realclean distcheck
- $(NOOP)
+ $(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 \'&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()"
@@ -1654,28 +1760,28 @@ sub dist_core {
my($self) = @_;
q[
dist : $(DIST_DEFAULT)
- ].$self->{NOECHO}.q[$(PERL) -le "print 'Warning: $m older than $vf' if -e ($vf = '$(VERSION_FROM)') && -M $vf < -M ($m = '$(MAKEFILE)'"
+ $(NOECHO) $(PERL) -le "print 'Warning: $m older than $vf' if -e ($vf = '$(VERSION_FROM)') && -M $vf < -M ($m = '$(MAKEFILE)')"
zipdist : $(DISTVNAME).zip
- $(NOOP)
+ $(NOECHO) $(NOOP)
$(DISTVNAME).zip : distdir
$(PREOP)
- $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) $(SRC)
+ $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*;
$(RM_RF) $(DISTVNAME)
$(POSTOP)
$(DISTVNAME).tar$(SUFFIX) : distdir
$(PREOP)
$(TO_UNIX)
- $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar $(SRC)
+ $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)]
$(RM_RF) $(DISTVNAME)
$(COMPRESS) $(DISTVNAME).tar
$(POSTOP)
shdist : distdir
$(PREOP)
- $(SHARE) $(SRC) $(DISTVNAME).share
+ $(SHAR) [.$(DISTVNAME...]*.*; $(DISTVNAME).share
$(RM_RF) $(DISTVNAME)
$(POSTOP)
];
@@ -1711,8 +1817,8 @@ disttest : distdir
startdir = F$Environment("Default")
Set Default [.$(DISTVNAME)]
$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL
- $(MMS)
- $(MMS) test
+ $(MMS)$(MMSQUALIFIERS)
+ $(MMS)$(MMSQUALIFIERS) test
Set Default 'startdir'
};
}
@@ -1735,93 +1841,108 @@ sub install {
foreach $file (@{$self->{EXE_FILES}}) {
$line .= "$file ";
if (length($line) > 128) {
- push(@docfiles,qq[\t\$(PERL) -e "print $line" >>.MM_tmp\n]);
+ 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(@docfiles,qq[\t\$(PERL) -e "print '$line'" >>.MM_tmp\n]) if $line;
}
push @m, q[
install :: all pure_install doc_install
- $(NOOP)
+ $(NOECHO) $(NOOP)
install_perl :: all pure_perl_install doc_perl_install
- $(NOOP)
+ $(NOECHO) $(NOOP)
install_site :: all pure_site_install doc_site_install
- $(NOOP)
+ $(NOECHO) $(NOOP)
install_ :: install_site
- ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
+ $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
pure_install :: pure_$(INSTALLDIRS)_install
- $(NOOP)
+ $(NOECHO) $(NOOP)
doc_install :: doc_$(INSTALLDIRS)_install
- ],$self->{NOECHO},q[Write Sys$Output "Appending installation info to $(INST_ARCHLIB)perllocal.pod"
+ $(NOECHO) $(SAY) "Appending installation info to $(INSTALLARCHLIB)perllocal.pod"
pure__install : pure_site_install
- ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
+ $(NOECHO) $(SAY) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
doc__install : doc_site_install
- ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
+ $(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 ::
- ].$self->{NOECHO}.q[$(PERL) -e "print 'read ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print 'write ].$self->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_LIB) $(INSTALLPRIVLIB) '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLARCHLIB) '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp
+ $(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
- ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp;
- ].$self->{NOECHO}.q[$(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[
+ $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
+ $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[
# Likewise
pure_site_install ::
- ].$self->{NOECHO}.q[$(PERL) -e "print 'read ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print 'write ].$self->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_LIB) $(INSTALLSITELIB) '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLSITEARCH) '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp
+ $(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
- ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp;
- ].$self->{NOECHO}.q[$(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[
+ $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
+ $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[
# Ditto
doc_perl_install ::
- ].$self->{NOECHO}.q[$(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLPRIVLIB)|'" >.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|'" >>.MM_tmp
-],@docfiles,q[ $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
- ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp;
+ $(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 ::
- ].$self->{NOECHO}.q[$(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLSITELIB)|'" >.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|'" >>.MM_tmp
-],@docfiles,q[ $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
- ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp;
+ $(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
- $(NOOP)
+ $(NOECHO) $(NOOP)
uninstall_from_perldirs ::
- ].$self->{NOECHO}.q[$(UNINSTALL) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[
+ $(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 ::
- ].$self->{NOECHO}.q[$(UNINSTALL) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist')."\n";
+ $(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);
}
@@ -1866,14 +1987,21 @@ $(OBJECT) : $(PERL_INC)vmsish.h, $(PERL_INC)util.h, $(PERL_INC)config.h
# An out of date config.h is not fatal but complains loudly!
#$(PERL_INC)config.h : $(PERL_SRC)config.sh
$(PERL_INC)config.h : $(PERL_VMS)config.vms
- ],$self->{NOECHO},q[Write Sys$Error "Warning: $(PERL_INC)config.h out of date with $(PERL_VMS)config.vms"
+ $(NOECHO) Write Sys$Error "Warning: $(PERL_INC)config.h out of date with $(PERL_VMS)config.vms"
#$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
$(PERL_ARCHLIB)Config.pm : $(PERL_VMS)config.vms $(PERL_VMS)genconfig.pl
- ],$self->{NOECHO},q[Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.vms or genconfig.pl"
+ $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.vms or genconfig.pl"
olddef = F$Environment("Default")
Set Default $(PERL_SRC)
- $(MMS)],$mmsquals,q[ $(MMS$TARGET)
+ $(MMS)],$mmsquals,);
+ if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) {
+ my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm'));
+ $target =~ s/\Q$prefix/[/;
+ push(@m," $target");
+ }
+ else { push(@m,' $(MMS$TARGET)'); }
+ push(@m,q[
Set Default 'olddef'
]);
}
@@ -1904,13 +2032,13 @@ $(OBJECT) : $(FIRST_MAKEFILE)
# 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)
- ],$self->{NOECHO},q[Write Sys$Output "$(MAKEFILE) out-of-date with respect to $(MMS$SOURCE_LIST)"
- ],$self->{NOECHO},q[Write Sys$Output "Cleaning current config before rebuilding $(MAKEFILE) ..."
+ $(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) $(USEMAKEFILE)$(MAKEFILE)_old clean
+ - $(MMS)$(MMSQUALIFIERS) $(USEMAKEFILE)$(MAKEFILE)_old clean
$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL ],join(' ',map(qq["$_"],@ARGV)),q[
- ],$self->{NOECHO},q[Write Sys$Output "$(MAKEFILE) has been rebuilt."
- ],$self->{NOECHO},q[Write Sys$Output "Please run $(MMS) to build the extension."
+ $(NOECHO) $(SAY) "$(MAKEFILE) has been rebuilt."
+ $(NOECHO) $(SAY) "Please run $(MMS) to build the extension."
];
join('',@m);
@@ -1933,25 +2061,25 @@ TEST_FILE = test.pl
TESTDB_SW = -d
test :: \$(TEST_TYPE)
- \$(NOOP)
+ \$(NOECHO) \$(NOOP)
testdb :: testdb_\$(LINKTYPE)
- \$(NOOP)
+ \$(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) $(PASTHRU2) test`'."\n");
+ '; print `$(MMS)$(MMSQUALIFIERS) $(PASTHRU2) test`'."\n");
}
- push(@m, "\t$self->{NOECHO}Write Sys\$Output \"No tests defined for \$(NAME) extension.\"\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, " \$(NOOP)\n") if (!$tests && ! -f "test.pl");
+ push(@m, "\t\$(NOECHO) \$(NOOP)\n") if (!$tests && ! -f "test.pl");
push(@m, "\n");
push(@m, "testdb_dynamic :: pure_all\n");
@@ -1971,8 +2099,8 @@ testdb :: testdb_\$(LINKTYPE)
push(@m, "\n");
}
else {
- push @m, "test_static :: test_dynamic\n\t$self->{NOECHO}\$(NOOP)\n\n";
- push @m, "testdb_static :: testdb_dynamic\n\t$self->{NOECHO}\$(NOOP)\n";
+ 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);
@@ -2027,14 +2155,14 @@ MAP_TARGET = $target
unless ($self->{MAKEAPERL}) {
push @m, q{
$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
- },$self->{NOECHO},q{Write Sys$Output "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
- },$self->{NOECHO},q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \
+ $(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)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET)
+ $(MMS)$(MMSQUALIFIERS)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET)
};
push @m, map( " \\\n\t\t$_", @ARGV );
push @m, "\n";
@@ -2043,7 +2171,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE)
}
- my($linkcmd,@staticopts,@staticpkgs,$extralist,$target,$targdir,$libperldir);
+ my($linkcmd,@staticopts,@staticpkgs,$extralist,$targdir,$libperldir);
# The front matter of the linkcommand...
$linkcmd = join ' ', $Config{'ld'},
@@ -2129,7 +2257,7 @@ $(MAP_TARGET) :: $(MAKE_APERL_FILE)
}
}
- $target = "Perl.Exe" unless $target;
+ $target = "Perl$Config{'exe_ext'}" unless $target;
($shrtarget,$targdir) = fileparse($target);
$shrtarget =~ s/^([^.]*)/$1Shr/;
$shrtarget = $targdir . $shrtarget;
@@ -2179,37 +2307,37 @@ $(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
- ',$self->{NOECHO},'Write Sys$Output "To install the new ""$(MAP_TARGET)"" binary, say"
- ',$self->{NOECHO},'Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
- ',$self->{NOECHO},'Write Sys$Output "To remove the intermediate files, say
- ',$self->{NOECHO},'Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) map_clean"
+ $(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)
- ',$self->{NOECHO},'$(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET)
+ $(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 :
- ].$self->{NOECHO}.q[$(PERL) -e "print 'Perl binary $(MAP_TARGET)|'" >.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print 'MAP_STATIC|$(MAP_STATIC)|'" >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
- ].$self->{NOECHO}.q[$(PERL) -e "print 'MAP_LIBPERL|$(MAP_LIBPERL)|'" >>.MM_tmp
+ $(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[
- ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp;
+ $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
];
push @m, "
inst_perl : pure_inst_perl doc_inst_perl
- \$(NOOP)
+ \$(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
- \$(NOOP)
+ \$(NOECHO) \$(NOOP)
map_clean :
\$(RM_F) ${tmp}perlmain\$(OBJ_EXT) ${tmp}perlmain.c \$(MAKEFILE)
@@ -2219,18 +2347,6 @@ map_clean :
join '', @m;
}
-=item ext (specific)
-
-Stub routine standing in for C<ExtUtils::LibList::ext> until VMS
-support is added to that package.
-
-=cut
-
-sub ext {
- my($self) = @_;
- '','','';
-}
-
# --- Output postprocessing section ---
=item nicetext (override)
@@ -2250,5 +2366,9 @@ sub nicetext {
1;
+=back
+
+=cut
+
__END__
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm b/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm
new file mode 100644
index 00000000000..3545f2c5a4e
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/ExtUtils/MM_Win32.pm
@@ -0,0 +1,784 @@
+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;
+$DMAKE = 1 if $Config{'make'} =~ /^dmake/i;
+$NMAKE = 1 if $Config{'make'} =~ /^nmake/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) = @_;
+ return "$file.exe" if -e "$file.exe";
+ 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'}
+ ||= ( $BORLAND
+ ? 'import32.lib cw32mti.lib '
+ : 'msvcrt.lib oldnames.lib kernel32.lib comdlg32.lib winspool.lib gdi32.lib '
+ .'advapi32.lib user32.lib shell32.lib netapi32.lib ole32.lib '
+ .'oleaut32.lib uuid.lib wsock32.lib mpr.lib winmm.lib version.lib '
+ ) . ' odbc32.lib odbccp32.lib';
+ $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:^"+")' : '-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)
+');
+
+ 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
+{
+ return '$(PERL_INC)\perl$(LIB_EXT)';
+}
+
+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 {
+ 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/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm b/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm
index 4b0b48ac575..b3e8a926099 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm
+++ b/gnu/usr.bin/perl/lib/ExtUtils/MakeMaker.pm
@@ -2,10 +2,10 @@ BEGIN {require 5.002;} # MakeMaker 5.17 was the last MakeMaker that was compatib
package ExtUtils::MakeMaker;
-$Version = $VERSION = "5.34";
+$Version = $VERSION = "5.42";
$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.1.1.1 $, 10)) =~ s/\s+$//;
+($Revision = substr(q$Revision: 1.2 $, 10)) =~ s/\s+$//;
@@ -25,8 +25,9 @@ use vars qw(
);
# use strict;
-eval {require DynaLoader;}; # Get mod2fname, if defined. Will fail
- # with miniperl.
+# &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
@@ -65,11 +66,12 @@ package ExtUtils::Liblist;
package ExtUtils::MakeMaker;
#
-# Now we can can pull in the friends
+# Now we can pull in the friends
#
-$Is_VMS = $^O eq 'VMS';
-$Is_OS2 = $^O =~ m|^os/?2$|i;
-$Is_Mac = $^O eq 'MacOS';
+$Is_VMS = $^O eq 'VMS';
+$Is_OS2 = $^O eq 'os2';
+$Is_Mac = $^O eq 'MacOS';
+$Is_Win32 = $^O eq 'MSWin32';
require ExtUtils::MM_Unix;
@@ -83,6 +85,9 @@ if ($Is_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
@@ -149,10 +154,12 @@ sub ExtUtils::MakeMaker::mksymlists ;
sub ExtUtils::MakeMaker::neatvalue ;
sub ExtUtils::MakeMaker::selfdocument ;
sub ExtUtils::MakeMaker::WriteMakefile ;
-sub ExtUtils::MakeMaker::prompt ;
+sub ExtUtils::MakeMaker::prompt ($;$) ;
1;
-#__DATA__
+
+__DATA__
+
package ExtUtils::MakeMaker;
sub WriteMakefile {
@@ -228,12 +235,12 @@ sub full_setup {
@Attrib_help = qw/
- C 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
+ 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 LIBS
+ 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 PL_FILES PM PMLIBDIRS PREFIX
@@ -241,10 +248,13 @@ sub full_setup {
XS_VERSION clean depend dist dynamic_lib linkext macro realclean
tool_autosplit
- installpm
+ 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
@@ -297,7 +307,7 @@ sub full_setup {
@Get_from_Config =
qw(
ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc
- lib_ext obj_ext ranlib sitelibexp sitearchexp so
+ lib_ext obj_ext ranlib sitelibexp sitearchexp so exe_ext
);
my $item;
@@ -405,20 +415,17 @@ sub ExtUtils::MakeMaker::new {
# This is for old Makefiles written pre 5.00, will go away
if ( Carp::longmess("") =~ /runsubdirpl/s ){
- #$self->{Correct_relativ_directories}++;
Carp::carp("WARNING: Please rerun 'perl Makefile.PL' to regenerate your Makefiles\n");
- } else {
- $self->{Correct_relativ_directories}=0;
}
- my $class = ++$PACKNAME;
+ my $newclass = ++$PACKNAME;
{
# no strict;
- print "Blessing Object into class [$class]\n" if $Verbose>=2;
- mv_all_methods("MY",$class);
- bless $self, $class;
+ print "Blessing Object into class [$newclass]\n" if $Verbose>=2;
+ mv_all_methods("MY",$newclass);
+ bless $self, $newclass;
push @Parent, $self;
- @{"$class\:\:ISA"} = 'MM';
+ @{"$newclass\:\:ISA"} = 'MM';
}
if (defined $Parent[-2]){
@@ -427,10 +434,14 @@ sub ExtUtils::MakeMaker::new {
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});
+ unless $self->file_name_is_absolute($self->{$key})
+ || ($^O eq 'VMS' and ($key =~ /PERL$/ && $self->{$key} =~ /^[\w\-\$]+$/));
}
- $self->{PARENT}->{CHILDREN}->{$class} = $self if $self->{PARENT};
+ $self->{PARENT}->{CHILDREN}->{$newclass} = $self if $self->{PARENT};
} else {
parse_args($self,@ARGV);
}
@@ -442,11 +453,18 @@ sub ExtUtils::MakeMaker::new {
$self->init_main();
if (! $self->{PERL_SRC} ) {
- my($pthinks) = $INC{'Config.pm'};
+ 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 $self->catfile($Config{archlibexp},'Config.pm')){
- $pthinks =~ s!/Config\.pm$!!;
- $pthinks =~ s!.*/!!;
+ 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.
@@ -550,15 +568,8 @@ sub parse_args{
(getpwuid($>))[7]
]ex;
}
- # This may go away, in mid 1996
- if ($self->{Correct_relativ_directories}){
- $value = $self->catdir("..",$value)
- if $Prepend_dot_dot{$name} && ! $self->file_name_is_absolute($value);
- }
$self->{uc($name)} = $value;
}
- # This may go away, in mid 1996
- delete $self->{Correct_relativ_directories};
# catch old-style 'potential_libs' and inform user how to 'upgrade'
if (defined $self->{potential_libs}){
@@ -855,18 +866,26 @@ Makefiles with a single invocation of WriteMakefile().
=head2 How To Write A Makefile.PL
-The short answer is: Don't. 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 very useful C<-X> switch. This will
-generate dummy files of all kinds that are useful for the module
-developer.
+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 below.
+The long answer is the rest of the manpage :-)
=head2 Default Makefile Behaviour
@@ -892,7 +911,7 @@ Other interesting targets in the generated Makefile are
=head2 make test
-MakeMaker checks for the existence of a file named "test.pl" in the
+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.
@@ -902,6 +921,22 @@ 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
@@ -909,7 +944,7 @@ 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.
+ ../../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*
@@ -931,9 +966,7 @@ The INSTALL... macros in turn default to their %Config
You can check the values of these variables on your system with
- perl -MConfig -le 'print join $/, map
- sprintf("%20s: %s", $_, $Config{$_}),
- grep /^install/, keys %Config'
+ perl '-V:install.*'
And to check the sequence in which the library directories are
searched by perl, run
@@ -941,18 +974,29 @@ searched by perl, run
perl -le 'print join $/, @INC'
-=head2 PREFIX attribute
+=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
-The PREFIX attribute can be used to set the INSTALL* attributes in one
-go. The quickest way to install a module in a non-standard place
+ 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 the tilde expansion is done by MakeMaker, not by perl by
-default, nor by make.
+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
@@ -1113,6 +1157,11 @@ 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
@@ -1137,7 +1186,7 @@ so
=item CONFIGURE
CODE reference. The subroutine should return a hash reference. The
-hash may contain further attributes, e.g. {LIBS => ...}, that have to
+hash may contain further attributes, e.g. {LIBS =E<gt> ...}, that have to
be determined by some evaluation method.
=item DEFINE
@@ -1213,6 +1262,10 @@ Perl binary able to run this extension.
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">
@@ -1323,6 +1376,11 @@ specify ld flags)
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
@@ -1515,15 +1573,17 @@ 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.*=/
+ /([\$*])(([\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 ) = '$Revision: 1.1.1.1 $ ' =~ /\$Revision:\s+([^\s]+)/;
+ *VERSION = \'1.01';
+ ( $VERSION ) = '$Revision: 1.2 $ ' =~ /\$Revision:\s+([^\s]+)/;
$FOO::VERSION = '1.10';
+ *FOO::VERSION = \'1.11';
but these will fail:
@@ -1531,9 +1591,16 @@ but these will fail:
local $VERSION = '1.02';
local $FOO::VERSION = '1.30';
-The file named in VERSION_FROM is added as a dependency to Makefile to
-guarantee, that the Makefile contains the correct VERSION macro after
-a change of the file.
+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
@@ -1644,7 +1711,8 @@ either say:
or you can edit the default by saying something like:
sub MY::c_o {
- my($inherited) = shift->SUPER::c_o(@_);
+ package MY; # so that "SUPER" works right
+ my $inherited = shift->SUPER::c_o(@_);
$inherited =~ s/old text/new text/;
$inherited;
}
@@ -1797,11 +1865,10 @@ ExtUtils::Install, ExtUtils::embed
=head1 AUTHORS
-Andy Dougherty F<E<lt>doughera@lafcol.lafayette.eduE<gt>>, Andreas
-KE<ouml>nig F<E<lt>A.Koenig@franz.ww.TU-Berlin.DEE<gt>>, Tim Bunce
-F<E<lt>Tim.Bunce@ig.co.ukE<gt>>. VMS support by Charles Bailey
-F<E<lt>bailey@genetics.upenn.eduE<gt>>. OS/2 support by Ilya
-Zakharevich F<E<lt>ilya@math.ohio-state.eduE<gt>>. Contact the
+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.
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm b/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm
index 67210966bef..cc323c8924f 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm
+++ b/gnu/usr.bin/perl/lib/ExtUtils/Manifest.pm
@@ -1,24 +1,26 @@
package ExtUtils::Manifest;
-
require Exporter;
-@ISA=('Exporter');
-@EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck',
- 'skipcheck', 'maniread', 'manicopy');
-
use Config;
use File::Find;
use File::Copy 'copy';
use Carp;
+use strict;
-$Debug = 0;
-$Verbose = 1;
-$Is_VMS = $^O eq 'VMS';
+use vars qw($VERSION @ISA @EXPORT_OK
+ $Is_VMS $Debug $Verbose $Quiet $MANIFEST $found);
-$VERSION = $VERSION = substr(q$Revision: 1.1.1.1 $,10,4);
+$VERSION = substr(q$Revision: 1.2 $, 10);
+@ISA=('Exporter');
+@EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck',
+ 'skipcheck', 'maniread', 'manicopy');
-$Quiet = 0;
+$Is_VMS = $^O eq 'VMS';
+if ($Is_VMS) { require File::Basename }
+$Debug = 0;
+$Verbose = 1;
+$Quiet = 0;
$MANIFEST = 'MANIFEST';
# Really cool fix from Ilya :)
@@ -83,10 +85,10 @@ sub skipcheck {
sub _manicheck {
my($arg) = @_;
my $read = maniread();
+ my $found = manifind();
my $file;
my(@missfile,@missentry);
if ($arg & 1){
- my $found = manifind();
foreach $file (sort keys %$read){
warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug;
unless ( exists $found->{$file} ) {
@@ -98,7 +100,6 @@ sub _manicheck {
if ($arg & 2){
$read ||= {};
my $matches = _maniskip();
- my $found = manifind();
my $skipwarn = $arg & 4;
foreach $file (sort keys %$found){
if (&$matches($file)){
@@ -117,7 +118,7 @@ sub _manicheck {
sub maniread {
my ($mfile) = @_;
- $mfile = $MANIFEST unless defined $mfile;
+ $mfile ||= $MANIFEST;
my $read = {};
local *M;
unless (open M, $mfile){
@@ -126,8 +127,20 @@ sub maniread {
}
while (<M>){
chomp;
- if ($Is_VMS) { /^(\S+)/ and $read->{"\L$1"}=$_; }
- else { /^(\S+)\s*(.*)/ and $read->{$1}=$2; }
+ 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;
@@ -138,12 +151,13 @@ sub _maniskip {
my ($mfile) = @_;
my $matches = sub {0};
my @skip ;
- $mfile = "$MANIFEST.SKIP" unless defined $mfile;
+ $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, $_;
}
@@ -161,7 +175,7 @@ sub _maniskip {
sub manicopy {
my($read,$target,$how)=@_;
croak "manicopy() called without target argument" unless defined $target;
- $how = 'cp' unless defined $how && $how;
+ $how ||= 'cp';
require File::Path;
require File::Basename;
my(%dirs,$file);
@@ -175,14 +189,13 @@ sub manicopy {
$dir = VMS::Filespec::unixify($dir) if $Is_VMS;
File::Path::mkpath(["$target/$dir"],1,$Is_VMS ? undef : 0755);
}
- if ($Is_VMS) { vms_cp_if_diff($file,"$target/$file"); }
- else { cp_if_diff($file, "$target/$file", $how); }
+ cp_if_diff($file, "$target/$file", $how);
}
}
sub cp_if_diff {
- my($from,$to, $how)=@_;
- -f $from || carp "$0: $from not found";
+ 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";
@@ -197,26 +210,14 @@ sub cp_if_diff {
if (-e $to) {
unlink($to) or confess "unlink $to: $!";
}
- &$how($from, $to);
- }
-}
-
-# Do the comparisons here rather than spawning off another process
-sub vms_cp_if_diff {
- my($from,$to) = @_;
- 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) {
- system('copy',VMS::Filespec::vmsify($from),VMS::Filespec::vmsify($to)) & 1
- or confess "Copy failed: $!";
+ 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'.");
+ }
}
}
@@ -224,13 +225,14 @@ sub cp {
my ($srcFile, $dstFile) = @_;
my ($perm,$access,$mod) = (stat $srcFile)[2,8,9];
copy($srcFile,$dstFile);
- utime $access, $mod, $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;
@@ -242,7 +244,7 @@ sub best {
if (-l $srcFile) {
cp($srcFile, $dstFile);
} else {
- ln($srcFile, $dstFile);
+ ln($srcFile, $dstFile) or cp($srcFile, $dstFile);
}
}
@@ -311,6 +313,8 @@ 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
@@ -326,7 +330,9 @@ make a tree without any symbolic link. Best is the default.
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. A typical example:
+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\.
@@ -350,7 +356,7 @@ 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).
-<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value,
+C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value,
all functions act silently.
=head1 DIAGNOSTICS
@@ -387,6 +393,6 @@ L<ExtUtils::MakeMaker> which has handy targets for most of the functionality.
=head1 AUTHOR
-Andreas Koenig F<E<lt>koenig@franz.ww.TU-Berlin.DEE<gt>>
+Andreas Koenig <F<koenig@franz.ww.TU-Berlin.DE>>
=cut
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm b/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm
index 06c001553bf..ff0aa096b3e 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm
+++ b/gnu/usr.bin/perl/lib/ExtUtils/Mkbootstrap.pm
@@ -1,47 +1,15 @@
package ExtUtils::Mkbootstrap;
+
+$VERSION = substr q$Revision: 1.2 $, 10;
+# $Date: 1997/11/30 07:57:31 $
+
use Config;
use Exporter;
@ISA=('Exporter');
@EXPORT='&Mkbootstrap';
-$Version=2.0; # just to start somewhere
sub Mkbootstrap {
-
-=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
-
my($baseext, @bsloadlibs)=@_;
-
@bsloadlibs = grep($_, @bsloadlibs); # strip empty libs
print STDOUT " bsloadlibs=@bsloadlibs\n" if $Verbose;
@@ -58,6 +26,8 @@ generated C<*.bs> file.
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 $_;
@@ -95,3 +65,39 @@ generated C<*.bs> file.
}
}
+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/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm b/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm
index 5c0173a5085..f47235d990b 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm
+++ b/gnu/usr.bin/perl/lib/ExtUtils/Mksymlists.pm
@@ -7,7 +7,7 @@ use Exporter;
use vars qw( @ISA @EXPORT $VERSION );
@ISA = 'Exporter';
@EXPORT = '&Mksymlists';
-$VERSION = '1.03';
+$VERSION = substr q$Revision: 1.2 $, 10;
sub Mksymlists {
my(%spec) = @_;
@@ -40,6 +40,7 @@ sub Mksymlists {
}
# 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}) ]);
@@ -47,7 +48,8 @@ sub Mksymlists {
if ($osname eq 'aix') { _write_aix(\%spec); }
elsif ($osname eq 'VMS') { _write_vms(\%spec) }
- elsif ($osname =~ m|^os/?2$|i) { _write_os2(\%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"); }
}
@@ -92,13 +94,59 @@ while (($name, $exp)= each %{$data->{IMPORTS}}) {
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')
+ print DEF "LIBRARY \"$data->{DLBASE}\"\n";
+ print DEF "CODE LOADONCALL\n";
+ print DEF "DATA LOADONCALL NONSHARED MULTIPLE\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";
@@ -114,13 +162,15 @@ sub _write_vms {
# the GSMATCH criteria for a dynamic extension
foreach $sym (@{$data->{FUNCLIST}}) {
- if ($isvax) { print OPT "UNIVERSAL=$sym\n" }
- else { print OPT "SYMBOL_VECTOR=($sym=PROCEDURE)\n"; }
+ 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=$sym\n" }
- else { print OPT "SYMBOL_VECTOR=($sym=DATA)\n"; }
+ if ($isvax) { print OPT "UNIVERSAL=$safe\n" }
+ else { print OPT "SYMBOL_VECTOR=($safe=DATA)\n"; }
}
close OPT;
@@ -152,13 +202,15 @@ ExtUtils::Mksymlists - write linker options files for dynamic extension
=head1 DESCRIPTION
C<ExtUtils::Mksymlists> produces files used by the linker under some OSs
-during the creation of shared libraries for synamic extensions. It is
+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
@@ -212,6 +264,8 @@ 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
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm b/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm
index d5596047fb7..57ea87c82fe 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm
+++ b/gnu/usr.bin/perl/lib/ExtUtils/testlib.pm
@@ -1,4 +1,7 @@
package ExtUtils::testlib;
+$VERSION = substr q$Revision: 1.2 $, 10;
+# $Id: testlib.pm,v 1.2 1997/11/30 07:57:32 millert Exp $
+
use lib qw(blib/arch blib/lib);
1;
__END__
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/typemap b/gnu/usr.bin/perl/lib/ExtUtils/typemap
index a9733d0f491..20cc96f0b55 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/typemap
+++ b/gnu/usr.bin/perl/lib/ExtUtils/typemap
@@ -45,6 +45,7 @@ FileHandle T_PTROBJ
InputStream T_IN
InOutStream T_INOUT
OutputStream T_OUT
+bool T_BOOL
#############################################################################
INPUT
@@ -78,6 +79,8 @@ 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
@@ -124,7 +127,7 @@ T_REF_IV_PTR
else
croak(\"$var is not of type ${ntype}\")
T_PTROBJ
- if (sv_isa($arg, \"${ntype}\")) {
+ if (sv_derived_from($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = ($type) tmp;
}
@@ -199,6 +202,8 @@ T_SYSRET
}
T_ENUM
sv_setiv($arg, (IV)$var);
+T_BOOL
+ $arg = boolSV($var);
T_U_INT
sv_setiv($arg, (IV)$var);
T_SHORT
diff --git a/gnu/usr.bin/perl/lib/ExtUtils/xsubpp b/gnu/usr.bin/perl/lib/ExtUtils/xsubpp
index 8554bb5054e..04de166ad67 100644
--- a/gnu/usr.bin/perl/lib/ExtUtils/xsubpp
+++ b/gnu/usr.bin/perl/lib/ExtUtils/xsubpp
@@ -6,7 +6,7 @@ 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<-typemap typemap>]... file.xs
+B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-nolinenumbers>] [B<-typemap typemap>]... file.xs
=head1 DESCRIPTION
@@ -55,6 +55,10 @@ 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.
+
=back
=head1 ENVIRONMENT
@@ -71,20 +75,32 @@ See the file F<changes.pod>.
=head1 SEE ALSO
-perl(1), perlxs(1), perlxstut(1), perlapi(1)
+perl(1), perlxs(1), perlxstut(1)
=cut
-# Global Constants
-$XSUBPP_version = "1.935";
require 5.002;
+use Cwd;
use vars '$cplusplus';
sub Q ;
+# Global Constants
+
+$XSUBPP_version = "1.9505";
+
+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] [-s pattern] [-typemap typemap]... file.xs\n";
+$usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-nolinenumbers] [-s pattern] [-typemap typemap]... file.xs\n";
$proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
@@ -92,10 +108,11 @@ $except = "";
$WantPrototypes = -1 ;
$WantVersionChk = 1 ;
$ProtoUsed = 0 ;
+$WantLineNumbers = 1 ;
SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
$flag = shift @ARGV;
$flag =~ s/^-// ;
- $spat = shift, next SWITCH if $flag eq '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';
@@ -103,6 +120,8 @@ SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
$WantVersionChk = 1, next SWITCH if $flag eq 'versioncheck';
$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;
@@ -115,19 +134,18 @@ else
@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);
-# Check for VMS; Config.pm may not be installed yet, but this routine
-# is built into VMS perl
-if (defined(&VMS::Filespec::vmsify)) { $Is_VMS = 1; $pwd = $ENV{DEFAULT}; }
-else { $Is_VMS = 0; chomp($pwd = `pwd`); }
+$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 ;
@@ -169,6 +187,7 @@ foreach $typemap (@tm) {
$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; }
@@ -183,7 +202,7 @@ foreach $typemap (@tm) {
$type = TidyType($type) ;
$type_kind{$type} = $kind ;
# prototype defaults to '$'
- $proto = '$' unless $proto ;
+ $proto = "\$" unless $proto ;
warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
unless ValidProtoString($proto) ;
$proto_letter{$type} = C_string($proto) ;
@@ -215,6 +234,7 @@ $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
$BLOCK_re= '\s*(' . join('|', qw(
REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
+ SCOPE
)) . "|$END)\\s*:";
# Input: ($_, @line) == unparsed input.
@@ -226,11 +246,59 @@ sub check_keyword {
}
+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 {
- $_ = shift(@line) while !/\S/ && @line;
+ # 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 process_keyword($)
@@ -440,6 +508,24 @@ sub PROTOTYPE_handler ()
}
+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
@@ -570,7 +656,7 @@ sub ProtoString ($)
{
my ($type) = @_ ;
- $proto_letter{$type} or '$' ;
+ $proto_letter{$type} or "\$" ;
}
sub check_cpp {
@@ -608,7 +694,7 @@ open($FH, $filename) or die "cannot open $filename: $!\n";
print <<EOM ;
/*
* This file was generated automatically by xsubpp version $XSUBPP_version from the
- * contents of $filename. Don't edit this file, edit $filename instead.
+ * contents of $filename. Do not edit this file, edit $filename instead.
*
* ANY CHANGES MADE HERE WILL BE LOST!
*
@@ -617,6 +703,9 @@ print <<EOM ;
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*$/;
@@ -627,7 +716,6 @@ while (<$FH>) {
$lastline = $_;
$lastline_no = $.;
-
# Read next xsub into @line from ($lastline, <$FH>).
sub fetch_para {
# parse paragraph
@@ -642,6 +730,7 @@ sub fetch_para {
$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;
@@ -722,7 +811,9 @@ while (fetch_para()) {
$XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
}
- death ("Code is not inside a function")
+ 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
@@ -737,7 +828,9 @@ while (fetch_para()) {
undef(%arg_list) ;
undef(@proto_arg) ;
undef($proto_in_this_xsub) ;
+ undef($scope_in_this_xsub) ;
$ProtoThisXSUB = $WantPrototypes ;
+ $ScopeThisXSUB = 0;
$_ = shift(@line);
while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
@@ -748,7 +841,9 @@ while (fetch_para()) {
if (check_keyword("BOOT")) {
&check_cpp;
- push (@BootCode, $_, @line, "") ;
+ push (@BootCode, "#line $line_no[@line_no - @line] \"$filename\"")
+ if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
+ push (@BootCode, @line, "") ;
next PARAGRAPH ;
}
@@ -768,12 +863,14 @@ while (fetch_para()) {
($class, $func_name, $orig_args) = ($1, $2, $3) ;
($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
- $Full_func_name = "${Packid}_$func_name";
+ ($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 '$func_name' detected");
+ Warn("Warning: duplicate function definition '$clean_func_name' detected");
last;
}
$XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
@@ -781,7 +878,8 @@ while (fetch_para()) {
@args = split(/\s*,\s*/, $orig_args);
if (defined($class)) {
- my $arg0 = ((defined($static) or $func_name =~ /^new/) ? "CLASS" : "THIS");
+ my $arg0 = ((defined($static) or $func_name eq 'new')
+ ? "CLASS" : "THIS");
unshift(@args, $arg0);
($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
}
@@ -802,7 +900,7 @@ while (fetch_para()) {
$defaults{$args[$i]} = $2;
$defaults{$args[$i]} =~ s/"/\\"/g;
}
- $proto_arg[$i+1] = '$' ;
+ $proto_arg[$i+1] = "\$" ;
}
if (defined($class)) {
$func_args = join(", ", @args[1..$#args]);
@@ -812,11 +910,16 @@ while (fetch_para()) {
@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);
# print function header
print Q<<"EOF";
-#XS(XS_${Packid}_$func_name)
+#XS(XS_${Full_func_name})
#[[
# dXSARGS;
EOF
@@ -875,10 +978,15 @@ EOF
$gotRETVAL = 0;
INPUT_handler() ;
- process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE") ;
+ process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE|SCOPE") ;
+ print Q<<"EOF" if $ScopeThisXSUB;
+# ENTER;
+# [[
+EOF
+
if (!$thisdone && defined($class)) {
- if (defined($static) or $func_name =~ /^new/) {
+ if (defined($static) or $func_name eq 'new') {
print "\tchar *";
$var_types{"CLASS"} = "char *";
&generate_init("char *", 1, "CLASS");
@@ -901,12 +1009,15 @@ EOF
$args_match{"RETVAL"} = 0;
$var_types{"RETVAL"} = $ret_type;
}
+
print $deferred;
- process_keyword("INIT|ALIAS|PROTOTYPE") ;
+
+ process_keyword("INIT|ALIAS|PROTOTYPE") ;
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() ;
@@ -920,13 +1031,13 @@ EOF
$wantRETVAL = 1;
}
if (defined($static)) {
- if ($func_name =~ /^new/) {
+ if ($func_name eq 'new') {
$func_name = "$class";
} else {
print "${class}::";
}
} elsif (defined($class)) {
- if ($func_name =~ /^new/) {
+ if ($func_name eq 'new') {
$func_name .= " $class";
} else {
print "THIS->";
@@ -954,6 +1065,13 @@ EOF
# 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;
# ]]
@@ -979,9 +1097,15 @@ EOF
# croak(errbuf);
EOF
- print Q<<EOF unless $PPCODE;
+ 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;
#]]
@@ -995,11 +1119,11 @@ EOF
if ($ProtoThisXSUB) {
$newXS = "newXSproto";
- if ($ProtoThisXSUB == 2) {
+ if ($ProtoThisXSUB eq 2) {
# User has specified empty prototype
$proto = ', ""' ;
}
- elsif ($ProtoThisXSUB != 1) {
+ elsif ($ProtoThisXSUB ne 1) {
# User has specified a prototype
$proto = ', "' . $ProtoThisXSUB . '"';
}
@@ -1066,8 +1190,9 @@ EOF
if (@BootCode)
{
- print "\n /* Initialisation Section */\n" ;
- print grep (s/$/\n/, @BootCode) ;
+ print "\n /* Initialisation Section */\n\n" ;
+ @line = @BootCode;
+ print_section();
print "\n /* End of Initialisation Section */\n\n" ;
}
@@ -1137,16 +1262,19 @@ sub generate_init {
$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/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"/;
$deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
- } elsif ($expr !~ /^\t\$var =/) {
+ } elsif ($ScopeThisXSUB or $expr !~ /^\t\$var =/) {
eval qq/print "\\t$var;\\n"/;
$deferred .= eval qq/"\\n$expr;\\n"/;
} else {
@@ -1186,11 +1314,27 @@ sub generate_output {
eval "print qq\a$expr\a";
}
elsif ($var eq 'RETVAL') {
- if ($expr =~ /^\t\$arg = /) {
+ if ($expr =~ /^\t\$arg = new/) {
+ # We expect that $arg has refcnt 1, so we need to
+ # mortalize it.
eval "print qq\a$expr\a";
print "\tsv_2mortal(ST(0));\n";
}
+ elsif ($expr =~ /^\s*\$arg\s*=/) {
+ # We expect that $arg has refcnt >=1, so we need
+ # to mortalize it. However, the extension may have
+ # returned the built-in perl value, which is
+ # read-only, thus not mortalizable. However, it is
+ # safe to leave it as it is, since it would be
+ # ignored by REFCNT_dec. Builtin values have REFCNT==0.
+ eval "print qq\a$expr\a";
+ print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n";
+ }
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";
}
@@ -1214,5 +1358,6 @@ 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 ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
+ exit ($errors ? 1 : 0);
}
diff --git a/gnu/usr.bin/perl/lib/File/Basename.pm b/gnu/usr.bin/perl/lib/File/Basename.pm
index daff148a638..e4863f8911a 100644
--- a/gnu/usr.bin/perl/lib/File/Basename.pm
+++ b/gnu/usr.bin/perl/lib/File/Basename.pm
@@ -2,8 +2,6 @@ package File::Basename;
=head1 NAME
-Basename - parse file specifications
-
fileparse - split a pathname into pieces
basename - extract just the filename from a path
@@ -34,16 +32,23 @@ pieces using the syntax of different operating systems.
=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", or "MacOS", 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
+"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.
@@ -61,8 +66,8 @@ 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 be identical to the
-input file specification.
+B<suffix> together in that order, the result will denote the same
+file as the input file specification.
=back
@@ -70,14 +75,14 @@ input file specification.
Using UNIX file syntax:
- ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
+ ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
'\.book\d+');
would yield
$base eq 'draft'
- $path eq '/virgil/aeneid',
- $tail eq '.book7'
+ $path eq '/virgil/aeneid/',
+ $type eq '.book7'
Similarly, using VMS syntax:
@@ -90,120 +95,100 @@ would yield
$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. It is provided for
-compatibility with the UNIX shell command basename(1).
+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. When using UNIX or MSDOS syntax, the return
+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
require 5.002;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
+#use strict;
+#use vars qw($VERSION $Fileparse_fstype $Fileparse_igncase);
+$VERSION = "2.5";
+
# fileparse_set_fstype() - specify OS-based rules used in future
# calls to routines in this package
#
-# Currently recognized values: VMS, MSDOS, MacOS
-# Any other name uses Unix-style rules
+# 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_fstype = $_[0] if $_[0];
- $old;
+ my @old = ($Fileparse_fstype, $Fileparse_igncase);
+ if (@_) {
+ $Fileparse_fstype = $_[0];
+ $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32)/i);
+ }
+ wantarray ? @old : $old[0];
}
# fileparse() - parse file specification
#
-# calling sequence:
-# ($filename,$prefix,$tail) = &basename_pat($filespec,@excludelist);
-# where $filespec is the file specification to be parsed, and
-# @excludelist is a list of patterns which should be removed
-# from the end of $filename.
-# $filename is the part of $filespec after $prefix (i.e. the
-# name of the file). The elements of @excludelist
-# are compared to $filename, and if an
-# $prefix is the path portion $filespec, up to and including
-# the end of the last directory name
-# $tail any characters removed from $filename because they
-# matched an element of @excludelist.
-#
-# fileparse() first removes the directory specification from $filespec,
-# according to the syntax of the OS (code is provided below to handle
-# VMS, Unix, MSDOS and MacOS; you can pick the one you want using
-# fileparse_set_fstype(), or you can accept the default, which is
-# based on the information in the builtin variable $^O). It then compares
-# each element of @excludelist to $filename, and if that element is a
-# suffix of $filename, it is removed from $filename and prepended to
-# $tail. By specifying the elements of @excludelist in the right order,
-# you can 'nibble back' $filename to extract the portion of interest
-# to you.
-#
-# For example, on a system running Unix,
-# ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
-# '\.book\d+');
-# would yield $base == 'draft',
-# $path == '/virgil/aeneid/' (note trailing slash)
-# $tail == '.book7'.
-# Similarly, on a system running VMS,
-# ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*');
-# would yield $name == 'Rhetoric';
-# $dir == 'Doc_Root:[Help]', and
-# $type == '.Rnh'.
-#
-# Version 2.2 13-Oct-1994 Charles Bailey bailey@genetics.upenn.edu
+# Version 2.4 27-Sep-1996 Charles Bailey bailey@genetics.upenn.edu
sub fileparse {
my($fullname,@suffices) = @_;
- my($fstype) = $Fileparse_fstype;
- my($dirpath,$tail,$suffix);
+ my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
+ my($dirpath,$tail,$suffix,$basename);
if ($fstype =~ /^VMS/i) {
if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation
else {
- ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
- $dirpath = $ENV{'DEFAULT'} unless $dirpath;
+ ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/);
}
}
- if ($fstype =~ /^MSDOS/i) {
- ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/);
- $dirpath = '.\\' unless $dirpath;
+ if ($fstype =~ /^MS(DOS|Win32)/i) {
+ ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/);
+ $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/;
}
- elsif ($fstype =~ /^MAC/i) {
- ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
+ 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#(.*/)?(.*)#);
+ ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#);
$dirpath = './' unless $dirpath;
}
if (@suffices) {
$tail = '';
foreach $suffix (@suffices) {
- if ($basename =~ /($suffix)$/) {
+ my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
+ if ($basename =~ s/$pat//) {
$tail = $1 . $tail;
- $basename = $`;
}
}
}
wantarray ? ($basename,$dirpath,$tail) : $basename;
-
}
@@ -213,7 +198,7 @@ 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
@@ -228,25 +213,40 @@ sub dirname {
if ($fstype =~ /VMS/i) {
if ($_[0] =~ m#/#) { $fstype = '' }
- else { return $dirname }
+ else { return $dirname || $ENV{DEFAULT} }
}
if ($fstype =~ /MacOS/i) { return $dirname }
elsif ($fstype =~ /MSDOS/i) {
- if ( $dirname =~ /:\\$/) { return $dirname }
+ $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 $basename;
- $dirname = '.' unless $dirname;
+ $dirname =~ s#[^:/]+$## unless length($basename);
}
else {
- if ( $dirname eq '/') { return $dirname }
- chop $dirname;
- $dirname =~ s:[^/]+$:: unless $basename;
- $dirname = '.' unless $dirname;
+ $dirname =~ s:(.)/*$:$1:;
+ unless( length($basename) ) {
+ local($File::Basename::Fileparse_fstype) = $fstype;
+ ($basename,$dirname) = fileparse $dirname;
+ $dirname =~ s:(.)/*$:$1:;
+ }
}
$dirname;
}
-$Fileparse_fstype = $^O;
+fileparse_set_fstype $^O;
1;
diff --git a/gnu/usr.bin/perl/lib/File/Compare.pm b/gnu/usr.bin/perl/lib/File/Compare.pm
new file mode 100644
index 00000000000..2f9c45c4c60
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/File/Copy.pm b/gnu/usr.bin/perl/lib/File/Copy.pm
index 68460130109..e95168e24b8 100644
--- a/gnu/usr.bin/perl/lib/File/Copy.pm
+++ b/gnu/usr.bin/perl/lib/File/Copy.pm
@@ -2,66 +2,94 @@
# 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;
-require Exporter;
+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';
-@ISA=qw(Exporter);
-@EXPORT=qw(copy);
-@EXPORT_OK=qw(copy cp);
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(copy move);
+@EXPORT_OK = qw(cp mv);
-$File::Copy::VERSION = '1.5';
-$File::Copy::Too_Big = 1024 * 1024 * 2;
+$Too_Big = 1024 * 1024 * 2;
-sub VERSION {
- # Version of File::Copy
- return $File::Copy::VERSION;
+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( file1, file2 [, buffersize]) ")
+ croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
unless(@_ == 2 || @_ == 3);
- if (($^O eq 'VMS' or $^O eq 'os2') && ref(\$to) ne 'GLOB' &&
- !(defined ref $to and (ref($to) eq 'GLOB' ||
- ref($to) eq 'FileHandle' || ref($to) eq 'VMS::Stdio')))
- { return File::Copy::syscopy($_[0],$_[1]) }
-
my $from = shift;
my $to = shift;
- my $recsep = $\;
- my $closefrom=0;
- my $closeto=0;
- my ($size, $status, $r, $buf);
- local(*FROM, *TO);
- $\ = '';
+ 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 (ref(\$from) eq 'GLOB') {
- *FROM = $from;
- } elsif (defined ref $from and
- (ref($from) eq 'GLOB' || ref($from) eq 'FileHandle' ||
- ref($from) eq 'VMS::Stdio')) {
- *FROM = *$from;
- } else {
- open(FROM,"<$from")||goto(fail_open1);
- binmode FROM;
- $closefrom = 1;
+ if (defined &syscopy && \&syscopy != \&copy
+ && !$to_a_handle
+ && !($from_a_handle && $^O eq 'os2')) # OS/2 cannot handle handles
+ {
+ return syscopy($from, $to);
}
- if (ref(\$to) eq 'GLOB') {
- *TO = $to;
- } elsif (defined ref $to and
- (ref($to) eq 'GLOB' || ref($to) eq 'FileHandle' ||
- ref($to) eq 'VMS::Stdio')) {
- *TO = *$to;
+ my $closefrom = 0;
+ my $closeto = 0;
+ my ($size, $status, $r, $buf);
+ local(*FROM, *TO);
+ local($\) = '';
+
+ if ($from_a_handle) {
+ *FROM = *$from{FILEHANDLE};
} else {
- open(TO,">$to")||goto(fail_open2);
- binmode TO;
- $closeto=1;
- }
+ $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;
@@ -69,19 +97,25 @@ sub copy {
} else {
$size = -s FROM;
$size = 1024 if ($size < 512);
- $size = $File::Copy::Too_Big if ($size > $File::Copy::Too_Big);
+ $size = $Too_Big if ($size > $Too_Big);
}
- $buf = '';
- while(defined($r = read(FROM,$buf,$size)) && $r > 0) {
- if (syswrite (TO,$buf,$r) != $r) {
- goto fail_inner;
+ $! = 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;
}
}
- goto fail_inner unless(defined($r));
+
close(TO) || goto fail_open2 if $closeto;
close(FROM) || goto fail_open1 if $closefrom;
- $\ = $recsep;
+
+ # Use this idiom to avoid uninitialized value warning.
return 1;
# All of these contortions try to preserve error messages...
@@ -100,14 +134,47 @@ sub copy {
$! = $status unless $!;
}
fail_open1:
- $\ = $recsep;
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
-*syscopy = ($^O eq 'VMS' ? \&rmscopy : \&copy) unless $^O eq 'os2';
+*syscopy = ($^O eq 'VMS' ? \&rmscopy : \&copy) unless defined &syscopy;
1;
@@ -123,6 +190,7 @@ File::Copy - Copy files or filehandles
copy("file1","file2");
copy("Copy.pm",\*STDOUT);'
+ move("/dev1/fileA","/dev2/fileB");
use POSIX;
use File::Copy cp;
@@ -132,16 +200,28 @@ File::Copy - Copy files or filehandles
=head1 DESCRIPTION
-The File::Copy module provides a basic function C<copy> which takes two
+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). Note that passing in
+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.
+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
@@ -153,6 +233,24 @@ upon the file, but will generally be the whole file (up to 2Mb), or
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
@@ -161,25 +259,28 @@ 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 under VMS
+=head2 Special behavior if C<syscopy> is defined (VMS and OS/2)
-If the second argument to C<copy> is not a file handle for an
-already opened file, then C<copy> will perform an RMS copy of
+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 the second argument to C<copy> is a
-Perl handle to an opened file, then data is copied using Perl
+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 RMS copy routine may also be called directly under VMS
-as C<File::Copy::rmscopy> (or C<File::Copy::syscopy>, which
-is just an alias for this routine).
+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, or
-typeglob references; they are used in all cases to obtain the
+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.
@@ -195,8 +296,8 @@ 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 < 0, none of the input file's
-timestamps are propagated to the output file. If it is > 0, then
+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
@@ -210,15 +311,17 @@ 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
-Returns 1 on success, 0 on failure. $! will be set if an error was
-encountered.
+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.
-The VMS-specific code was added by Charles Bailey
-I<E<lt>bailey@genetics.upenn.eduE<gt>> in March 1996.
+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/gnu/usr.bin/perl/lib/File/DosGlob.pm b/gnu/usr.bin/perl/lib/File/DosGlob.pm
new file mode 100644
index 00000000000..4597c715640
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/File/DosGlob.pm
@@ -0,0 +1,250 @@
+#!perl -w
+
+#
+# Documentation at the __END__
+#
+
+package File::DosGlob;
+
+unless (caller) {
+ $| = 1;
+ while (@ARGV) {
+ #
+ # We have to do this one by one for compatibility reasons.
+ # If an arg doesn't match anything, we are supposed to return
+ # the original arg. I know, it stinks, eh?
+ #
+ my $arg = shift;
+ my @m = doglob(1,$arg);
+ print (@m ? join("\0", sort @m) : $arg);
+ print "\0" if @ARGV;
+ }
+}
+
+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;
+
+ # glob without args defaults to $_
+ $pat = $_ unless defined $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;
+ my $callpkg = caller(0);
+ my $sym = shift;
+ *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym}
+ if defined($sym) and $sym eq 'glob';
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+File::DosGlob - DOS like globbing and then some
+
+perlglob.bat - a more capable perlglob.exe replacement
+
+=head1 SYNOPSIS
+
+ require 5.004;
+
+ # override CORE::glob in current package
+ use File::DosGlob '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?>"
+
+ > perlglob ../pe*/*p?
+
+=head1 DESCRIPTION
+
+A module that implements DOS-like globbing with a few enhancements.
+This file is also a portable replacement for perlglob.exe. 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.
+
+When invoked as a program, it will print null-separated filenames
+to standard output.
+
+While one may replace perlglob.exe with this, usage by overriding
+CORE::glob via importation should be much more efficient, because
+it avoids launching a separate process, and is therefore strongly
+recommended. Note that it is currently possible to override
+builtins like glob() only on a per-package basis, not "globally".
+Thus, every namespace that wants to override glob() must explicitly
+request the override. See L<perlsub>.
+
+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 *
+
+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
+
+=cut
+
diff --git a/gnu/usr.bin/perl/lib/File/Find.pm b/gnu/usr.bin/perl/lib/File/Find.pm
index 02bacd8fc25..033cfe5e9de 100644
--- a/gnu/usr.bin/perl/lib/File/Find.pm
+++ b/gnu/usr.bin/perl/lib/File/Find.pm
@@ -31,6 +31,9 @@ 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 primarily for the C<find2perl> tool, which when fed,
find2perl / -name .nfs\* -mtime +7 \
@@ -62,6 +65,10 @@ that don't resolve:
-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);
@@ -70,27 +77,34 @@ that don't resolve:
sub find {
my $wanted = shift;
- my $cwd = Cwd::fastcwd();
- my ($topdir,$topdev,$topino,$topmode,$topnlink);
+ my $cwd = Cwd::cwd();
+ # Localize these rather than lexicalizing them for backwards
+ # compatibility.
+ local($topdir,$topdev,$topino,$topmode,$topnlink);
foreach $topdir (@_) {
- (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+ (($topdev,$topino,$topmode,$topnlink) =
+ ($Is_VMS ? stat($topdir) : lstat($topdir)))
|| (warn("Can't stat $topdir: $!\n"), next);
if (-d _) {
if (chdir($topdir)) {
($dir,$_) = ($topdir,'.');
$name = $topdir;
+ $prune = 0;
&$wanted;
- my $fixtopdir = $topdir;
- $fixtopdir =~ s,/$,, ;
- $fixtopdir =~ s/\.dir$// if $Is_VMS; ;
- &finddir($wanted,$fixtopdir,$topnlink);
+ if (!$prune) {
+ my $fixtopdir = $topdir;
+ $fixtopdir =~ s,/$,, ;
+ $fixtopdir =~ s/\.dir$// if $Is_VMS;
+ $fixtopdir =~ s/\\dir$// if $Is_NT;
+ &finddir($wanted,$fixtopdir,$topnlink);
+ }
}
else {
warn "Can't cd to $topdir: $!\n";
}
}
else {
- unless (($dir,$_) = File::Basename::fileparse($topdir)) {
+ unless (($_,$dir) = File::Basename::fileparse($topdir)) {
($dir,$_) = ('.', $topdir);
}
$name = $topdir;
@@ -142,6 +156,7 @@ sub finddir {
if (!$prune && chdir $_) {
$name =~ s/\.dir$// if $Is_VMS;
+ $name =~ s/\\dir$// if $Is_NT;
&finddir($wanted,$name,$nlink);
chdir '..';
}
@@ -158,15 +173,19 @@ sub finddepth {
$cwd = Cwd::fastcwd();;
- my($topdir, $topdev, $topino, $topmode, $topnlink);
+ # Localize these rather than lexicalizing them for backwards
+ # compatibility.
+ local($topdir, $topdev, $topino, $topmode, $topnlink);
foreach $topdir (@_) {
- (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
+ (($topdev,$topino,$topmode,$topnlink) =
+ ($Is_VMS ? stat($topdir) : lstat($topdir)))
|| (warn("Can't stat $topdir: $!\n"), next);
if (-d _) {
if (chdir($topdir)) {
my $fixtopdir = $topdir;
$fixtopdir =~ s,/$,, ;
$fixtopdir =~ s/\.dir$// if $Is_VMS;
+ $fixtopdir =~ s/\\dir$// if $Is_NT;
&finddepthdir($wanted,$fixtopdir,$topnlink);
($dir,$_) = ($fixtopdir,'.');
$name = $fixtopdir;
@@ -177,9 +196,10 @@ sub finddepth {
}
}
else {
- unless (($dir,$_) = File::Basename::fileparse($topdir)) {
+ unless (($_,$dir) = File::Basename::fileparse($topdir)) {
($dir,$_) = ('.', $topdir);
}
+ $name = $topdir;
chdir $dir && &$wanted;
}
chdir $cwd;
@@ -225,6 +245,7 @@ sub finddepthdir {
if (chdir $_) {
$name =~ s/\.dir$// if $Is_VMS;
+ $name =~ s/\\dir$// if $Is_NT;
&finddepthdir($wanted,$name,$nlink);
chdir '..';
}
@@ -247,9 +268,13 @@ if ($^O eq 'VMS') {
$Is_VMS = 1;
$dont_use_nlink = 1;
}
+if ($^O =~ m:^mswin32:i) {
+ $Is_NT = 1;
+ $dont_use_nlink = 1;
+}
-$dont_use_nlink = 1 if $^O eq 'os2';
-$dont_use_nlink = 1 if $^O =~ m:^mswin32$:i ;
+$dont_use_nlink = 1
+ if $^O eq 'os2' || $^O eq 'msdos' || $^O eq 'amigaos';
1;
diff --git a/gnu/usr.bin/perl/lib/File/Path.pm b/gnu/usr.bin/perl/lib/File/Path.pm
index 97cb66855dc..43856dfe7b9 100644
--- a/gnu/usr.bin/perl/lib/File/Path.pm
+++ b/gnu/usr.bin/perl/lib/File/Path.pm
@@ -14,9 +14,9 @@ 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:
+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
@@ -38,8 +38,8 @@ the numeric mode to use when creating the directories
=back
-It returns a list of all directories (including intermediates, determined using
-the Unix '/' separator) created.
+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>.
@@ -69,34 +69,50 @@ 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)
+than VMS is settled. (defaults to FALSE)
=back
-It returns the number of files successfully deleted. Symlinks are
+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 <Tim.Bunce@ig.co.uk>
-Charles Bailey <bailey@genetics.upenn.edu>
+Tim Bunce <F<Tim.Bunce@ig.co.uk>> and
+Charles Bailey <F<bailey@genetics.upenn.edu>>
=head1 REVISION
-This module was last revised 14-Feb-1996, for perl 5.002. $VERSION is
-1.01.
+Current $VERSION is 1.04.
=cut
-$VERSION = "1.01"; # That's my hobby-horse, A.K.
-
-require 5.000;
use Carp;
-require Exporter;
+use File::Basename ();
+use DirHandle ();
+use Exporter ();
+use strict;
+
+use vars qw( $VERSION @ISA @EXPORT );
+$VERSION = "1.04";
@ISA = qw( Exporter );
@EXPORT = qw( mkpath rmtree );
-$Is_VMS = $^O eq 'VMS';
+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 'msdos' || $^O eq 'MSWin32'
+ || $^O eq 'amigaos');
sub mkpath {
my($paths, $verbose, $mode) = @_;
@@ -106,17 +122,19 @@ sub mkpath {
local($")="/";
$mode = 0777 unless defined($mode);
$paths = [$paths] unless ref $paths;
- my(@created);
- foreach $path (@$paths){
- next if -d $path;
- my(@p);
- foreach(split(/\//, $path)){
- push(@p, $_);
- next if -d "@p/";
- print "mkdir @p\n" if $verbose;
- mkdir("@p",$mode) || croak "mkdir @p: $!";
- push(@created, "@p");
- }
+ my(@created,$path);
+ foreach $path (@$paths) {
+ 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);
+ 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;
}
@@ -126,40 +144,81 @@ sub rmtree {
my(@files);
my($count) = 0;
$roots = [$roots] unless ref $roots;
+ $verbose ||= 0;
+ $safe ||= 0;
+ my($root);
foreach $root (@{$roots}) {
- $root =~ s#/$##;
- if (not -l $root and -d _) {
- opendir(D,$root);
- ($root = VMS::Filespec::unixify($root)) =~ s#\.dir$## if $Is_VMS;
- @files = map("$root/$_", grep $_!~/^\.{1,2}$/, readdir(D));
- closedir(D);
- $count += rmtree(\@files,$verbose,$safe);
- if ($safe &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
- print "skipped $root\n" if $verbose;
- next;
- }
- print "rmdir $root\n" if $verbose;
- (rmdir $root && ++$count) or carp "Can't remove directory $root: $!";
- }
- else {
- if ($safe &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
- print "skipped $root\n" if $verbose;
- next;
- }
- print "unlink $root\n" if $verbose;
- while (-e $root || -l $root) { # delete all versions under VMS
- (unlink($root) && ++$count)
- or carp "Can't unlink file $root: $!";
- }
- }
+ $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
+ while (-e $root || -l $root) {
+ if (unlink $root) {
+ ++$count;
+ }
+ else {
+ 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");
+ }
+ }
+ }
+ }
}
$count;
}
1;
-
-__END__
diff --git a/gnu/usr.bin/perl/lib/File/stat.pm b/gnu/usr.bin/perl/lib/File/stat.pm
new file mode 100644
index 00000000000..f5d17f7da44
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/FileCache.pm b/gnu/usr.bin/perl/lib/FileCache.pm
index 3d01371b3b3..e1c5ec4c8a8 100644
--- a/gnu/usr.bin/perl/lib/FileCache.pm
+++ b/gnu/usr.bin/perl/lib/FileCache.pm
@@ -19,7 +19,7 @@ maximum.
=head1 BUGS
F<sys/param.h> lies with its C<NOFILE> define on some systems,
-so you may have to set $cacheout::maxopen yourself.
+so you may have to set $FileCache::cacheout_maxopen yourself.
=cut
@@ -53,7 +53,7 @@ sub cacheout {
($file) = @_;
unless (defined $cacheout_maxopen) {
if (open(PARAM,'/usr/include/sys/param.h')) {
- local $.;
+ local ($_, $.);
while (<PARAM>) {
$cacheout_maxopen = $1 - 4
if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
diff --git a/gnu/usr.bin/perl/lib/FileHandle.pm b/gnu/usr.bin/perl/lib/FileHandle.pm
new file mode 100644
index 00000000000..455fc63917d
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/FileHandle.pm
@@ -0,0 +1,258 @@
+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
+
+=head1 SEE ALSO
+
+The B<IO> extension,
+L<perlfunc>,
+L<perlop/"I/O Operators">.
+
+=cut
diff --git a/gnu/usr.bin/perl/lib/FindBin.pm b/gnu/usr.bin/perl/lib/FindBin.pm
new file mode 100644
index 00000000000..918775cda7f
--- /dev/null
+++ b/gnu/usr.bin/perl/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.4 $ =~ /(\d+)\.(\d+)/);
+
+sub is_abs_path
+{
+ local $_ = shift if (@_);
+ if ($^O eq 'MSWin32')
+ {
+ 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 = ($IsWin32) ? 'Path' : '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/gnu/usr.bin/perl/lib/Getopt/Long.pm b/gnu/usr.bin/perl/lib/Getopt/Long.pm
index df306d68c99..4f23f5d6c13 100644
--- a/gnu/usr.bin/perl/lib/Getopt/Long.pm
+++ b/gnu/usr.bin/perl/lib/Getopt/Long.pm
@@ -1,22 +1,15 @@
-# GetOpt::Long.pm -- POSIX compatible options parsing
+# GetOpt::Long.pm -- Universal options parsing
-# RCS Status : $Id: Long.pm,v 1.1.1.1 1996/08/19 10:12:44 downsj Exp $
+package Getopt::Long;
+
+# RCS Status : $Id: Long.pm,v 1.2 1997/11/30 07:57:41 millert Exp $
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Fri Feb 2 21:24:32 1996
-# Update Count : 347
+# Last Modified On: Wed Sep 17 12:20:10 1997
+# Update Count : 608
# Status : Released
-package Getopt::Long;
-require 5.000;
-require Exporter;
-
-@ISA = qw(Exporter);
-@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/);
-use strict;
-
=head1 NAME
GetOptions - extended processing of command line options
@@ -32,9 +25,10 @@ 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 "--". There is no bundling of command line options, as was
-the case with the more traditional single-letter approach. For
-example, the UNIX "ps" command can be given the command line "option"
+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
@@ -55,18 +49,19 @@ 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);
+ 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. The following call is
-equivalent to the example above:
+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");
+ 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
@@ -81,7 +76,7 @@ followed by an argument specifier. Values for argument specifiers are:
=over 8
-=item <none>
+=item E<lt>noneE<gt>
Option does not take an argument.
The option variable will be set to 1.
@@ -150,7 +145,7 @@ specified but a ref HASH is passed, GetOptions will place the value in
the HASH. For example:
%optctl = ();
- &GetOptions (\%optctl, "size=i");
+ GetOptions (\%optctl, "size=i");
will perform the equivalent of the assignment
@@ -159,13 +154,24 @@ will perform the equivalent of the assignment
For array options, a reference to an array is used, e.g.:
%optctl = ();
- &GetOptions (\%optctl, "sizes=i@");
+ 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,
@@ -175,7 +181,7 @@ 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@");
+ GetOptions ("size=i", "sizes=i@");
with command line "-size 10 -sizes 24 -sizes 48" will perform the
equivalent of the assignments
@@ -187,7 +193,7 @@ 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 or a reference to a subroutine.
+an array, a reference to a hash or a reference to a subroutine.
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
@@ -196,6 +202,11 @@ 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.
@@ -204,19 +215,21 @@ The option name is always the true name, not an abbreviation or alias.
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
-op this option. If no linkage is specified, options "foo", "bar" and
+of this option. If no linkage is specified, options "foo", "bar" and
"blech" all will set $opt_foo.
Option names may be abbreviated to uniqueness, depending on
-configuration variable $Getopt::Long::autoabbrev.
+configuration option B<auto_abbrev>.
=head2 Non-option call-back routine
-A special option specifier, <>, can be used to designate a subroutine
+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 $Getopt::Long::order to have the value $PERMUTE.
+This feature requires configuration option B<permute>, see section
+CONFIGURATION OPTIONS.
+
See also the examples.
=head2 Option starters
@@ -242,13 +255,20 @@ 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. This only applies if no linkage is supplied.
+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 configuration variable $Getopt::Long::getopt_compat is set to a
-non-zero value, options that start with "+" may also include their
-arguments, e.g. "+foo=bar". This is for compatiblity with older
-implementations of the GNU "getopt" routine.
+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
@@ -281,64 +301,90 @@ In GNU or POSIX format, option names and values can be combined:
--bar= -> $opt_bar = ''
--bar=-- -> $opt_bar = '--'
-Example of using variabel references:
+Example of using variable references:
- $ret = &GetOptions ('foo=s', \$foo, 'bar=i', 'ar=s', \@ar);
+ $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:
- $bar = 'blech'
+ $foo = 'blech'
$opt_bar = 24
@ar = ('xx','yy')
-Example of using the <> option specifier:
+Example of using the E<lt>E<gt> option specifier:
@ARGV = qw(-foo 1 bar -foo 2 blech);
- &GetOptions("foo=i", \$myfoo, "<>", \&mysub);
+ GetOptions("foo=i", \$myfoo, "<>", \&mysub);
Results:
- &mysub("bar") will be called (with $myfoo being 1)
- &mysub("blech") will be called (with $myfoo being 2)
+ 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);
+ GetOptions("foo=i", \$myfoo);
This will leave the non-options in @ARGV:
$myfoo -> 2
@ARGV -> qw(bar blech)
-=head1 CONFIGURATION VARIABLES
+=head1 CONFIGURATION OPTIONS
+
+B<GetOptions> can be configured by calling subroutine
+B<Getopt::Long::config>. 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 variables can be set to change the default behaviour of
-GetOptions():
+The following options are available:
=over 12
-=item $Getopt::Long::autoabbrev
+=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 1 unless environment variable
-POSIXLY_CORRECT has been set.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<auto_abbrev> is reset.
-=item $Getopt::Long::getopt_compat
+=item getopt_compat
Allow '+' to start options.
-Default is 1 unless environment variable
-POSIXLY_CORRECT has been set.
+Default is set unless environment variable
+POSIXLY_CORRECT has been set, in which case B<getopt_compat> is reset.
+
+=item require_order
-=item $Getopt::Long::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 $REQUIRE_ORDER if environment variable
-POSIXLY_CORRECT has been set, $PERMUTE otherwise.
+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>.
-$PERMUTE means that
+If B<permute> is set, this means that
-foo arg1 -bar arg2 arg3
@@ -355,7 +401,7 @@ processed, except when B<--> is used:
will call the call-back routine for arg1 and arg2, and terminate
leaving arg2 in @ARGV.
-If $Getopt::Long::order is $REQUIRE_ORDER, options processing
+If B<require_order> is set, options processing
terminates when the first non-option is encountered.
-foo arg1 -bar arg2 arg3
@@ -364,11 +410,76 @@ is equivalent to
-foo -- arg1 -bar arg2 arg3
-$RETURN_IN_ORDER is not supported by GetOptions().
+=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
-=item $Getopt::Long::ignorecase
+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; this value has
+to be the last part of the bundle, e.g.
+
+ scale -h24 -w80
+
+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 debug (default: reset)
+
+Enable copious debugging output.
+
+=back
-Ignore case when matching options. Default is 1.
+=head1 OTHER USEFUL VARIABLES
+
+=over 12
=item $Getopt::Long::VERSION
@@ -376,7 +487,7 @@ 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 2.00;
+ use Getopt::Long 3.00;
You can inspect $Getopt::Long::major_version and
$Getopt::Long::minor_version for the individual components.
@@ -386,22 +497,13 @@ $Getopt::Long::minor_version for the individual components.
Internal error flag. May be incremented from a call-back routine to
cause options parsing to fail.
-=item $Getopt::Long::debug
-
-Enable copious debugging output. Default is 0.
-
=back
=cut
-################ Introduction ################
-#
-# This package implements an extended getopt function. This function
-# adheres to the new syntax (long option names, no bundling). It tries
-# to implement the better functionality of traditional, GNU and POSIX
-# getopt functions.
-#
-# This program is Copyright 1990,1996 by Johan Vromans.
+################ Copyright ################
+
+# This program is Copyright 1990,1997 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
@@ -416,84 +518,87 @@ Enable copious debugging output. Default is 0.
# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
# MA 02139, USA.
-################ History ################
-#
-# 13-Jan-1996 Johan Vromans
-# Generalized the linkage interface.
-# Eliminated the linkage argument.
-# Add code references as a possible value for the option linkage.
-# Add option specifier <> to have a call-back for non-options.
-#
-# 26-Dec-1995 Johan Vromans
-# Import from netgetopt.pl.
-# Turned into a decent module.
-# Added linkage argument.
-
-################ Configuration Section ################
+################ Module Preamble ################
-# Values for $order. See GNU getopt.c for details.
-($Getopt::Long::REQUIRE_ORDER,
- $Getopt::Long::PERMUTE,
- $Getopt::Long::RETURN_IN_ORDER) = (0..2);
+use strict;
-my $gen_prefix; # generic prefix (option starters)
+BEGIN {
+ require 5.003;
+ use Exporter ();
+ use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ $VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);
-# Handle POSIX compliancy.
-if ( defined $ENV{"POSIXLY_CORRECT"} ) {
- $gen_prefix = "(--|-)";
- $Getopt::Long::autoabbrev = 0; # no automatic abbrev of options
- $Getopt::Long::getopt_compat = 0; # disallow '+' to start options
- $Getopt::Long::order = $Getopt::Long::REQUIRE_ORDER;
-}
-else {
- $gen_prefix = "(--|-|\\+)";
- $Getopt::Long::autoabbrev = 1; # automatic abbrev of options
- $Getopt::Long::getopt_compat = 1; # allow '+' to start options
- $Getopt::Long::order = $Getopt::Long::PERMUTE;
+ @ISA = qw(Exporter);
+ @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
+ %EXPORT_TAGS = ();
+ @EXPORT_OK = qw();
}
-# Other configurable settings.
-$Getopt::Long::debug = 0; # for debugging
-$Getopt::Long::error = 0; # error tally
-$Getopt::Long::ignorecase = 1; # ignore case when matching options
-($Getopt::Long::version,
- $Getopt::Long::major_version,
- $Getopt::Long::minor_version) = '$Revision: 1.1.1.1 $ ' =~ /: ((\d+)\.(\d+))/;
-$Getopt::Long::version .= '*' if length('$Locker: $ ') > 12;
+use vars @EXPORT, @EXPORT_OK;
+# User visible variables.
+use vars qw($error $debug $major_version $minor_version);
+# Deprecated visible variables.
+use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
+ $passthrough);
+
+################ Local Variables ################
+
+my $gen_prefix; # generic prefix (option starters)
+my $argend; # option list terminator
+my %opctl; # table of arg.specs (long and abbrevs)
+my %bopctl; # table of arg.specs (bundles)
+my @opctl; # the possible long option names
+my $pkg; # current context. Needed if no linkage.
+my %aliases; # alias table
+my $genprefix; # so we can call the same module more
+my $opt; # current option
+my $arg; # current option value, if any
+my $array; # current option is array typed
+my $hash; # current option is hash typed
+my $key; # hash key for a hash option
+ # than once in differing environments
+my $config_defaults; # set config defaults
+my $find_option; # helper routine
################ Subroutines ################
sub GetOptions {
my @optionlist = @_; # local copy of the option descriptions
- my $argend = '--'; # option list terminator
- my %opctl; # table of arg.specs
- my $pkg = (caller)[0]; # current context
+ $argend = '--'; # option list terminator
+ %opctl = (); # table of arg.specs (long and abbrevs)
+ %bopctl = (); # table of arg.specs (bundles)
+ $pkg = (caller)[0]; # current context
# Needed if linkage is omitted.
- my %aliases; # alias table
+ %aliases= (); # alias table
my @ret = (); # accum for non-options
my %linkage; # linkage
my $userlinkage; # user supplied HASH
- my $debug = $Getopt::Long::debug; # convenience
- my $genprefix = $gen_prefix; # so we can call the same module more
- # than once in differing environments
- $Getopt::Long::error = 0;
+ $genprefix = $gen_prefix; # so we can call the same module many times
+ $error = 0;
- print STDERR ("GetOptions $Getopt::Long::version",
- " [GetOpt::Long $Getopt::Long::VERSION] -- ",
+ print STDERR ('GetOptions $Revision: 1.2 $ ',
+ "[GetOpt::Long $Getopt::Long::VERSION] -- ",
"called from package \"$pkg\".\n",
- " autoabbrev=$Getopt::Long::autoabbrev".
- ",getopt_compat=$Getopt::Long::getopt_compat",
+ " (@ARGV)\n",
+ " autoabbrev=$autoabbrev".
+ ",bundling=$bundling",
+ ",getopt_compat=$getopt_compat",
+ ",order=$order",
+ ",\n ignorecase=$ignorecase",
+ ",passthrough=$passthrough",
",genprefix=\"$genprefix\"",
- ",order=$Getopt::Long::order",
- ",ignorecase=$Getopt::Long::ignorecase",
".\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]) && ref($optionlist[0]) eq 'HASH' ) {
+ 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
@@ -507,10 +612,11 @@ sub GetOptions {
# 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.
+ # Strip leading prefix so people can specify "--foo=i" if they like.
$opt = $' if $opt =~ /^($genprefix)+/;
if ( $opt eq '<>' ) {
@@ -523,35 +629,54 @@ sub GetOptions {
unless ( @optionlist > 0
&& ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
warn ("Option spec <> requires a reference to a subroutine\n");
- $Getopt::Long::error++;
+ $error++;
next;
}
$linkage{'<>'} = shift (@optionlist);
next;
}
- $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase;
- if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
+ if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) {
warn ("Error in option spec: \"", $opt, "\"\n");
- $Getopt::Long::error++;
+ $error++;
next;
}
my ($o, $c, $a) = ($1, $2);
+ $c = '' unless defined $c;
if ( ! defined $o ) {
# empty -> '-' option
- $opctl{$o = ''} = defined $c ? $c : '';
+ $opctl{$o = ''} = $c;
}
else {
# Handle alias names
my @o = split (/\|/, $o);
- $o = $o[0];
+ 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 ( defined $c && $c eq '!' ) {
- $opctl{"no$_"} = $c;
- $c = '';
+ 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;
}
- $opctl{$_} = defined $c ? $c : '';
if ( defined $a ) {
# Note alias.
$aliases{$_} = $a;
@@ -561,6 +686,7 @@ sub GetOptions {
$a = $_;
}
}
+ $o = $linko;
}
# If no linkage is supplied in the @optionlist, copy it from
@@ -584,14 +710,26 @@ sub GetOptions {
if ( @optionlist > 0 && ref($optionlist[0]) ) {
print STDERR ("=> link \"$o\" to $optionlist[0]\n")
if $debug;
- if ( ref($optionlist[0]) eq 'SCALAR'
- || ref($optionlist[0]) eq 'ARRAY'
- || ref($optionlist[0]) eq 'CODE' ) {
+ 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 $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 $bopctl{$o} ne '' and $bopctl{$o} !~ /\%$/;
+ }
else {
warn ("Invalid option linkage for \"", $opt, "\"\n");
- $Getopt::Long::error++;
+ $error++;
}
}
else {
@@ -599,11 +737,16 @@ sub GetOptions {
# Make sure a valid perl identifier results.
my $ov = $o;
$ov =~ s/\W/_/g;
- if ( $c && $c =~ /@/ ) {
+ 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;
@@ -613,12 +756,12 @@ sub GetOptions {
}
# Bail out if errors found.
- return 0 if $Getopt::Long::error;
+ return 0 if $error;
- # Sort the possible option names.
- my @opctl = sort(keys (%opctl)) if $Getopt::Long::autoabbrev;
+ # Sort the possible long option names.
+ @opctl = sort(keys (%opctl)) if $autoabbrev;
- # Show if debugging.
+ # Show the options tables if debugging.
if ( $debug ) {
my ($arrow, $k, $v);
$arrow = "=> ";
@@ -626,23 +769,21 @@ sub GetOptions {
print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
$arrow = " ";
}
+ $arrow = "=> ";
+ while ( ($k,$v) = each(%bopctl) ) {
+ print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
+ $arrow = " ";
+ }
}
- my $opt; # current option
- my $arg; # current option value
- my $array; # current option is array typed
-
# Process argument list
while ( @ARGV > 0 ) {
- # >>> See also the continue block <<<
-
#### Get next argument ####
$opt = shift (@ARGV);
$arg = undef;
- my $optarg = undef;
- $array = 0;
+ $array = $hash = 0;
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
#### Determine what we have ####
@@ -651,33 +792,93 @@ sub GetOptions {
if ( $opt eq $argend ) {
# Finish. Push back accumulated arguments and return.
unshift (@ARGV, @ret)
- if $Getopt::Long::order == $Getopt::Long::PERMUTE;
- return ($Getopt::Long::error == 0);
- }
-
- if ( $opt =~ /^$genprefix/ ) {
- # Looks like an option.
- $opt = $'; # option name (w/o prefix)
- # If it is a long opt, it may include the value.
- if (($& eq "--" || ($Getopt::Long::getopt_compat && $& eq "+"))
- && $opt =~ /^([^=]+)=/ ) {
- $opt = $1;
- $optarg = $';
- print STDERR ("=> option \"", $opt,
- "\", optarg = \"$optarg\"\n") if $debug;
- }
+ if $order == $PERMUTE;
+ return ($error == 0);
+ }
+
+ my $tryopt = $opt;
+ # find_option operates on the GLOBAL $opt and $arg!
+ if ( &$find_option () ) {
+
+ # find_option 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' ) {
+ 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");
+ die ("Getopt::Long -- internal error!\n");
+ }
+ }
+ # No entry in linkage means entry in userlinkage.
+ elsif ( $array ) {
+ 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 ( $hash ) {
+ 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 {
+ 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 ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) {
+ elsif ( $order == $PERMUTE ) {
# Try non-options call-back.
my $cb;
if ( (defined ($cb = $linkage{'<>'})) ) {
- &$cb($opt);
+ &$cb($tryopt);
}
else {
- push (@ret, $opt);
+ print STDERR ("=> saving \"$tryopt\" ",
+ "(not an option, may permute)\n") if $debug;
+ push (@ret, $tryopt);
}
next;
}
@@ -685,207 +886,353 @@ sub GetOptions {
# ...otherwise, terminate.
else {
# Push this one back and exit.
- unshift (@ARGV, $opt);
- return ($Getopt::Long::error == 0);
+ unshift (@ARGV, $tryopt);
+ return ($error == 0);
}
- #### Look it up ###
+ }
- $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase;
+ # Finish.
+ if ( $order == $PERMUTE ) {
+ # Push back accumulated arguments
+ print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
+ if $debug && @ret > 0;
+ unshift (@ARGV, @ret) if @ret > 0;
+ }
- my $tryopt = $opt;
- if ( $Getopt::Long::autoabbrev ) {
- my $pat;
-
- # Turn option name into pattern.
- ($pat = $opt) =~ s/(\W)/\\$1/g;
- # Look up in option names.
- my @hits = grep (/^$pat/, @opctl);
- print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
- "out of ", 0+@opctl, "\n") if $debug;
-
- # Check for ambiguous results.
- unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
- print STDERR ("Option ", $opt, " is ambiguous (",
- join(", ", @hits), ")\n");
- $Getopt::Long::error++;
- next;
- }
+ return ($error == 0);
+}
- # Complete the option name, if appropriate.
- if ( @hits == 1 && $hits[0] ne $opt ) {
- $tryopt = $hits[0];
- print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
- if $debug;
- }
+sub config (@) {
+ my (@options) = @_;
+ my $opt;
+ foreach $opt ( @options ) {
+ my $try = lc ($opt);
+ my $action = 1;
+ if ( $try =~ /^no_?/ ) {
+ $action = 0;
+ $try = $';
}
-
- my $type;
- unless ( defined ( $type = $opctl{$tryopt} ) ) {
- print STDERR ("Unknown option: ", $opt, "\n");
- $Getopt::Long::error++;
- next;
+ if ( $try eq 'default' or $try eq 'defaults' ) {
+ &$config_defaults () if $action;
}
- $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 '!' ) {
- if ( defined $optarg ) {
- print STDERR ("Option ", $opt, " does not take an argument\n");
- $Getopt::Long::error++;
- }
- elsif ( $type eq '' ) {
- $arg = 1; # supply explicit value
- }
- else {
- substr ($opt, 0, 2) = ''; # strip NO prefix
- $arg = 0; # supply explicit value
- }
- next;
+ 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 eq 'debug' ) {
+ $debug = $action;
+ }
+ else {
+ $Carp::CarpLevel = 1;
+ Carp::croak("Getopt::Long: unknown config parameter \"$opt\"")
+ }
+ }
+}
- # Get mandatory status and type info.
- my $mand;
- ($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
+# Modified from Exporter. This one handles 2.001 and 2.01 etc just like 2.1.
+sub require_version {
+ no strict;
+ my ($self, $wanted) = @_;
+ my $pkg = ref $self || $self;
+ my $version = $ {"${pkg}::VERSION"} || "(undef)";
+
+ $wanted .= '.0' unless $wanted =~ /\./;
+ $wanted = $1 * 1000 + $2 if $wanted =~ /^(\d+)\.(\d+)$/;
+ $version = $1 * 1000 + $2 if $version =~ /^(\d+)\.(\d+)$/;
+ if ( $version < $wanted ) {
+ $version =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e;
+ $wanted =~ s/^(\d+)(\d\d\d)$/$1.'.'.(0+$2)/e;
+ $Carp::CarpLevel = 1;
+ Carp::croak("$pkg $wanted required--this is only version $version")
+ }
+ $version;
+}
- # Check if there is an option argument available.
- if ( defined $optarg ? ($optarg eq '') : (@ARGV <= 0) ) {
+################ Private Subroutines ################
- # Complain if this option needs an argument.
- if ( $mand eq "=" ) {
- print STDERR ("Option ", $opt, " requires an argument\n");
- $Getopt::Long::error++;
- }
- if ( $mand eq ":" ) {
- $arg = $type eq "s" ? '' : 0;
- }
- next;
- }
+$find_option = sub {
- # Get (possibly optional) argument.
- $arg = defined $optarg ? $optarg : shift (@ARGV);
+ return 0 unless $opt =~ /^$genprefix/;
- #### Check if the argument is valid for this option ####
+ $opt = $';
+ my ($starter) = $&;
- if ( $type eq "s" ) { # string
- # A mandatory string takes anything.
- next if $mand eq "=";
+ my $optarg = undef; # value supplied with --opt=value
+ my $rest = undef; # remainder from unbundling
- # An optional string takes almost anything.
- next if defined $optarg;
- next if $arg eq "-";
+ # If it is a long option, it may include the value.
+ if (($starter eq "--" || $getopt_compat)
+ && $opt =~ /^([^=]+)=/ ) {
+ $opt = $1;
+ $optarg = $';
+ print STDERR ("=> option \"", $opt,
+ "\", optarg = \"$optarg\"\n") if $debug;
+ }
- # Check for option or option list terminator.
- if ($arg eq $argend ||
- $arg =~ /^$genprefix.+/) {
- # Push back.
- unshift (@ARGV, $arg);
- # Supply empty value.
- $arg = '';
+ #### Look it up ###
+
+ my $tryopt = $opt; # option to try
+ my $optbl = \%opctl; # table to look it up (long names)
+ my $type;
+
+ 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/, @opctl);
+ print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ",
+ "out of ", scalar(@opctl), "\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;
}
- next;
+ # Now see if it really is ambiguous.
+ unless ( keys(%hit) == 1 ) {
+ return 0 if $passthrough;
+ print STDERR ("Option ", $opt, " is ambiguous (",
+ join(", ", @hits), ")\n");
+ $error++;
+ undef $opt;
+ return 1;
+ }
+ @hits = keys(%hit);
}
- if ( $type eq "n" || $type eq "i" ) { # numeric/integer
- if ( $arg !~ /^-?[0-9]+$/ ) {
- if ( defined $optarg || $mand eq "=" ) {
- print STDERR ("Value \"", $arg, "\" invalid for option ",
- $opt, " (number expected)\n");
- $Getopt::Long::error++;
- undef $arg; # don't assign it
- }
- else {
- # Push back.
- unshift (@ARGV, $arg);
- # Supply default value.
- $arg = 0;
- }
- }
- next;
+ # 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;
}
+ }
- if ( $type eq "f" ) { # fixed real number, int is also ok
- if ( $arg !~ /^-?[0-9.]+$/ ) {
- if ( defined $optarg || $mand eq "=" ) {
- print STDERR ("Value \"", $arg, "\" invalid for option ",
- $opt, " (real number expected)\n");
- $Getopt::Long::error++;
- undef $arg; # don't assign it
- }
- else {
- # Push back.
- unshift (@ARGV, $arg);
- # Supply default value.
- $arg = 0.0;
- }
- }
- next;
+ # 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;
+ }
+ # 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 '!' ) {
+ if ( defined $optarg ) {
+ return 0 if $passthrough;
+ print STDERR ("Option ", $opt, " does not take an argument\n");
+ $error++;
+ undef $opt;
+ }
+ elsif ( $type eq '' ) {
+ $arg = 1; # supply explicit value
}
+ else {
+ substr ($opt, 0, 2) = ''; # strip NO prefix
+ $arg = 0; # supply explicit value
+ }
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ return 1;
+ }
- die ("GetOpt::Long internal error (Can't happen)\n");
+ # Get mandatory status and type info.
+ my $mand;
+ ($mand, $type, $array, $hash) = $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;
+ print STDERR ("Option ", $opt, " requires an argument\n");
+ $error++;
+ undef $opt;
+ }
+ if ( $mand eq ":" ) {
+ $arg = $type eq "s" ? '' : 0;
+ }
+ return 1;
}
- continue {
- if ( defined $arg ) {
- $opt = $aliases{$opt} if defined $aliases{$opt};
+ # Get (possibly optional) argument.
+ $arg = (defined $rest ? $rest
+ : (defined $optarg ? $optarg : shift (@ARGV)));
- if ( defined $linkage{$opt} ) {
- print STDERR ("=> ref(\$L{$opt}) -> ",
- ref($linkage{$opt}), "\n") if $debug;
+ # Get key if this is a "name=value" pair for a hash option.
+ $key = undef;
+ if ($hash && defined $arg) {
+ ($key, $arg) = ($arg =~ /=/o) ? ($`, $') : ($arg, 1);
+ }
- if ( ref($linkage{$opt}) eq 'SCALAR' ) {
- 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 '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");
- die ("Getopt::Long -- internal error!\n");
+ #### Check if the argument is valid for this option ####
+
+ if ( $type eq "s" ) { # string
+ # A mandatory string takes anything.
+ return 1 if $mand eq "=";
+
+ # An optional string takes almost anything.
+ return 1 if defined $optarg || defined $rest;
+ return 1 if $arg eq "-"; # ??
+
+ # Check for option or option list terminator.
+ if ($arg eq $argend ||
+ $arg =~ /^$genprefix.+/) {
+ # Push back.
+ unshift (@ARGV, $arg);
+ # Supply empty value.
+ $arg = '';
+ }
+ }
+
+ elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
+ if ( $arg !~ /^-?[0-9]+$/ ) {
+ if ( defined $optarg || $mand eq "=" ) {
+ if ( $passthrough ) {
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return 0;
}
+ print STDERR ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (number expected)\n");
+ $error++;
+ undef $opt;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
}
- # No entry in linkage means entry in userlinkage.
- elsif ( $array ) {
- 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];
+ 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
+ if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) {
+ if ( defined $optarg || $mand eq "=" ) {
+ if ( $passthrough ) {
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg)
+ unless defined $optarg;
+ return 0;
}
+ print STDERR ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (real number expected)\n");
+ $error++;
+ undef $opt;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
}
else {
- print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug;
- $userlinkage->{$opt} = $arg;
+ # Push back.
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ # Supply default value.
+ $arg = 0.0;
}
}
}
-
- # Finish.
- if ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) {
- # Push back accumulated arguments
- unshift (@ARGV, @ret) if @ret > 0;
+ else {
+ die ("GetOpt::Long internal error (Can't happen)\n");
}
+ return 1;
+};
+
+$config_defaults = sub {
+ # Handle POSIX compliancy.
+ if ( defined $ENV{"POSIXLY_CORRECT"} ) {
+ $gen_prefix = "(--|-)";
+ $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 {
+ $gen_prefix = "(--|-|\\+)";
+ $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
+};
- return ($Getopt::Long::error == 0);
-}
+################ 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.
+&$config_defaults ();
################ Package return ################
-# Returning 1 is so boring...
-$Getopt::Long::major_version * 1000 + $Getopt::Long::minor_version;
+1;
diff --git a/gnu/usr.bin/perl/lib/Getopt/Std.pm b/gnu/usr.bin/perl/lib/Getopt/Std.pm
index 4117ca7f8b5..27882935f99 100644
--- a/gnu/usr.bin/perl/lib/Getopt/Std.pm
+++ b/gnu/usr.bin/perl/lib/Getopt/Std.pm
@@ -11,9 +11,12 @@ 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'); # -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
@@ -24,6 +27,11 @@ 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.
+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);
@@ -40,8 +48,8 @@ switch and the argument.
# Usage:
# getopt('oDI'); # -o, -D & -I take arg. Sets opt_* as a side effect.
-sub getopt {
- local($argumentative) = @_;
+sub getopt ($;$) {
+ local($argumentative, $hash) = @_;
local($_,$first,$rest);
local $Exporter::ExportLevel;
@@ -55,12 +63,22 @@ sub getopt {
shift(@ARGV);
$rest = shift(@ARGV);
}
- eval "\$opt_$first = \$rest;";
- push( @EXPORT, "\$opt_$first" );
+ if (ref $hash) {
+ $$hash{$first} = $rest;
+ }
+ else {
+ ${"opt_$first"} = $rest;
+ push( @EXPORT, "\$opt_$first" );
+ }
}
else {
- eval "\$opt_$first = 1;";
- push( @EXPORT, "\$opt_$first" );
+ if (ref $hash) {
+ $$hash{$first} = 1;
+ }
+ else {
+ ${"opt_$first"} = 1;
+ push( @EXPORT, "\$opt_$first" );
+ }
if ($rest ne '') {
$ARGV[0] = "-$rest";
}
@@ -77,8 +95,8 @@ sub getopt {
# getopts('a:bc'); # -a takes arg. -b & -c not. Sets opt_* as a
# # side effect.
-sub getopts {
- local($argumentative) = @_;
+sub getopts ($;$) {
+ local($argumentative, $hash) = @_;
local(@args,$_,$first,$rest);
local($errs) = 0;
local $Exporter::ExportLevel;
@@ -94,12 +112,22 @@ sub getopts {
++$errs unless @ARGV;
$rest = shift(@ARGV);
}
- eval "\$opt_$first = \$rest;";
- push( @EXPORT, "\$opt_$first" );
+ if (ref $hash) {
+ $$hash{$first} = $rest;
+ }
+ else {
+ ${"opt_$first"} = $rest;
+ push( @EXPORT, "\$opt_$first" );
+ }
}
else {
- eval "\$opt_$first = 1";
- push( @EXPORT, "\$opt_$first" );
+ if (ref $hash) {
+ $$hash{$first} = 1;
+ }
+ else {
+ ${"opt_$first"} = 1;
+ push( @EXPORT, "\$opt_$first" );
+ }
if($rest eq '') {
shift(@ARGV);
}
diff --git a/gnu/usr.bin/perl/lib/I18N/Collate.pm b/gnu/usr.bin/perl/lib/I18N/Collate.pm
index 0d8314e12e4..580ca39785c 100644
--- a/gnu/usr.bin/perl/lib/I18N/Collate.pm
+++ b/gnu/usr.bin/perl/lib/I18N/Collate.pm
@@ -4,6 +4,23 @@ package I18N::Collate;
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;
@@ -23,30 +40,29 @@ You can compare $s1 and $s2 above with
to extract the data itself, you'll need a dereference: $$s1
-This 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. Due to C<cmp>
-and overload magic, C<lt>, C<le>, C<eq>, C<ge>, and C<gt> work also. 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>. Not all the locales that your vendor supports
-are necessarily installed: please consult your operating system's
-documentation and possibly your local system administration.
+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 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.
+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 <Jarkko.Hietaniemi@hut.fi>
+# Author: Jarkko Hietaniemi <F<jhi@iki.fi>>
# Helsinki University of Technology, Finland
#
-# Acks: Guy Decoux <decoux@moulon.inra.fr> understood
+# 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)
@@ -87,7 +103,7 @@ ISO Latin (8859) 1 (-1) which is the Western European character set.
# variant of French (fr), ISO Latin (8859) 1 (-1)
# which is the Western European character set.
#
-# Updated: 19960104 1946 GMT
+# Updated: 19961005
#
# ---
@@ -104,7 +120,35 @@ fallback 1
cmp collate_cmp
);
-sub new { my $new = $_[1]; bless \$new }
+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];
diff --git a/gnu/usr.bin/perl/lib/IPC/Open2.pm b/gnu/usr.bin/perl/lib/IPC/Open2.pm
index 243412ef094..32282d62b39 100644
--- a/gnu/usr.bin/perl/lib/IPC/Open2.pm
+++ b/gnu/usr.bin/perl/lib/IPC/Open2.pm
@@ -1,7 +1,14 @@
package IPC::Open2;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT);
+
require 5.000;
require Exporter;
-use Carp;
+
+$VERSION = 1.01;
+@ISA = qw(Exporter);
+@EXPORT = qw(open2);
=head1 NAME
@@ -20,7 +27,16 @@ 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");
+ 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:/>.
@@ -38,19 +54,17 @@ 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 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.
+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<open3> for an alternative that handles STDERR as well.
+See L<IPC::Open3> for an alternative that handles STDERR as well. This
+function is really just a wrapper around open3().
=cut
-@ISA = qw(Exporter);
-@EXPORT = qw(open2);
-
# &open2: tom christiansen, <tchrist@convex.com>
#
# usage: $pid = open2('rdr', 'wtr', 'some cmd and args');
@@ -67,41 +81,15 @@ See L<open3> for an alternative that handles STDERR as well.
#
# abort program if
# rdr or wtr are null
-# pipe or fork or exec fails
+# a system call fails
-$fh = 'FHOPEN000'; # package static in case called more than once
+require IPC::Open3;
sub open2 {
- local($kidpid);
- local($dad_rdr, $dad_wtr, @cmd) = @_;
-
- $dad_rdr ne '' || croak "open2: rdr should not be null";
- $dad_wtr ne '' || croak "open2: wtr should not be null";
-
- # force unqualified filehandles into callers' package
- local($package) = caller;
- $dad_rdr =~ s/^[^']+$/$package'$&/ unless ref $dad_rdr;
- $dad_wtr =~ s/^[^']+$/$package'$&/ unless ref $dad_wtr;
-
- local($kid_rdr) = ++$fh;
- local($kid_wtr) = ++$fh;
-
- pipe($dad_rdr, $kid_wtr) || croak "open2: pipe 1 failed: $!";
- pipe($kid_rdr, $dad_wtr) || croak "open2: pipe 2 failed: $!";
-
- if (($kidpid = fork) < 0) {
- croak "open2: fork failed: $!";
- } elsif ($kidpid == 0) {
- close $dad_rdr; close $dad_wtr;
- open(STDIN, "<&$kid_rdr");
- open(STDOUT, ">&$kid_wtr");
- warn "execing @cmd\n" if $debug;
- exec @cmd
- or croak "open2: exec of @cmd failed";
- }
- close $kid_rdr; close $kid_wtr;
- select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
- $kidpid;
+ my ($read, $write, @cmd) = @_;
+ local $Carp::CarpLevel = $Carp::CarpLevel + 1;
+ return IPC::Open3::_open3('open2', scalar caller,
+ $write, $read, '>&STDERR', @cmd);
}
-1; # so require is happy
+1
diff --git a/gnu/usr.bin/perl/lib/IPC/Open3.pm b/gnu/usr.bin/perl/lib/IPC/Open3.pm
index d055c51ca84..5bae5057367 100644
--- a/gnu/usr.bin/perl/lib/IPC/Open3.pm
+++ b/gnu/usr.bin/perl/lib/IPC/Open3.pm
@@ -1,7 +1,18 @@
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.0101;
+@ISA = qw(Exporter);
+@EXPORT = qw(open3);
=head1 NAME
@@ -9,7 +20,7 @@ IPC::Open3, open3 - open a process for reading, writing, and error handling
=head1 SYNOPSIS
- $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH
+ $pid = open3(\*WTRFH, \*RDRFH, \*ERRFH,
'some cmd and args', 'optarg', ...);
=head1 DESCRIPTION
@@ -17,30 +28,46 @@ IPC::Open3, open3 - open a process for reading, writing, and error handling
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.
+on the same file handle. The WTRFH will have autoflush turned on.
-If WTRFH begins with "<&", then WTRFH will be closed in the parent, and
+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
-">&", 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.
+"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.
-All caveats from open2() continue to apply. See L<open2> for details.
+open3() returns the process ID of the child process. It doesn't return on
+failure: it just raises an exception matching C</^open3:/>.
-=cut
+=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.
-@ISA = qw(Exporter);
-@EXPORT = qw(open3);
+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>
#
-# $Id: Open3.pm,v 1.1.1.1 1996/08/19 10:12:45 downsj Exp $
+# $Id: Open3.pm,v 1.2 1997/11/30 07:57:45 millert Exp $
#
# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
#
@@ -48,7 +75,7 @@ All caveats from open2() continue to apply. See L<open2> for details.
# 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 0 on failure.
+# of child (or dies on failure).
# if wtr begins with '<&', then wtr will be closed in the parent, and
@@ -64,17 +91,43 @@ All caveats from open2() continue to apply. See L<open2> for details.
#
# abort program if
# rdr or wtr are null
-# pipe or fork or exec fails
+# a system call fails
-$fh = 'FHOPEN000'; # package static in case called more than once
+$Fh = 'FHOPEN000'; # package static in case called more than once
+$Me = 'open3 (bug)'; # you should never see this, it's always localized
-sub open3 {
- my($kidpid);
- my($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
- my($dup_wtr, $dup_rdr, $dup_err);
+# 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: $!";
+}
- $dad_wtr || croak "open3: wtr should not be null";
- $dad_rdr || croak "open3: rdr should not be null";
+# 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';
+
+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/^[<>]&//);
@@ -82,63 +135,155 @@ sub open3 {
$dup_err = ($dad_err =~ s/^[<>]&//);
# force unqualified filehandles into callers' package
- my($package) = caller;
- $dad_wtr =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_wtr;
- $dad_rdr =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_rdr;
- $dad_err =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_err;
+ $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;
+ my $kid_rdr = ++$Fh;
+ my $kid_wtr = ++$Fh;
+ my $kid_err = ++$Fh;
- if (!$dup_wtr) {
- pipe($kid_rdr, $dad_wtr) || croak "open3: pipe 1 (stdin) failed: $!";
- }
- if (!$dup_rdr) {
- pipe($dad_rdr, $kid_wtr) || croak "open3: pipe 2 (stdout) failed: $!";
- }
- if ($dad_err ne $dad_rdr && !$dup_err) {
- pipe($dad_err, $kid_err) || croak "open3: pipe 3 (stderr) failed: $!";
- }
+ 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 (($kidpid = fork) < 0) {
- croak "open3: fork failed: $!";
- } elsif ($kidpid == 0) {
if ($dup_wtr) {
- open(STDIN, "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr));
+ xopen \*STDIN, "<&$dad_wtr" if fileno(STDIN) != fileno($dad_wtr);
} else {
- close($dad_wtr);
- open(STDIN, "<&$kid_rdr");
+ xclose $dad_wtr;
+ xopen \*STDIN, "<&$kid_rdr";
+ xclose $kid_rdr;
}
if ($dup_rdr) {
- open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr));
+ xopen \*STDOUT, ">&$dad_rdr" if fileno(STDOUT) != fileno($dad_rdr);
} else {
- close($dad_rdr);
- open(STDOUT, ">&$kid_wtr");
+ xclose $dad_rdr;
+ xopen \*STDOUT, ">&$kid_wtr";
+ xclose $kid_wtr;
}
if ($dad_rdr ne $dad_err) {
if ($dup_err) {
- open(STDERR, ">&$dad_err")
- if (fileno(STDERR) != fileno($dad_err));
+ xopen \*STDERR, ">&$dad_err"
+ if fileno(STDERR) != fileno($dad_err);
} else {
- close($dad_err);
- open(STDERR, ">&$kid_err");
+ xclose $dad_err;
+ xopen \*STDERR, ">&$kid_err";
+ xclose $kid_err;
}
} else {
- open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT));
+ xopen \*STDERR, ">&STDOUT" if fileno(STDERR) != fileno(STDOUT);
}
local($")=(" ");
exec @cmd
or croak "open3: exec of @cmd failed";
- }
+ } elsif ($do_spawn) {
+ # All the bookkeeping of coincidence between handles is
+ # handled in spawn_with_handles.
- close $kid_rdr; close $kid_wtr; close $kid_err;
- if ($dup_wtr) {
- close($dad_wtr);
+ 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 "open3: $@" 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;
}
-1; # so require is happy
+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});
+ }
+ # 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/gnu/usr.bin/perl/lib/Math/BigInt.pm b/gnu/usr.bin/perl/lib/Math/BigInt.pm
index 68856aea6e0..422dca42fd6 100644
--- a/gnu/usr.bin/perl/lib/Math/BigInt.pm
+++ b/gnu/usr.bin/perl/lib/Math/BigInt.pm
@@ -106,13 +106,23 @@ sub bcmp { #(num_str, num_str) return cond_code
sub cmp { # post-normalized compare for internal use
local($cx, $cy) = @_;
- $cx cmp $cy
- &&
- (
- ord($cy) <=> ord($cx)
- ||
- ($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx)
- );
+
+ 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
@@ -161,11 +171,11 @@ sub add { #(int_num_array, int_num_array) return int_num_array
$car = 0;
for $x (@x) {
last unless @y || $car;
- $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5);
+ $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0;
}
for $y (@y) {
last unless $car;
- $y -= 1e5 if $car = (($y += $car) >= 1e5);
+ $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0;
}
(@x, @y, $car);
}
@@ -204,7 +214,7 @@ sub mul { #(*int_num_array, *int_num_array) return int_num_array
for $x (@x) {
($car, $cty) = (0, $[);
for $y (@y) {
- $prod = $x * $y + $prod[$cty] + $car;
+ $prod = $x * $y + ($prod[$cty] || 0) + $car;
$prod[$cty++] =
$prod - ($car = int($prod * 1e-5)) * 1e5;
}
diff --git a/gnu/usr.bin/perl/lib/Math/Complex.pm b/gnu/usr.bin/perl/lib/Math/Complex.pm
index 969f3c2c79e..b3d7e6084f2 100644
--- a/gnu/usr.bin/perl/lib/Math/Complex.pm
+++ b/gnu/usr.bin/perl/lib/Math/Complex.pm
@@ -1,123 +1,1198 @@
-package Math::Complex;
+#
+# Complex numbers and associated mathematical functions
+# -- Raphael Manfredi September 1996
+# -- Jarkko Hietaniemi March-October 1997
+# -- Daniel S. Lewart September-October 1997
+#
require Exporter;
+package Math::Complex;
+
+$VERSION = 1.05;
+
+# $Id: Complex.pm,v 1.2 1997/11/30 07:57:47 millert Exp $
+
+use strict;
-@ISA = ('Exporter');
+use vars qw($VERSION @ISA
+ @EXPORT %EXPORT_TAGS
+ $package $display
+ $i $ip2 $logn %logn);
-# just to make use happy
+@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 arg
+ sqrt log ln
+ log10 logn cbrt root
+ cplx cplxe
+ ),
+ @trig);
+
+%EXPORT_TAGS = (
+ 'trig' => [@trig],
+);
use overload
- '+' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]});
- bless [ $x1+$x2, $y1+$y2];
- },
-
- '-' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]});
- bless [ $x1-$x2, $y1-$y2];
- },
-
- '*' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]});
- bless [ $x1*$x2-$y1*$y2,$x1*$y2+$x2*$y1];
- },
-
- '/' => sub { my($x1,$y1,$x2,$y2) = (@{$_[0]},@{$_[1]});
- my $q = $x2*$x2+$y2*$y2;
- bless [($x1*$x2+$y1*$y2)/$q, ($y1*$x2-$y2*$x1)/$q];
- },
-
- 'neg' => sub { my($x,$y) = @{$_[0]}; bless [ -$x, -$y];
- },
-
- '~' => sub { my($x,$y) = @{$_[0]}; bless [ $x, -$y];
- },
-
- 'abs' => sub { my($x,$y) = @{$_[0]}; sqrt $x*$x+$y*$y;
- },
-
- 'cos' => sub { my($x,$y) = @{$_[0]};
- my ($ab,$c,$s) = (exp $y, cos $x, sin $x);
- my $abr = 1/(2*$ab); $ab /= 2;
- bless [ ($abr+$ab)*$c, ($abr-$ab)*$s];
- },
-
- 'sin' => sub { my($x,$y) = @{$_[0]};
- my ($ab,$c,$s) = (exp $y, cos $x, sin $x);
- my $abr = 1/(2*$ab); $ab /= 2;
- bless [ (-$abr-$ab)*$s, ($abr-$ab)*$c];
- },
-
- 'exp' => sub { my($x,$y) = @{$_[0]};
- my ($ab,$c,$s) = (exp $x, cos $y, sin $y);
- bless [ $ab*$c, $ab*$s ];
- },
-
- 'sqrt' => sub {
- my($zr,$zi) = @{$_[0]};
- my ($x, $y, $r, $w);
- my $c = new Math::Complex (0,0);
- if (($zr == 0) && ($zi == 0)) {
- # nothing, $c already set
- }
- else {
- $x = abs($zr);
- $y = abs($zi);
- if ($x >= $y) {
- $r = $y/$x;
- $w = sqrt($x) * sqrt(0.5*(1.0+sqrt(1.0+$r*$r)));
- }
- else {
- $r = $x/$y;
- $w = sqrt($y) * sqrt($y) * sqrt(0.5*($r+sqrt(1.0+$r*$r)));
- }
- if ( $zr >= 0) {
- @$c = ($w, $zi/(2 * $w) );
- }
- else {
- $c->[1] = ($zi >= 0) ? $w : -$w;
- $c->[0] = $zi/(2.0* $c->[1]);
- }
- }
- return $c;
- },
-
- qw("" stringify)
-;
-
-sub new {
- my $class = shift;
- my @C = @_;
- bless \@C, $class;
+ '+' => \&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 globals
+#
+
+$package = 'Math::Complex'; # Package name
+$display = 'cartesian'; # Default display format
+
+#
+# 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)
+#
+
+#
+# ->make
+#
+# Create a new complex number (cartesian form)
+#
+sub make {
+ my $self = bless {}, shift;
+ my ($re, $im) = @_;
+ $self->{'cartesian'} = [$re, $im];
+ $self->{c_dirty} = 0;
+ $self->{p_dirty} = 1;
+ return $self;
+}
+
+#
+# ->emake
+#
+# Create a new complex number (exponential form)
+#
+sub emake {
+ my $self = bless {}, shift;
+ my ($rho, $theta) = @_;
+ if ($rho < 0) {
+ $rho = -$rho;
+ $theta = ($theta <= 0) ? $theta + pi() : $theta - pi();
+ }
+ $self->{'polar'} = [$rho, $theta];
+ $self->{p_dirty} = 0;
+ $self->{c_dirty} = 1;
+ 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 * atan2(1, 1);
+
+#
+# pit2
+#
+# The full circle
+#
+use constant pit2 => 2 * pi;
+
+#
+# pip2
+#
+# The quarter circle
+#
+use constant pip2 => pi / 2;
+
+#
+# uplog10
+#
+# Used in log10().
+#
+use constant uplog10 => 1 / 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 * cos $t, $r * 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'} = [sqrt($x*$x + $y*$y), 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);
+ }
+ return $inverted ? exp($z1 * log $z2) : exp($z2 * log $z1);
+}
+
+#
+# (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 complex's norm (rho).
+#
+sub abs {
+ my ($z) = @_;
+ my ($r, $t) = @{$z->polar};
+ return $r;
+}
+
+#
+# arg
+#
+# Compute complex's argument (theta).
+#
+sub arg {
+ my ($z) = @_;
+ return ($z < 0 ? pi : 0) unless ref $z;
+ my ($r, $t) = @{$z->polar};
+ if ($t > pi()) { $t -= pit2 }
+ elsif ($t <= -pi()) { $t += pit2 }
+ return $t;
}
+#
+# (sqrt)
+#
+# Compute sqrt(z).
+#
+sub sqrt {
+ my ($z) = @_;
+ return $z >= 0 ? sqrt($z) : cplx(0, sqrt(-$z)) unless ref $z;
+ my ($re, $im) = @{$z->cartesian};
+ return cplx($re < 0 ? (0, sqrt(-$re)) : (sqrt($re), 0)) if $im == 0;
+ my ($r, $t) = @{$z->polar};
+ return (ref $z)->emake(sqrt($r), $t/2);
+}
+
+#
+# cbrt
+#
+# Compute cbrt(z) (cubic root).
+#
+sub cbrt {
+ my ($z) = @_;
+ return $z < 0 ? -exp(log(-$z)/3) : ($z > 0 ? exp(log($z)/3): 0)
+ unless ref $z;
+ my ($r, $t) = @{$z->polar};
+ return (ref $z)->emake(exp(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} : (abs($z), $z >= 0 ? 0 : pi);
+ my @root;
+ my $k;
+ my $theta_inc = pit2 / $n;
+ my $rho = $r ** (1/$n);
+ my $theta;
+ my $complex = ref($z) || $package;
+ for ($k = 0, $theta = $t / $n; $k < $n; $k++, $theta += $theta_inc) {
+ push(@root, $complex->emake($rho, $theta));
+ }
+ return @root;
+}
+
+#
+# Re
+#
+# Return Re(z).
+#
sub Re {
- my($x,$y) = @{$_[0]};
- $x;
+ my ($z) = @_;
+ return $z unless ref $z;
+ my ($re, $im) = @{$z->cartesian};
+ return $re;
}
+#
+# Im
+#
+# Return Im(z).
+#
sub Im {
- my($x,$y) = @{$_[0]};
- $y;
+ my ($z) = @_;
+ return 0 unless ref $z;
+ my ($re, $im) = @{$z->cartesian};
+ return $im;
}
-sub arg {
- my($x,$y) = @{$_[0]};
- atan2($y,$x);
+#
+# (exp)
+#
+# Computes exp(z).
+#
+sub exp {
+ my ($z) = @_;
+ my ($x, $y) = @{$z->cartesian};
+ return (ref $z)->emake(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 ? log($z) : cplx(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(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} = log($n) unless defined $logn; # Cache log(n)
+ return log($z) / $logn;
+}
+
+#
+# (cos)
+#
+# Compute cos(z) = (exp(iz) + exp(-iz))/2.
+#
+sub cos {
+ my ($z) = @_;
+ my ($x, $y) = @{$z->cartesian};
+ my $ey = exp($y);
+ my $ey_1 = 1 / $ey;
+ return (ref $z)->make(cos($x) * ($ey + $ey_1)/2,
+ 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 = exp($y);
+ my $ey_1 = 1 / $ey;
+ return (ref $z)->make(sin($x) * ($ey + $ey_1)/2,
+ cos($x) * ($ey - $ey_1)/2);
+}
+
+#
+# tan
+#
+# Compute tan(z) = sin(z) / cos(z).
+#
+sub tan {
+ my ($z) = @_;
+ my $cz = cos($z);
+ _divbyzero "tan($z)", "cos($z)" if ($cz == 0);
+ return sin($z) / $cz;
+}
+
+#
+# sec
+#
+# Computes the secant sec(z) = 1 / cos(z).
+#
+sub sec {
+ my ($z) = @_;
+ my $cz = 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 = 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 = sin($z);
+ _divbyzero "cot($z)", "sin($z)" if ($sz == 0);
+ return 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 atan2(sqrt(1-$z*$z), $z) if (! ref $z) && abs($z) <= 1;
+ my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0);
+ my $t1 = sqrt(($x+1)*($x+1) + $y*$y);
+ my $t2 = 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 = atan2(sqrt(1-$beta*$beta), $beta);
+ my $v = log($alpha + 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 atan2($z, sqrt(1-$z*$z)) if (! ref $z) && abs($z) <= 1;
+ my ($x, $y) = ref $z ? @{$z->cartesian} : ($z, 0);
+ my $t1 = sqrt(($x+1)*($x+1) + $y*$y);
+ my $t2 = 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 = atan2($beta, sqrt(1-$beta*$beta));
+ my $v = -log($alpha + 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 atan2($z, 1) unless ref $z;
+ _divbyzero "atan(i)" if ( $z == i);
+ _divbyzero "atan(-i)" if (-$z == i);
+ my $log = 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) = @_;
+ return ($z >= 0) ? atan2(1, $z) : atan2(-1, -$z) unless ref $z;
+ _divbyzero "acot(i)", if ( $z == i);
+ _divbyzero "acot(-i)" if (-$z == i);
+ 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 = exp($z);
+ return ($ex + 1/$ex)/2;
+ }
+ my ($x, $y) = @{$z->cartesian};
+ $ex = exp($x);
+ my $ex_1 = 1 / $ex;
+ return (ref $z)->make(cos($y) * ($ex + $ex_1)/2,
+ 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 = exp($z);
+ return ($ex - 1/$ex)/2;
+ }
+ my ($x, $y) = @{$z->cartesian};
+ $ex = exp($x);
+ my $ex_1 = 1 / $ex;
+ return (ref $z)->make(cos($y) * ($ex - $ex_1)/2,
+ 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 log($z + sqrt($z*$z-1)) if $z >= 1;
+ $z = cplx($z, 0);
+ }
+ my ($re, $im) = @{$z->cartesian};
+ if ($im == 0) {
+ return cplx(log($re + sqrt($re*$re - 1)), 0) if $re >= 1;
+ return cplx(0, atan2(sqrt(1-$re*$re), $re)) if abs($re) <= 1;
+ }
+ return log($z + sqrt($z*$z - 1));
+}
+
+#
+# asinh
+#
+# Computes the arc hyperbolic sine asinh(z) = log(z + sqrt(z*z-1))
+#
+sub asinh {
+ my ($z) = @_;
+ return log($z + 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 log((1 + $z)/(1 - $z))/2 if abs($z) < 1;
+ $z = cplx($z, 0);
+ }
+ _divbyzero 'atanh(1)', "1 - $z" if ($z == 1);
+ _logofzero 'atanh(-1)' if ($z == -1);
+ return 0.5 * 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) = @_;
+ unless (ref $z) {
+ return log(($z + 1)/($z - 1))/2 if abs($z) > 1;
+ $z = cplx($z, 0);
+ }
+ _divbyzero 'acoth(1)', "$z - 1" if ($z == 1);
+ _logofzero 'acoth(-1)' if ($z == -1);
+ return 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(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($x,$y) = @{$_[0]};
- my($re,$im);
+ my ($z) = shift;
+ my $format;
- $re = $x if ($x);
- if ($y == 1) {$im = 'i';}
- elsif ($y == -1){$im = '-i';}
- elsif ($y) {$im = "${y}i"; }
+ $format = $display;
+ $format = $z->{display} if defined $z->{display};
- local $_ = $re.'+'.$im;
- s/\+-/-/;
- s/^\+//;
- s/[\+-]$//;
- $_ = 0 if ($_ eq '');
- return $_;
+ 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);
+ my $eps = 1e-14;
+
+ $x = int($x + ($x < 0 ? -1 : 1) * $eps)
+ if int(abs($x)) != int(abs($x) + $eps);
+ $y = int($y + ($y < 0 ? -1 : 1) * $eps)
+ if int(abs($y)) != int(abs($y) + $eps);
+
+ $re = "$x" if abs($x) >= $eps;
+ if ($y == 1) { $im = 'i' }
+ elsif ($y == -1) { $im = '-i' }
+ elsif (abs($y) >= $eps) { $im = $y . "i" }
+
+ my $str = '';
+ $str = $re if defined $re;
+ $str .= "+$im" if defined $im;
+ $str =~ s/\+-/-/;
+ $str =~ s/^\+//;
+ $str = '0' unless $str;
+
+ return $str;
+}
+
+#
+# ->stringify_polar
+#
+# Stringify as a polar representation '[r,t]'.
+#
+sub stringify_polar {
+ my $z = shift;
+ my ($r, $t) = @{$z->polar};
+ my $theta;
+ my $eps = 1e-14;
+
+ return '[0,0]' if $r <= $eps;
+
+ my $nt = $t / pit2;
+ $nt = ($nt - int($nt)) * pit2;
+ $nt += pit2 if $nt < 0; # Range [0, 2pi]
+
+ if (abs($nt) <= $eps) { $theta = 0 }
+ elsif (abs(pi-$nt) <= $eps) { $theta = 'pi' }
+
+ if (defined $theta) {
+ $r = int($r + ($r < 0 ? -1 : 1) * $eps)
+ if int(abs($r)) != int(abs($r) + $eps);
+ $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps)
+ if ($theta ne 'pi' and
+ int(abs($theta)) != int(abs($theta) + $eps));
+ return "\[$r,$theta\]";
+ }
+
+ #
+ # Okay, number is not a real. Try to identify pi/n and friends...
+ #
+
+ $nt -= pit2 if $nt > pi;
+ 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 (abs($kpi/$n - $nt) <= $eps) {
+ $theta = ($nt < 0 ? '-':'').
+ ($k == 1 ? 'pi':"${k}pi").'/'.abs($n);
+ last;
+ }
+ }
+
+ $theta = $nt unless defined $theta;
+
+ $r = int($r + ($r < 0 ? -1 : 1) * $eps)
+ if int(abs($r)) != int(abs($r) + $eps);
+ $theta = int($theta + ($theta < 0 ? -1 : 1) * $eps)
+ if ($theta !~ m(^-?\d*pi/\d+$) and
+ int(abs($theta)) != int(abs($theta) + $eps));
+
+ return "\[$r,$theta\]";
}
1;
@@ -125,39 +1200,393 @@ __END__
=head1 NAME
-Math::Complex - complex numbers package
+Math::Complex - complex numbers and associated mathematical functions
=head1 SYNOPSIS
- use Math::Complex;
- $i = new Math::Complex;
+ use Math::Complex;
+
+ $z = Math::Complex->make(5, 6);
+ $t = 4 - 3*i + $z;
+ $j = cplxe(1, 2*pi/3);
=head1 DESCRIPTION
-Complex numbers declared as
+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>.
- $i = Math::Complex->new(1,1);
+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.
-can be manipulated with overloaded math operators. The operators
+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):
- + - * / neg ~ abs cos sin exp sqrt
+ sqrt(x) = x >= 0 ? sqrt(x) : sqrt(-x)*i
-are supported as well as
+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:
- "" (stringify)
+ sqrt(z = [r,t]) = sqrt(r) * exp(i * t/2)
-The methods
+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
- Re Im arg
+ sqrt([x,pi]) = sqrt(x) * exp(i*pi/2) = [sqrt(x),pi/2] = sqrt(x)*i
-are also provided.
+which is exactly what we had defined for negative real numbers above.
+
+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)
+ ~z1 = a - bi
+ abs(z1) = r1 = sqrt(a*a + b*b)
+ sqrt(z1) = sqrt(r1) * exp(i * t1/2)
+ exp(z1) = exp(a) * exp(i * b)
+ log(z1) = log(r1) + i*t1
+ sin(z1) = 1/2i (exp(i * z1) - exp(-i * z1))
+ cos(z1) = 1/2 (exp(i * z1) + exp(-i * z1))
+ 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
+
+ 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<log>, I<csc>, I<cot>, I<acsc>, I<acot>, I<csch>, I<coth>,
+I<acosech>, I<acotanh>, have aliases I<ln>, I<cosec>, I<cotan>,
+I<acosec>, I<acotan>, I<cosech>, I<cotanh>, I<acosech>, I<acotanh>,
+respectively.
+
+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).
+
+=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";
+
+=head1 ERRORS DUE TO DIVISION BY ZERO
+
+The division (/) and the following functions
+
+ tan
+ sec
+ csc
+ cot
+ asec
+ acsc
+ atan
+ 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
+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>, C<sech>, the
+argument cannot be I<pi/2 + k * pi>, where I<k> is any integer.
=head1 BUGS
-sqrt() should return two roots, but only returns one.
+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.
=head1 AUTHORS
-Dave Nadler, Tom Christiansen, Tim Bunce, Larry Wall.
+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
+
+# eof
diff --git a/gnu/usr.bin/perl/lib/Math/Trig.pm b/gnu/usr.bin/perl/lib/Math/Trig.pm
new file mode 100644
index 00000000000..a1cbb072340
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Math/Trig.pm
@@ -0,0 +1,233 @@
+#
+# Trigonometric functions, mostly inherited from Math::Complex.
+# -- Jarkko Hietaniemi, 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);
+
+@ISA = qw(Exporter);
+
+$VERSION = 1.00;
+
+my @angcnv = qw(rad2deg rad2grad
+ deg2rad deg2grad
+ grad2rad grad2deg);
+
+@EXPORT = (@{$Math::Complex::EXPORT_TAGS{'trig'}},
+ @angcnv);
+
+use constant pi2 => 2 * pi;
+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) }
+
+=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
+
+ tan
+
+The cofunctions of the sine, cosine, and tangent (cosec/csc and cotan/cot
+are aliases)
+
+ csc cosec sec cot cotan
+
+The arcus (also known as the inverse) functions of the sine, cosine,
+and tangent
+
+ asin acos atan
+
+The principal value of the arc tangent of y/x
+
+ atan2(y, x)
+
+The arcus cofunctions of the sine, cosine, and tangent (acosec/acsc
+and acotan/acot are aliases)
+
+ acsc acosec asec acot acotan
+
+The hyperbolic sine, cosine, and tangent
+
+ sinh cosh tanh
+
+The cofunctions of the hyperbolic sine, cosine, and tangent (cosech/csch
+and cotanh/coth are aliases)
+
+ csch cosech sech coth cotanh
+
+The arcus (also known as the inverse) functions of the hyperbolic
+sine, cosine, and tangent
+
+ asinh acosh atanh
+
+The arcus cofunctions of the hyperbolic sine, cosine, and tangent
+(acsch/acosech and acoth/acotanh are aliases)
+
+ acsch acosech asech acoth acotanh
+
+The trigonometric constant B<pi> is also defined.
+
+ $pi2 = 2 * pi;
+
+=head2 ERRORS DUE TO DIVISION BY ZERO
+
+The following functions
+
+ tan
+ sec
+ csc
+ cot
+ asec
+ acsc
+ 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
+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 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 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/gnu/usr.bin/perl/lib/Net/Ping.pm b/gnu/usr.bin/perl/lib/Net/Ping.pm
index 3ba88d57518..91077ddad1c 100644
--- a/gnu/usr.bin/perl/lib/Net/Ping.pm
+++ b/gnu/usr.bin/perl/lib/Net/Ping.pm
@@ -1,106 +1,550 @@
package Net::Ping;
-# Authors: karrer@bernina.ethz.ch (Andreas Karrer)
-# pmarquess@bfsec.bt.co.uk (Paul Marquess)
-
-require 5.002 ;
+# 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 $tcp_proto $echo_port) ;
+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(ping pingecho);
-$VERSION = 1.01;
-
-use Socket 'PF_INET', 'AF_INET', 'SOCK_STREAM';
-use Carp ;
-
-$tcp_proto = (getprotobyname('tcp'))[2];
-$echo_port = (getservbyname('echo', 'tcp'))[2];
-
-sub ping {
- croak "ping not implemented yet. Use pingecho()";
-}
+@EXPORT = qw(pingecho);
+$VERSION = 2.02;
+# Constants
-sub pingecho {
+$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
- croak "usage: pingecho host [timeout]"
- unless @_ == 1 or @_ == 2 ;
+# 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.
- my ($host, $timeout) = @_;
- my ($saddr, $ip);
- my ($ret) ;
- local (*PINGSOCK);
+sub pingecho
+{
+ my ($host, # Name or IP number of host to ping
+ $timeout # Optional timeout in seconds
+ ) = @_;
+ my ($p); # A ping object
- # check if $host is alive by connecting to its echo port, within $timeout
- # (default 5) seconds. returns 1 if OK, 0 if no answer, 0 if host not found
+ $p = Net::Ping->new("tcp", $timeout);
+ $p->ping($host); # Going out of scope closes the connection
+}
- $timeout = 5 unless $timeout;
+# 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 $>;
+ $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);
+}
- if ($host =~ /^\s*((\d+\.){3}\d+)\s*$/)
- { $ip = pack ('C4', split (/\./, $1)) }
+# 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
- { $ip = (gethostbyname($host))[4] }
-
- return 0 unless $ip; # "no such host"
+ {
+ croak("Unknown protocol \"$self->{proto}\" in ping()");
+ }
+ return($ret);
+}
- $saddr = pack('S n a4 x8', AF_INET, $echo_port, $ip);
- $SIG{'ALRM'} = sub { die } ;
- alarm($timeout);
-
+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 socket(PINGSOCK, PF_INET, SOCK_STREAM, $tcp_proto) ;
- return unless connect(PINGSOCK, $saddr) ;
- $ret=1 ;
+ return unless connect($self->{"fh"}, $saddr);
+ $ret = 1;
EOM
alarm(0);
- close(PINGSOCK);
- $ret;
+ $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__
-=cut
-
=head1 NAME
-Net::Ping, pingecho - check a host for upness
+Net::Ping - check a remote host for reachability
=head1 SYNOPSIS
use Net::Ping;
- print "'jimmy' is alive and kicking\n" if pingecho('jimmy', 10) ;
-
-=head1 DESCRIPTION
-This module contains routines to test for the reachability of remote hosts.
-Currently the only routine implemented is pingecho().
+ $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);
-pingecho() uses a TCP echo (I<not> an ICMP one) to determine if the
-remote host is reachable. This is usually adequate to tell that a remote
-host is available to rsh(1), ftp(1), or telnet(1) onto.
+=head1 DESCRIPTION
-=head2 Parameters
+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.
-=over 5
+=back
-=item hostname
+=head1 WARNING
-The remote host to check, specified either as a hostname or as an IP address.
+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.
-=item timeout
+=head1 NOTES
-The timeout in seconds. If not specified it will default to 5 seconds.
+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.
-=back
+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.
-=head1 WARNING
+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).
-pingecho() uses alarm to implement the timeout, so don't set another alarm
-while you are using it.
+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/gnu/usr.bin/perl/lib/Net/hostent.pm b/gnu/usr.bin/perl/lib/Net/hostent.pm
new file mode 100644
index 00000000000..96b090dae5a
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/Net/netent.pm b/gnu/usr.bin/perl/lib/Net/netent.pm
new file mode 100644
index 00000000000..b82447cad71
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/Net/protoent.pm b/gnu/usr.bin/perl/lib/Net/protoent.pm
new file mode 100644
index 00000000000..737ff5a33bc
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/Net/servent.pm b/gnu/usr.bin/perl/lib/Net/servent.pm
new file mode 100644
index 00000000000..fb85dd04bfa
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/Pod/Functions.pm b/gnu/usr.bin/perl/lib/Pod/Functions.pm
index a775cf61654..3cc9b385a00 100644
--- a/gnu/usr.bin/perl/lib/Pod/Functions.pm
+++ b/gnu/usr.bin/perl/lib/Pod/Functions.pm
@@ -5,7 +5,7 @@ package Pod::Functions;
require Exporter;
@ISA = qw(Exporter);
-@EXPORT = qw(%Kinds %Type %Flavor %Type_Descriptions @Type_Order);
+@EXPORT = qw(%Kinds %Type %Flavor %Type_Description @Type_Order);
%Type_Description = (
'ARRAY' => 'Functions for real @ARRAYs',
@@ -193,6 +193,7 @@ 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
diff --git a/gnu/usr.bin/perl/lib/Pod/Html.pm b/gnu/usr.bin/perl/lib/Pod/Html.pm
new file mode 100644
index 00000000000..ffeb0b21361
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/Pod/Html.pm
@@ -0,0 +1,1523 @@
+package Pod::Html;
+
+use Pod::Functions;
+use Getopt::Long; # package for handling command-line parameters
+require Exporter;
+@ISA = Exporter;
+@EXPORT = qw(pod2html htmlify);
+use Cwd;
+
+use Carp;
+
+use strict;
+
+=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
+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
+
+}
+
+sub pod2html {
+ local(@ARGV) = @_;
+ local($/);
+ local $_;
+
+ init_globals();
+
+ # 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;
+ }
+ unless ($title) {
+ 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>
+ </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) { # =head[1-6] heading
+ process_head($1, $2);
+ } elsif (/^=item\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 "$text\n<P>\n\n";
+ }
+ }
+
+ # 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;
+
+ if ($which_head > $listdepth) {
+ $index .= "\n" . ("\t" x $listdepth) . "<UL>\n";
+ } elsif ($which_head < $listdepth) {
+ $listdepth--;
+ $index .= "\n" . ("\t" x $listdepth) . "</UL>\n";
+ }
+ $listdepth = $which_head;
+
+ $index .= "\n" . ("\t" x $listdepth) . "<LI>" .
+ "<A HREF=\"#" . htmlify(0,$title) . "\">" .
+ 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 =~ /^[0-9]+/) { # numbered list
+ /\A=item\s+[0-9]+\.?(.*?)\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);
+ 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><STRONG>";
+ $text =~ /\A\*\s*(.*)\Z/s;
+ print HTML "<A NAME=\"item_" . htmlify(1,$1) . "\">" if $1 && !$items_named{$1}++;
+ $quote = 1;
+ #print HTML process_puretext($1, \$quote);
+ print HTML $1;
+ print HTML "</A>" if $1;
+ print HTML "</STRONG>";
+
+ } elsif ($text =~ /\A[0-9#]+/) { # numbered list
+
+ if ($need_preamble) {
+ push(@listend, "</OL>");
+ print HTML "<OL>\n";
+ }
+
+ print HTML "<LI><STRONG>";
+ $text =~ /\A[0-9]+\.?(.*)\Z/s;
+ print HTML "<A NAME=\"item_" . htmlify(0,$1) . "\">" if $1;
+ $quote = 1;
+ #print HTML process_puretext($1, \$quote);
+ print HTML $1 if $1;
+ print HTML "</A>" if $1;
+ print HTML "</STRONG>";
+
+ } else { # all others
+
+ if ($need_preamble) {
+ push(@listend, '</DL>');
+ print HTML "<DL>\n";
+ }
+
+ print HTML "<DT><STRONG>";
+ print HTML "<A NAME=\"item_" . htmlify(1,$text) . "\">"
+ if $text && !$items_named{($text =~ /(\S+)/)[0]}++;
+ # preceding craziness so that the duplicate leading bits in
+ # perlfunc work to find just the first one. otherwise
+ # open etc would have many names
+ $quote = 1;
+ #print HTML process_puretext($text, \$quote);
+ print HTML $text;
+ print HTML "</A>" if $text;
+ 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, otherwise ignore it.
+#
+sub process_for {
+ my($whom, $text) = @_;
+ if ( $whom =~ /^(pod2)?html$/i) {
+ print HTML $text;
+ }
+}
+
+#
+# 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>);
+ } 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 ($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
+ $word = qq(<A HREF="MAILTO:$word">$word</A>);
+ } 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;
+}
+
+#
+# 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, $section, $link); # work strings
+
+ $str =~ s/\n/ /g; # undo word-wrapped tags
+ $s1 = $str;
+ for ($s1) {
+ # 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 = "";
+ }
+ }
+
+ if ($page eq "") {
+ $link = "#" . htmlify(0,$section);
+ $linktext = $section;
+ } elsif (!defined $pages{$page}) {
+ warn "$0: $podfile: cannot resolve L<$str> in paragraph $paragraph: no such page '$page'\n";
+ $link = "";
+ $linktext = $page;
+ } else {
+ $linktext = ($section ? "$section" : "the $page manpage");
+ $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;
+ }
+ }
+ }
+
+ 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
+
+ # 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/gnu/usr.bin/perl/lib/Pod/Text.pm b/gnu/usr.bin/perl/lib/Pod/Text.pm
index ac4f72b688b..2b6c6b62971 100644
--- a/gnu/usr.bin/perl/lib/Pod/Text.pm
+++ b/gnu/usr.bin/perl/lib/Pod/Text.pm
@@ -1,7 +1,5 @@
package Pod::Text;
-# Version 1.01
-
=head1 NAME
Pod::Text - convert POD data to formatted ASCII text
@@ -14,7 +12,7 @@ Pod::Text - convert POD data to formatted ASCII text
Also:
- pod2text < input.pod
+ pod2text [B<-a>] [B<->I<width>] < input.pod
=head1 DESCRIPTION
@@ -27,14 +25,16 @@ 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 one or two arguments. The first
-should be the name of a file to read the pod from, or "<&STDIN" to read from
+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>tchrist@mox.perl.comE<gt>
+Tom Christiansen E<lt>F<tchrist@mox.perl.com>E<gt>
=head1 TODO
@@ -49,8 +49,13 @@ 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";
@@ -59,8 +64,7 @@ $BOLD = "\x1b[1m";
$NORM = "\x1b[0m";
sub pod2text {
-local($file,*OUTPUT) = @_;
-*OUTPUT = *STDOUT if @_<2;
+shift if $opt_alt_format = ($_[0] eq '-a');
if($termcap and !$setuptermcap) {
$setuptermcap=1;
@@ -73,11 +77,18 @@ if($termcap and !$setuptermcap) {
}
$SCREEN = ($_[0] =~ /^-(\d+)/ && (shift, $1))
- || ($ENV{TERMCAP} =~ /co#(\d+)/)[0]
|| $ENV{COLUMNS}
- || (`stty -a 2>/dev/null` =~ /(\d+) columns/)[0]
+ || ($ENV{TERMCAP} =~ /co#(\d+)/)[0]
+ || ($^O ne 'MSWin32' && (`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;
@@ -86,6 +97,7 @@ $cutting = 1;
$DEF_INDENT = 4;
$indent = $DEF_INDENT;
$needspace = 0;
+$begun = "";
open(IN, $file) || die "Couldn't open $file: $!";
@@ -94,6 +106,15 @@ POD_DIRECTIVE: while (<IN>) {
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))
@@ -101,11 +122,26 @@ POD_DIRECTIVE: while (<IN>) {
}me;
# Translate verbatim paragraph
if (/^\s/) {
- $needspace = 1;
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/;
@@ -116,14 +152,19 @@ sub prepare_for_output {
$maxnest = 10;
while ($maxnest-- && /[A-Z]</) {
unless ($FANCY) {
- s/C<(.*?)>/`$1'/g;
+ 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>")/ge;
+ s/C<(.*?)>/noremap("E<lchevron>${1}E<rchevron>")/sge;
}
# s/[IF]<(.*?)>/italic($1)/ge;
- s/I<(.*?)>/*$1*/g;
+ s/I<(.*?)>/*$1*/sg;
# s/[CB]<(.*?)>/bold($1)/ge;
- s/X<.*?>//g;
+ s/X<.*?>//sg;
# LREF: a manpage(3f)
s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))?>:the $1$2 manpage:g;
# LREF: an =item on another manpage
@@ -167,9 +208,9 @@ sub prepare_for_output {
? "the section on \"$2\" in the $1 manpage"
: "the section on \"$2\""
}
- }gex;
+ }sgex;
- s/[A-Z]<(.*?)>/$1/g;
+ s/[A-Z]<(.*?)>/$1/sg;
}
clear_noremap(1);
}
@@ -184,10 +225,18 @@ sub prepare_for_output {
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();
@@ -195,7 +244,13 @@ sub prepare_for_output {
#print ' ' x $DEF_INDENT, $_;
# print "\xA7";
s/(\w)/\xA7 $1/ if $FANCY;
- print OUTPUT ' ' x ($DEF_INDENT/2), $_, "\n";
+ 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);
@@ -204,7 +259,6 @@ sub prepare_for_output {
elsif ($Cmd eq 'back') {
$indent = pop(@indent);
warn "Unmatched =back\n" unless defined $indent;
- $needspace = 1;
}
elsif ($Cmd eq 'item') {
makespace();
@@ -223,7 +277,7 @@ sub prepare_for_output {
IP_output($paratag, $_);
} else {
local($indent) = $indent[$#index - 1] || $DEF_INDENT;
- output($_);
+ output($_, 0);
}
}
}
@@ -317,7 +371,9 @@ sub IP_output {
s/\s+/ /g;
s/^ //;
$str = "format OUTPUT = \n"
- . (" " x ($tag_indent))
+ . (($opt_alt_format && $tag_indent > 1)
+ ? ":" . " " x ($tag_indent - 1)
+ : " " x ($tag_indent))
. '@' . ('<' x ($indent - $tag_indent - 1))
. "^" . ("<" x ($cols - 1)) . "\n"
. '$tag, $_'
@@ -345,6 +401,7 @@ sub output {
} else {
s/^/' ' x $indent/gem;
s/^\s+\n$/\n/gm;
+ s/^ /: /s if defined($reformat) && $opt_alt_format;
print OUTPUT;
}
}
@@ -357,9 +414,8 @@ sub noremap {
sub init_noremap {
die "unmatched init" if $mapready++;
- if ( /[\200-\377]/ ) {
- warn "hit bit char in input stream";
- }
+ #mask off high bit characters in input stream
+ s/([\200-\377])/"E<".ord($1).">"/ge;
}
sub clear_noremap {
@@ -370,15 +426,21 @@ sub clear_noremap {
# otherwise the interative \w<> processing would have
# been hosed by the E<gt>
s {
- E<
- ( [A-Za-z]+ )
+ E<
+ (
+ ( \d+ )
+ | ( [A-Za-z]+ )
+ )
>
} {
do {
- defined $HTML_Escapes{$1}
- ? do { $HTML_Escapes{$1} }
+ defined $2
+ ? chr($2)
+ :
+ defined $HTML_Escapes{$3}
+ ? do { $HTML_Escapes{$3} }
: do {
- warn "Unknown escape: $& in $_";
+ warn "Unknown escape: E<$1> in $_";
"E<$1>";
}
}
diff --git a/gnu/usr.bin/perl/lib/Search/Dict.pm b/gnu/usr.bin/perl/lib/Search/Dict.pm
index 295da6b31d2..9a229a7bc02 100644
--- a/gnu/usr.bin/perl/lib/Search/Dict.pm
+++ b/gnu/usr.bin/perl/lib/Search/Dict.pm
@@ -37,7 +37,7 @@ sub look {
my($size, $blksize) = @stat[7,11];
$blksize ||= 8192;
$key =~ s/[^\w\s]//g if $dict;
- $key =~ tr/A-Z/a-z/ if $fold;
+ $key = lc $key if $fold;
my($min, $max, $mid) = (0, int($size / $blksize));
while ($max - $min > 1) {
$mid = int(($max + $min) / 2);
@@ -47,7 +47,7 @@ sub look {
$_ = <FH>;
chop;
s/[^\w\s]//g if $dict;
- tr/A-Z/a-z/ if $fold;
+ $_ = lc $_ if $fold;
if (defined($_) && $_ lt $key) {
$min = $mid;
}
@@ -61,11 +61,11 @@ sub look {
<FH> if $min;
for (;;) {
$min = tell(FH);
- $_ = <FH>
+ defined($_ = <FH>)
or last;
chop;
s/[^\w\s]//g if $dict;
- y/A-Z/a-z/ if $fold;
+ $_ = lc $_ if $fold;
last if $_ ge $key;
}
seek(FH,$min,0);
diff --git a/gnu/usr.bin/perl/lib/SelectSaver.pm b/gnu/usr.bin/perl/lib/SelectSaver.pm
index 4c764bedcf1..5f569222fcc 100644
--- a/gnu/usr.bin/perl/lib/SelectSaver.pm
+++ b/gnu/usr.bin/perl/lib/SelectSaver.pm
@@ -38,8 +38,10 @@ use Symbol;
sub new {
@_ >= 1 && @_ <= 2 or croak 'usage: new SelectSaver [FILEHANDLE]';
- my $fh = (@_ > 1) ? (select qualify($_[1], caller)) : select;
- bless [$fh], $_[0];
+ my $fh = select;
+ my $self = bless [$fh], $_[0];
+ select qualify($_[1], caller) if @_ > 1;
+ $self;
}
sub DESTROY {
diff --git a/gnu/usr.bin/perl/lib/SelfLoader.pm b/gnu/usr.bin/perl/lib/SelfLoader.pm
index e3da9ebadbc..f93841c862a 100644
--- a/gnu/usr.bin/perl/lib/SelfLoader.pm
+++ b/gnu/usr.bin/perl/lib/SelfLoader.pm
@@ -3,25 +3,26 @@ use Carp;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(AUTOLOAD);
-$VERSION = 1.06; sub Version {$VERSION}
+$VERSION = 1.07; 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 $code = $Cache{$AUTOLOAD};
- unless ($code) {
+ 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"};
- $code = $Cache{$AUTOLOAD};
- $code = "sub $AUTOLOAD { }" if (!$code and $AUTOLOAD =~ m/::DESTROY$/);
- croak "Undefined subroutine $AUTOLOAD" unless $code;
+ $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: $code\n" if $DEBUG;
- eval $code;
+ print STDERR "SelfLoader::AUTOLOAD eval: $SL_code\n" if $DEBUG;
+ eval $SL_code;
if ($@) {
$@ =~ s/ at .*\n//;
croak $@;
@@ -44,8 +45,8 @@ sub _load_stubs {
unless fileno($fh);
$Cache{"${currpack}::<DATA"} = 1; # indicate package is cached
- while($line = <$fh> and $line !~ m/^__END__/) {
- if ($line =~ m/^sub\s+([\w:]+)\s*(\([\$\@\;\%\\]*\))?/) { # A sub declared
+ 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);
@@ -119,117 +120,123 @@ SelfLoader - load functions only on demand
=head1 DESCRIPTION
This module tells its users that functions in the FOOBAR package are to be
-autoloaded from after the __DATA__ token. See also L<perlsub/"Autoloading">.
+autoloaded from after the C<__DATA__> token. See also
+L<perlsub/"Autoloading">.
=head2 The __DATA__ token
-The __DATA__ token tells the perl compiler that the perl code
-for compilation is finished. Everything after 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 __DATA__
-token is reached. This works just the same as __END__ does in
-package 'main', but for other modules data after __END__ is not
-automatically retreivable , whereas data after __DATA__ is.
-The __DATA__ token is not recognized in versions of perl prior to
+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 __DATA__ tokens in the same package
-in multiple files, and that the last __DATA__ token in a given
+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 __END__ and main, i.e. if
-the 'main' program has an __END__, but a module 'require'd (_not_ 'use'd)
-by that program has a 'package main;' declaration followed by an '__DATA__',
-then the DATA filehandle is set to access the data after the __DATA__
-in the module, _not_ the data after the __END__ token in the 'main'
+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 SelfLoader works by the user placing the __DATA__
-token _after_ perl code which needs to be compiled and
-run at 'require' time, but _before_ subroutine declarations
+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 SelfLoader will read from the FOOBAR::DATA filehandle to
-load in the data after __DATA__, and load in any subroutine
+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 __DATA__, and a load delay for the _first_
+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 SelfLoader will stop reading from __DATA__ if
-it encounters the __END__ token - just as you would expect.
-If the __END__ token is present, and is followed by the
-token DATA, then the SelfLoader leaves the FOOBAR::DATA
+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 SelfLoader exports the AUTOLOAD subroutine to the
-package using the SelfLoader, and this loads the called
+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 __DATA__ token.
+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 __DATA__ token. Subroutines
+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 SelfLoader and the Autoloader).
+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 SelfLoader can replace the AutoLoader - just change 'use AutoLoader'
-to 'use SelfLoader' (though note that the SelfLoader exports
+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 __END__ token to __DATA__. You will need perl version 5.001m
+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 SelfLoader.
+There is no need to inherit from the B<SelfLoader>.
-The SelfLoader works similarly to the AutoLoader, but picks up the
-subs from after the __DATA__ instead of in the 'lib/auto' directory.
+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 __DATA__.
+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 FOOBAR::DATA together with the SelfLoader.
-
-Data after the __DATA__ token in a module is read using the
-FOOBAR::DATA filehandle. __END__ can still be used to denote the end
-of the __DATA__ section if followed by the token DATA - this is supported
-by the SelfLoader. The FOOBAR::DATA filehandle is left open if an __END__
-followed by a DATA is found, with the filehandle positioned at the start
-of the line after the __END__ token. If no __END__ token is present,
-or an __END__ token with no DATA token on the same line, then the filehandle
-is closed.
-
-The SelfLoader reads from wherever the current
-position of the FOOBAR::DATA filehandle is, until the
-EOF or __END__. This means that 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 __DATA__ token and put your own data after those
-declarations, using the __END__ token to mark the end
-of subroutine declarations. You must also ensure that the SelfLoader
-reads first by calling 'SelfLoader->load_stubs();', or by using a
+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 FOOBAR::DATA filehandle first, leaving
+2. You should read the C<FOOBAR::DATA> filehandle first, leaving
the handle open and positioned at the first line of subroutine
declarations.
@@ -252,11 +259,11 @@ 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->load_stubs();' to the module to do
+adding the statement 'SelfLoader-E<gt>load_stubs();' to the module to do
this.
-The alternative is to put the stubs in before the __DATA__ token BEFORE
-releasing the module, and for this purpose the Devel::SelfStubber
+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
@@ -265,10 +272,10 @@ 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 SelfLoader::AUTOLOAD to
+should note that this requires exporting the C<SelfLoader::AUTOLOAD> to
every package which requires it. This is done automatically by the
-SelfLoader when it first loads the subs into the cache, but you should
-really specify it in the initialization before the __DATA__ by putting
+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,
@@ -278,8 +285,9 @@ Fully qualified subroutine names are also supported. For example,
package baz;
sub dob {32}
-will all be loaded correctly by the SelfLoader, and the SelfLoader
+will all be loaded correctly by the B<SelfLoader>, and the B<SelfLoader>
will ensure that the packages 'foo' and 'baz' correctly have the
-SelfLoader AUTOLOAD method when the data after __DATA__ is first parsed.
+B<SelfLoader> C<AUTOLOAD> method when the data after C<__DATA__> is first
+parsed.
=cut
diff --git a/gnu/usr.bin/perl/lib/Shell.pm b/gnu/usr.bin/perl/lib/Shell.pm
index bb44b5398b5..f4ef431cc54 100644
--- a/gnu/usr.bin/perl/lib/Shell.pm
+++ b/gnu/usr.bin/perl/lib/Shell.pm
@@ -21,7 +21,7 @@ AUTOLOAD {
my $cmd = $AUTOLOAD;
$cmd =~ s/^.*:://;
eval qq {
- sub $AUTOLOAD {
+ *$AUTOLOAD = sub {
if (\@_ < 1) {
`$cmd`;
}
diff --git a/gnu/usr.bin/perl/lib/Symbol.pm b/gnu/usr.bin/perl/lib/Symbol.pm
index 67808af082a..6807e74479a 100644
--- a/gnu/usr.bin/perl/lib/Symbol.pm
+++ b/gnu/usr.bin/perl/lib/Symbol.pm
@@ -23,6 +23,10 @@ Symbol - manipulate Perl symbols and their names
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;
+
=head1 DESCRIPTION
C<Symbol::gensym> creates an anonymous glob and returns a reference
@@ -34,7 +38,7 @@ 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" -> "MyPackage::myvar"). If it is given a
+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
@@ -44,29 +48,35 @@ 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.
+
=cut
BEGIN { require 5.002; }
require Exporter;
@ISA = qw(Exporter);
+@EXPORT = qw(gensym ungensym qualify qualify_to_ref);
-@EXPORT = qw(gensym ungensym qualify);
+$VERSION = 1.02;
my $genpkg = "Symbol::";
my $genseq = 0;
-my %global;
-while (<DATA>) {
- chomp;
- $global{$_} = 1;
-}
-close DATA;
+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++;
- local *{$genpkg . $name};
- \delete ${$genpkg}{$name};
+ my $ref = \*{$genpkg . $name};
+ delete $$genpkg{$name};
+ $ref;
}
sub ungensym ($) {}
@@ -87,14 +97,8 @@ sub qualify ($;$) {
$name;
}
-1;
+sub qualify_to_ref ($;$) {
+ return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
+}
-__DATA__
-ARGV
-ARGVOUT
-ENV
-INC
-SIG
-STDERR
-STDIN
-STDOUT
+1;
diff --git a/gnu/usr.bin/perl/lib/Sys/Hostname.pm b/gnu/usr.bin/perl/lib/Sys/Hostname.pm
index 2c40361b51a..95f9a99a7ab 100644
--- a/gnu/usr.bin/perl/lib/Sys/Hostname.pm
+++ b/gnu/usr.bin/perl/lib/Sys/Hostname.pm
@@ -25,7 +25,7 @@ All nulls, returns, and newlines are removed from the result.
=head1 AUTHOR
-David Sundstrom <sunds@asictest.sc.ti.com>
+David Sundstrom E<lt>F<sunds@asictest.sc.ti.com>E<gt>
Texas Instruments
@@ -39,7 +39,7 @@ sub hostname {
if ($^O eq 'VMS') {
# method 2 - no sockets ==> return DECnet node name
- eval {gethostbyname('me')};
+ 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
@@ -60,10 +60,16 @@ sub hostname {
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";
@@ -72,18 +78,34 @@ sub hostname {
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);
}
diff --git a/gnu/usr.bin/perl/lib/Sys/Syslog.pm b/gnu/usr.bin/perl/lib/Sys/Syslog.pm
index f02a2b516c3..709f5785f5d 100644
--- a/gnu/usr.bin/perl/lib/Sys/Syslog.pm
+++ b/gnu/usr.bin/perl/lib/Sys/Syslog.pm
@@ -7,6 +7,7 @@ use Carp;
@EXPORT = qw(openlog closelog setlogmask syslog);
use Socket;
+use Sys::Hostname;
# adapted from syslog.pl
#
@@ -23,7 +24,7 @@ Sys::Syslog, openlog, closelog, setlogmask, syslog - Perl interface to the UNIX
use Sys::Syslog;
openlog $ident, $logopt, $facility;
- syslog $priority, $mask, $format, @args;
+ syslog $priority, $format, @args;
$oldmask = setlogmask $mask_priority;
closelog;
@@ -43,9 +44,9 @@ I<$ident> is prepended to every message.
I<$logopt> contains one or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>.
I<$facility> specifies the part of the system
-=item syslog $priority, $mask, $format, @args
+=item syslog $priority, $format, @args
-If I<$priority> and I<$mask> permit, logs I<($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).
@@ -53,6 +54,20 @@ is replaced with C<"$!"> (the latest error message).
Sets log mask I<$mask_priority> and returns the old mask.
+=item setlogsock $sock_type (added in 5.004_03)
+
+Sets the socket type to be used for the next call to
+C<openlog()> or C<syslog()>.
+
+A value of 'unix' will connect to the UNIX domain socket returned by
+C<_PATH_LOG> in F<syslog.ph>. If F<syslog.ph> fails to define
+C<_PATH_LOG>, C<setlogsock> returns C<undef>; otherwise a true value is
+returned. 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.
@@ -69,9 +84,12 @@ Note that C<openlog> now takes three arguments, just like C<openlog(3)>.
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)
@@ -85,12 +103,12 @@ L<syslog(3)>
=head1 AUTHOR
-Tom Christiansen E<lt>F<tchrist@perl.com>E<gt> and Larry Wall E<lt>F<lwall@sems.com>E<gt>
+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
-$host = hostname() unless $host; # set $Syslog::host to change
-
require 'syslog.ph';
$maskpri = &LOG_UPTO(&LOG_DEBUG);
@@ -115,6 +133,22 @@ sub setlogmask {
$oldmask;
}
+sub setlogsock {
+ local($setsock) = shift;
+ if (lc($setsock) eq 'unix') {
+ if (defined &_PATH_LOG) {
+ $sock_unix = 1;
+ } else {
+ return undef;
+ }
+ } elsif (lc($setsock) eq 'inet') {
+ undef($sock_unix);
+ } else {
+ croak "Invalid argument passed to setlogsock; must be 'unix' or 'inet'";
+ }
+ return 1;
+}
+
sub syslog {
local($priority) = shift;
local($mask) = shift;
@@ -155,7 +189,7 @@ sub syslog {
$whoami = $ident;
- if (!$ident && $mask =~ /^(\S.*):\s?(.*)/) {
+ if (!$whoami && $mask =~ /^(\S.*?):\s?(.*)/) {
$whoami = $1;
$mask = $2;
}
@@ -173,7 +207,7 @@ sub syslog {
$message = sprintf ($mask, @_);
$sum = $numpri + $numfac;
- unless (send(SYSLOG,"<$sum>$whoami: $message",0)) {
+ unless (send(SYSLOG,"<$sum>$whoami: $message\0",0)) {
if ($lo_cons) {
if ($pid = fork) {
unless ($lo_nowait) {
@@ -192,23 +226,31 @@ sub syslog {
sub xlate {
local($name) = @_;
- $name =~ y/a-z/A-Z/;
+ $name = uc $name;
$name = "LOG_$name" unless $name =~ /^LOG_/;
$name = "Sys::Syslog::$name";
- eval(&$name) || -1;
+ defined &$name ? &$name : -1;
}
sub connect {
unless ($host) {
require Sys::Hostname;
- $host = Sys::Hostname::hostname();
+ my($host_uniq) = Sys::Hostname::hostname();
+ ($host) = $host_uniq =~ /([A-Za-z0-9_.-]+)/; # allow FQDN (inc _)
+ }
+ unless ( $sock_unix ) {
+ 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 "open: $!";
+ connect(SYSLOG,$that) || croak "connect: $!";
}
- 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: $!";
local($old) = select(SYSLOG); $| = 1; select($old);
$connected = 1;
}
diff --git a/gnu/usr.bin/perl/lib/Term/Cap.pm b/gnu/usr.bin/perl/lib/Term/Cap.pm
index 656889591a6..5703405c9d2 100644
--- a/gnu/usr.bin/perl/lib/Term/Cap.pm
+++ b/gnu/usr.bin/perl/lib/Term/Cap.pm
@@ -104,8 +104,11 @@ as C<$self-E<gt>{TERMCAP}>.
sub termcap_path { ## private
my @termcap_path;
# $TERMCAP, if it's a filespec
- push(@termcap_path, $ENV{TERMCAP}) if ((exists $ENV{TERMCAP}) &&
- ($ENV{TERMCAP} =~ /^\//));
+ push(@termcap_path, $ENV{TERMCAP})
+ if ((exists $ENV{TERMCAP}) &&
+ (($^O eq 'os2' || $^O eq 'MSWin32')
+ ? $ENV{TERMCAP} =~ /^[a-z]:[\\\/]/i
+ : $ENV{TERMCAP} =~ /^\//));
if ((exists $ENV{TERMPATH}) && ($ENV{TERMPATH})) {
# Add the users $TERMPATH
push(@termcap_path, split(/(:|\s+)/, $ENV{TERMPATH}))
@@ -185,16 +188,20 @@ sub Tgetent { ## public -- static method
# This is eval'ed inside the while loop for each file
$search = q{
- while ($_ = <TERMCAP>) {
+ while (<TERMCAP>) {
next if /^\\t/ || /^#/;
if ($_ =~ m/(^|\\|)${termpat}[:|]/o) {
chomp;
s/^[^:]*:// if $first++;
$state = 0;
- while ($_ =~ s/\\\\$//) { $_ .= <TERMCAP>; chomp; }
+ while ($_ =~ s/\\\\$//) {
+ defined(my $x = <TERMCAP>) or last;
+ $_ .= $x; chomp;
+ }
last;
}
}
+ defined $entry or $entry = '';
$entry .= $_;
};
diff --git a/gnu/usr.bin/perl/lib/Term/Complete.pm b/gnu/usr.bin/perl/lib/Term/Complete.pm
index 6faef2296ed..275aadeb651 100644
--- a/gnu/usr.bin/perl/lib/Term/Complete.pm
+++ b/gnu/usr.bin/perl/lib/Term/Complete.pm
@@ -28,7 +28,8 @@ The following command characters are defined:
=over 4
-=item <tab>
+=item E<lt>tabE<gt>
+
Attempts word completion.
Cannot be changed.
@@ -42,7 +43,7 @@ Defined by I<$Term::Complete::complete>.
Erases the current input.
Defined by I<$Term::Complete::kill>.
-=item <del>, <bs>
+=item E<lt>delE<gt>, E<lt>bsE<gt>
Erases one character.
Defined by I<$Term::Complete::erase1> and I<$Term::Complete::erase2>.
@@ -55,7 +56,7 @@ Bell sounds when word completion fails.
=head1 BUGS
-The completion charater <tab> cannot be changed.
+The completion charater E<lt>tabE<gt> cannot be changed.
=head1 AUTHOR
@@ -71,6 +72,8 @@ CONFIG: {
}
sub Complete {
+ my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
+
$prompt = shift;
if (ref $_[0] || $_[0] =~ /^\*/) {
@cmp_lst = sort @{$_[0]};
@@ -110,7 +113,8 @@ sub Complete {
# (^U) kill
$_ eq $kill && do {
if ($r) {
- undef($r, $return);
+ undef $r;
+ undef $return;
print("\r\n");
redo LOOP;
}
diff --git a/gnu/usr.bin/perl/lib/Term/ReadLine.pm b/gnu/usr.bin/perl/lib/Term/ReadLine.pm
index 2ce74231867..b6923dd1e7c 100644
--- a/gnu/usr.bin/perl/lib/Term/ReadLine.pm
+++ b/gnu/usr.bin/perl/lib/Term/ReadLine.pm
@@ -33,7 +33,7 @@ or as
$term->addhistory('row');
-where $term is a return value of Term::ReadLine->Init.
+where $term is a return value of Term::ReadLine-E<gt>Init.
=over 12
@@ -74,7 +74,13 @@ 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<"<$in">, C<"E<gt>out">.
+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>
@@ -86,26 +92,79 @@ 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 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>.
+
+If the variable is not set, the best available package is loaded.
+
=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 ($in,$out,$str) = @{shift()};
- print $out shift;
- $str = scalar <$in>;
+ 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;
@@ -117,13 +176,16 @@ sub findConsole {
if (-e "/dev/tty") {
$console = "/dev/tty";
- } elsif (-e "con") {
+ } elsif (-e "con" or $^O eq 'MSWin32') {
$console = "con";
} else {
$console = "sys\$command";
}
- if (defined $ENV{'OS2_SHELL'}) { # In OS/2
+ if ($^O eq 'amigaos') {
+ $console = undef;
+ }
+ elsif ($^O eq 'os2') {
if ($DB::emacs) {
$console = undef;
} else {
@@ -163,13 +225,40 @@ sub new {
bless [$FIN, $FOUT];
}
}
+
+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 Features { {} }
+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?
-eval "use Term::ReadLine::Gnu;" or eval "use Term::ReadLine::Perl;";
+
+my $which = $ENV{PERL_RL};
+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) { # Defined but false
+ # Do nothing fancy
+} else {
+ eval "use Term::ReadLine::Gnu; 1" or eval "use Term::ReadLine::Perl; 1";
+}
#require FileHandle;
@@ -184,6 +273,71 @@ if (defined &Term::ReadLine::Gnu::readline) {
@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 == 1;
+ my @ts = split /,/, $rl_term_set, 4;
+ eval { LoadTermCap };
+ warn("Cannot find termcap: $@\n"), return unless defined $terminal;
+ @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;
+ return scalar <$in>;
+}
1;
diff --git a/gnu/usr.bin/perl/lib/Test/Harness.pm b/gnu/usr.bin/perl/lib/Test/Harness.pm
index 7d899a69f92..f5fc3d8cc55 100644
--- a/gnu/usr.bin/perl/lib/Test/Harness.pm
+++ b/gnu/usr.bin/perl/lib/Test/Harness.pm
@@ -1,18 +1,41 @@
package Test::Harness;
+BEGIN {require 5.002;}
use Exporter;
use Benchmark;
use Config;
use FileHandle;
-use vars qw($VERSION $verbose $switches);
-require 5.002;
+use strict;
-$VERSION = "1.07";
+use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest
+ @ISA @EXPORT @EXPORT_OK);
+$have_devel_corestack = 0;
+
+$VERSION = "1.1502";
@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";
@@ -20,100 +43,194 @@ $switches = "-w";
sub runtests {
my(@tests) = @_;
local($|) = 1;
- my($test,$te,$ok,$next,$max,$pct);
+ my($test,$te,$ok,$next,$max,$pct,$totok,@failed,%failedtests);
my $totmax = 0;
my $files = 0;
my $bad = 0;
my $good = 0;
my $total = @tests;
- local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); # pass -I flags to children
+
+ # 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 $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("$^X $switches $test|") || (print "can't run. $!\n");
+ $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 = "$^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 = ();
while (<$fh>) {
if( $verbose ){
print $_;
}
- unless (/^\s*\#/) {
- if (/^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;
- push @failed, $this;
- } elsif (/^ok\s*(\d*)/) {
- $this = $1 if $1 > 0;
- $ok++;
- $totok++;
- }
- 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 "Aborting test: output counter mismatch [test $this answered when test $next expected]\n";
- last;
- }
- $next = $this + 1;
+ if (/^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;
+ push @failed, $this;
+ } elsif (/^ok\s*(\d*)/) {
+ $this = $1 if $1 > 0;
+ $ok++;
+ $totok++;
+ }
+ 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 = $?;
- my $estatus = $wstatus >> 8;
- if ($ok == $max && $next == $max+1 && ! $estatus) {
- print "ok\n";
+ 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) {
+ print "ok\n";
+ } else {
+ print "skipping test on this platform\n";
+ }
$good++;
} elsif ($max) {
if ($next <= $max) {
push @failed, $next..$max;
}
if (@failed) {
- print canonfailed($max,@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 for some reason\n";
+ 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++;
- }
- if ($wstatus) {
- print "\tTest returned status $estatus (wstat $wstatus)\n";
+ $failedtests{$test} = { canon => '??', max => '??',
+ failed => '??',
+ name => $test, percent => undef,
+ estat => '', wstat => '',
+ };
}
}
my $t_total = timediff(new Benchmark, $t_start);
+ if ($^O eq 'VMS') {
+ if (defined $old5lib) {
+ $ENV{PERL5LIB} = $old5lib;
+ } else {
+ delete $ENV{PERL5LIB};
+ }
+ }
if ($bad == 0 && $totmax) {
print "All tests successful.\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";
+ 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;
- if ($bad == 1) {
- die "Failed 1 test script, $pct% okay.$subpct\n";
- } else {
+ my $script;
+ for $script (sort keys %failedtests) {
+ $curtest = $failedtests{$script};
+ write;
+ }
+ if ($bad) {
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 ($@) {
@@ -125,6 +242,7 @@ sub canonfailed ($@) {
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) {
@@ -139,13 +257,16 @@ sub canonfailed ($@) {
}
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";
- join "", @result;
+ my $txt = join "", @result;
+ ($txt, $canon);
}
1;
@@ -165,22 +286,21 @@ runtests(@tests);
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 scxript is C<"1..M"> with C<M> being the
+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::runscripts(@tests) runs all the testscripts
+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, runscripts() prints some
+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 that look like perl comments (start with C</^\s*\#/>) are
-discarded. Lines containing C</^(not\s+)?ok\b/> are interpreted as
-feedback for runtests().
+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
@@ -201,12 +321,16 @@ will generate
Failed 3/6 tests, 50.00% okay
The global variable $Test::Harness::verbose is exportable and can be
-used to let runscripts() display the standard output of the script
+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>.
+
=head1 EXPORT
-C<&runscripts> is exported by Test::Harness per default.
+C<&runtests> is exported by Test::Harness per default.
=head1 DIAGNOSTICS
@@ -224,7 +348,7 @@ above are printed.
=item C<Test returned status %d (wstat %d)>
-Scripts that return a non-zero exit status, both $?>>8 and $? are
+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>
@@ -244,8 +368,8 @@ See L<Benchmark> for the underlying timing routines.
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. Current maintainer is Andreas
-Koenig.
+with perl distributions for ages. Numerous anonymous contributors
+exist. Current maintainer is Andreas Koenig.
=head1 BUGS
diff --git a/gnu/usr.bin/perl/lib/Text/Abbrev.pm b/gnu/usr.bin/perl/lib/Text/Abbrev.pm
index d12dfb36a69..ae6797c81ac 100644
--- a/gnu/usr.bin/perl/lib/Text/Abbrev.pm
+++ b/gnu/usr.bin/perl/lib/Text/Abbrev.pm
@@ -8,19 +8,25 @@ abbrev - create an abbreviation table from a list
=head1 SYNOPSIS
- use Abbrev;
- abbrev *HASH, LIST
+ use Text::Abbrev;
+ abbrev $hashref, LIST
=head1 DESCRIPTION
Stores all unambiguous truncations of each element of LIST
-as keys key in the associative array indicated by C<*hash>.
+as keys key in the associative array referenced to by C<$hashref>.
The values are the original list elements.
=head1 EXAMPLE
- abbrev(*hash,qw("list edit send abort gripe"));
+ $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
@@ -33,17 +39,26 @@ The values are the original list elements.
# $long = $foo{$short};
sub abbrev {
- local(*domain) = shift;
- @cmp = @_;
- %domain = ();
+ 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 (@_) {
- @extra = split(//,$name);
- $abbrev = shift(@extra);
- $len = 1;
- foreach $cmp (@cmp) {
+ 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) {
- $abbrev .= shift(@extra);
+ last WORD unless @extra;
+ $abbrev .= shift(@extra);
++$len;
}
}
@@ -53,6 +68,19 @@ sub abbrev {
$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/gnu/usr.bin/perl/lib/Text/ParseWords.pm b/gnu/usr.bin/perl/lib/Text/ParseWords.pm
index 89951387ef6..62da1d273fe 100644
--- a/gnu/usr.bin/perl/lib/Text/ParseWords.pm
+++ b/gnu/usr.bin/perl/lib/Text/ParseWords.pm
@@ -1,11 +1,13 @@
package Text::ParseWords;
require 5.000;
-require Exporter;
-require AutoLoader;
use Carp;
-@ISA = qw(Exporter AutoLoader);
+require AutoLoader;
+*AUTOLOAD = \&AutoLoader::AUTOLOAD;
+
+require Exporter;
+@ISA = qw(Exporter);
@EXPORT = qw(shellwords quotewords);
@EXPORT_OK = qw(old_shellwords);
@@ -35,7 +37,6 @@ This version differs from the original in that it will _NOT_ default
to using $_ if no arguments are given. I personally find the old behavior
to be a mis-feature.
-
&quotewords() works by simply jamming all of @lines into a single
string in $_ and then pulling off words a bit at a time until $_
is exhausted.
@@ -88,43 +89,49 @@ sub quotewords {
# at a time behavior was necessary if the delimiter was going to be a
# regexp (love to hear it if you can figure out a better way).
- local($delim, $keep, @lines) = @_;
- local(@words,$snippet,$field,$_);
+ my ($delim, $keep, @lines) = @_;
+ my (@words, $snippet, $field);
+
+ local $_ = join ('', @lines);
- $_ = join('', @lines);
- while ($_) {
+ while (length) {
$field = '';
+
for (;;) {
- $snippet = '';
- if (s/^"(([^"\\]|\\[\\"])*)"//) {
+ $snippet = '';
+
+ if (s/^"([^"\\]*(\\.[^"\\]*)*)"//) {
$snippet = $1;
- $snippet = "\"$snippet\"" if ($keep);
+ $snippet = qq|"$snippet"| if $keep;
}
- elsif (s/^'(([^'\\]|\\[\\'])*)'//) {
+ elsif (s/^'([^'\\]*(\\.[^'\\]*)*)'//) {
$snippet = $1;
- $snippet = "'$snippet'" if ($keep);
+ $snippet = "'$snippet'" if $keep;
}
elsif (/^["']/) {
- croak "Unmatched quote";
+ croak 'Unmatched quote';
}
- elsif (s/^\\(.)//) {
- $snippet = $1;
- $snippet = "\\$snippet" if ($keep);
- }
- elsif (!$_ || s/^$delim//) {
- last;
+ elsif (s/^\\(.)//) {
+ $snippet = $1;
+ $snippet = "\\$snippet" if $keep;
+ }
+ elsif (!length || s/^$delim//) {
+ last;
}
else {
- while ($_ && !(/^$delim/ || /^['"\\]/)) {
- $snippet .= substr($_, 0, 1);
- substr($_, 0, 1) = '';
- }
+ while (length && !(/^$delim/ || /^['"\\]/)) {
+ $snippet .= substr ($_, 0, 1);
+ substr($_, 0, 1) = '';
+ }
}
+
$field .= $snippet;
}
- push(@words, $field);
+
+ push @words, $field;
}
- @words;
+
+ return @words;
}
diff --git a/gnu/usr.bin/perl/lib/Text/Soundex.pm b/gnu/usr.bin/perl/lib/Text/Soundex.pm
index 82df8c0d74d..a70c14219a5 100644
--- a/gnu/usr.bin/perl/lib/Text/Soundex.pm
+++ b/gnu/usr.bin/perl/lib/Text/Soundex.pm
@@ -5,7 +5,7 @@ require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&soundex $soundex_nocode);
-# $Id: Soundex.pm,v 1.1.1.1 1996/08/19 10:12:51 downsj Exp $
+# $Id: Soundex.pm,v 1.2 1997/11/30 07:58:05 millert Exp $
#
# Implementation of soundex algorithm as described by Knuth in volume
# 3 of The Art of Computer Programming, with ideas stolen from Ian
@@ -23,9 +23,8 @@ require Exporter;
# Lukasiewicz, Lissajous -> L222
#
# $Log: Soundex.pm,v $
-# Revision 1.1.1.1 1996/08/19 10:12:51 downsj
-# Import of Perl 5.003 into the tree. Makefile.bsd-wrapper and
-# config.sh.OpenBSD are the only local changes.
+# Revision 1.2 1997/11/30 07:58:05 millert
+# perl 5.004_04
#
# Revision 1.2 1994/03/24 00:30:27 mike
# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu>
@@ -52,7 +51,7 @@ sub soundex
foreach (@s)
{
- tr/a-z/A-Z/;
+ $_ = uc $_;
tr/A-Z//cd;
if ($_ eq '')
diff --git a/gnu/usr.bin/perl/lib/Text/Tabs.pm b/gnu/usr.bin/perl/lib/Text/Tabs.pm
index 2481d81ec6b..acd7afb7d6f 100644
--- a/gnu/usr.bin/perl/lib/Text/Tabs.pm
+++ b/gnu/usr.bin/perl/lib/Text/Tabs.pm
@@ -1,43 +1,3 @@
-#
-# expand and unexpand tabs as per the unix expand and
-# unexpand programs.
-#
-# expand and unexpand operate on arrays of lines. Do not
-# feed strings that contain newlines to them.
-#
-# David Muir Sharnoff <muir@idiom.com>
-#
-# Version: 9/21/95
-#
-
-=head1 NAME
-
-Text::Tabs -- expand and unexpand tabs
-
-=head1 SYNOPSIS
-
- use Text::Tabs;
-
- #$tabstop = 8; # Defaults
- print expand("Hello\tworld");
- print unexpand("Hello, world");
- $tabstop = 4;
- print join("\n",expand(split(/\n/,
- "Hello\tworld,\nit's a nice day.\n"
- )));
-
-=head1 DESCRIPTION
-
-This module expands and unexpands tabs into spaces, as per the unix expand
-and unexpand programs. Either function should be passed an array of strings
-(newlines may I<not> be included, and should be used to split an incoming
-string into separate elements.) which will be processed and returned.
-
-=head1 AUTHOR
-
-David Muir Sharnoff <muir@idiom.com>
-
-=cut
package Text::Tabs;
@@ -46,35 +6,92 @@ require Exporter;
@ISA = (Exporter);
@EXPORT = qw(expand unexpand $tabstop);
-$tabstop = 8;
+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/^([^\t]*)(\t+)/
- $1 . (" " x
- ($tabstop * length($2)
- - (length($1) % $tabstop)))
- /e;
+ 1 while s/(^|\n)([^\t\n]*)(\t+)/
+ $1. $2 . (" " x
+ ($tabstop * length($3)
+ - (length($2) % $tabstop)))
+ /sex;
}
return @l if wantarray;
- return @l[0];
+ return $l[0];
}
sub unexpand
{
- my @l = &expand(@_);
+ my @l = @_;
my @e;
+ my $x;
+ my $line;
+ my @lines;
+ my $lastbit;
for $x (@l) {
- @e = split(/(.{$tabstop})/,$x);
- for $_ (@e) {
- s/ +$/\t/;
+ @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('',@e);
+ $x = join("\n", @lines);
}
return @l if wantarray;
- return @l[0];
+ 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/gnu/usr.bin/perl/lib/Text/Wrap.pm b/gnu/usr.bin/perl/lib/Text/Wrap.pm
index b665752f942..0910a2ab345 100644
--- a/gnu/usr.bin/perl/lib/Text/Wrap.pm
+++ b/gnu/usr.bin/perl/lib/Text/Wrap.pm
@@ -1,93 +1,145 @@
-
package Text::Wrap;
-#
-# This is a very simple paragraph formatter. It formats one
-# paragraph at a time by wrapping and indenting text.
-#
-# Usage:
-#
-# use Text::Wrap;
-#
-# print wrap($initial_tab,$subsequent_tab,@text);
-#
-# You can also set the number of columns to wrap before:
-#
-# $Text::Wrap::columns = 135; # <= width of screen
-#
-# use Text::Wrap qw(wrap $columns);
-# $columns = 70;
-#
-#
-# The first line will be printed with $initial_tab prepended. All
-# following lines will have $subsequent_tab prepended.
-#
-# Example:
-#
-# print wrap("\t","","This is a bit of text that ...");
-#
-# David Muir Sharnoff <muir@idiom.com>
-# Version: 9/21/95
-#
-
-=head1 NAME
-
-Text::Wrap -- wrap text into a paragraph
-
-=head1 SYNOPSIS
-
- use Text::Wrap;
-
- $Text::Wrap::columns = 20; # Default
- print wrap("\t","",Hello, world, it's a nice day, isn't it?");
-
-=head1 DESCRIPTION
-
-This module is a simple paragraph formatter that wraps text into a paragraph
-and indents each line. The single exported function, wrap(), takes three
-arguments. The first is included before the first output line, and the
-second argument is included before each subsequest output line. The third
-argument is the text to be wrapped.
-
-=head1 AUTHOR
-
-David Muir Sharnoff <muir@idiom.com>
-
-=cut
-
require Exporter;
@ISA = (Exporter);
@EXPORT = qw(wrap);
@EXPORT_OK = qw($columns);
+$VERSION = 97.011701;
+
+use vars qw($VERSION $columns $debug);
+use strict;
+
BEGIN {
- $Text::Wrap::columns = 76; # <= screen width
+ $columns = 76; # <= screen width
+ $debug = 0;
}
-use Text::Tabs;
-use strict;
+use Text::Tabs qw(expand unexpand);
sub wrap
{
my ($ip, $xp, @t) = @_;
- my $r;
+ my $r = "";
my $t = expand(join(" ",@t));
my $lead = $ip;
- my $ll = $Text::Wrap::columns - length(expand($lead)) - 1;
- if ($t =~ s/^([^\n]{0,$ll})\s//) {
- $r .= unexpand($lead . $1 . "\n");
+ my $ll = $columns - length(expand($lead)) - 1;
+ my $nl = "";
+
+ # remove up to a line length of things that aren't
+ # new lines and tabs.
+
+ if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm) {
+
+ # accept it.
+ $r .= unexpand($lead . $1);
+
+ # recompute the leader
$lead = $xp;
- my $ll = $Text::Wrap::columns - length(expand($lead)) - 1;
- while ($t =~ s/^([^\n]{0,$ll})\s//) {
- $r .= unexpand($lead . $1 . "\n");
+ $ll = $columns - length(expand($lead)) - 1;
+ $nl = $2;
+
+ # repeat the above until there's none left
+ while ($t) {
+ if ( $t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm ) {
+ print "\$2 is '$2'\n" if $debug;
+ $nl = $2;
+ $r .= unexpand("\n" . $lead . $1);
+ } elsif ($t =~ s/^([^\n]{$ll})//) {
+ $nl = "\n";
+ $r .= unexpand("\n" . $lead . $1);
+ }
}
+ $r .= $nl;
}
+
die "couldn't wrap '$t'"
if length($t) > $ll;
- $r .= $t;
+
+ print "-----------$r---------\n" if $debug;
+
+ print "Finish up with '$lead', '$t'\n" if $debug;
+
+ $r .= $lead . $t if $t ne "";
+
+ print "-----------$r---------\n" if $debug;;
return $r;
}
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);
+
+ $columns = 132;
+
+=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.
+
+=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 split at line-length.
+
+=head1 AUTHOR
+
+David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and
+others.
+
+=cut
+
+Latest change by Andreas Koenig <k@anna.in-berlin.de> - 1/17/97
+
+ print fill($initial_tab, $subsequent_tab, @text);
+
+ print fill("", "", `cat book`);
+
+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().
+
+# Tim Pierce did a faster version of this:
+
+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);
+}
+
diff --git a/gnu/usr.bin/perl/lib/Tie/Hash.pm b/gnu/usr.bin/perl/lib/Tie/Hash.pm
index 9a9d059a7f7..2117c54c183 100644
--- a/gnu/usr.bin/perl/lib/Tie/Hash.pm
+++ b/gnu/usr.bin/perl/lib/Tie/Hash.pm
@@ -26,8 +26,8 @@ Tie::Hash, Tie::StdHash - base class definitions for tied hashes
package main;
- tie %new_hash, NewHash;
- tie %new_std_hash, NewStdHash;
+ tie %new_hash, 'NewHash';
+ tie %new_std_hash, 'NewStdHash';
=head1 DESCRIPTION
@@ -98,7 +98,7 @@ L<Config> module. While these do not utilize B<Tie::Hash>, they serve as
good working examples.
=cut
-
+
use Carp;
sub new {
diff --git a/gnu/usr.bin/perl/lib/Tie/RefHash.pm b/gnu/usr.bin/perl/lib/Tie/RefHash.pm
new file mode 100644
index 00000000000..66de2572fcd
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/Tie/Scalar.pm b/gnu/usr.bin/perl/lib/Tie/Scalar.pm
index 2db02ae1daf..ef27dc1398c 100644
--- a/gnu/usr.bin/perl/lib/Tie/Scalar.pm
+++ b/gnu/usr.bin/perl/lib/Tie/Scalar.pm
@@ -26,8 +26,8 @@ Tie::Scalar, Tie::StdScalar - base class definitions for tied scalars
package main;
- tie $new_scalar, NewScalar;
- tie $new_std_scalar, NewStdScalar;
+ tie $new_scalar, 'NewScalar';
+ tie $new_std_scalar, 'NewStdScalar';
=head1 DESCRIPTION
diff --git a/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm b/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm
index a01c66ef8d5..44c2140c7be 100644
--- a/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm
+++ b/gnu/usr.bin/perl/lib/Tie/SubstrHash.pm
@@ -8,7 +8,7 @@ Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
require Tie::SubstrHash;
- tie %myhash, Tie::SubstrHash, $key_len, $value_len, $table_size;
+ tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;
=head1 DESCRIPTION
@@ -144,13 +144,17 @@ sub hashkey {
$hash = 2;
for (unpack('C*', $key)) {
$hash = $hash * 33 + $_;
+ &_hashwrap if $hash >= 1e13;
}
- $hash = $hash - int($hash / $tsize) * $tsize
- if $hash >= $tsize;
+ &_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;
diff --git a/gnu/usr.bin/perl/lib/Time/Local.pm b/gnu/usr.bin/perl/lib/Time/Local.pm
index 451c7fa20c7..eef412d46d7 100644
--- a/gnu/usr.bin/perl/lib/Time/Local.pm
+++ b/gnu/usr.bin/perl/lib/Time/Local.pm
@@ -8,7 +8,7 @@ use Carp;
=head1 NAME
-Time::Local - efficiently compute tome from local and GMT time
+Time::Local - efficiently compute time from local and GMT time
=head1 SYNOPSIS
@@ -39,53 +39,78 @@ after the 1st of January, 2038 on most machines.
=cut
-@epoch = localtime(0);
-$tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT
-if ($tzmin > 0) {
- $tzmin = 24 * 60 - $tzmin; # minutes west of GMT
- $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line
-}
+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;
-$SEC = 1;
-$MIN = 60 * $SEC;
-$HR = 60 * $MIN;
-$DAYS = 24 * $HR;
-$YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0;
+}
sub timegm {
$ym = pack(C2, @_[5,4]);
$cheat = $cheat{$ym} || &cheat;
- return -1 if $cheat<0;
- $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS;
+ return -1 if $cheat<0 and $^O ne 'VMS';
+ $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY;
}
sub timelocal {
- $time = &timegm + $tzmin*$MIN;
- return -1 if $cheat<0;
- @test = localtime($time);
+ 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 out of range 0..11 in timelocal.pl"
- if $month > 11 || $month < 0;
- croak "Day out of range 1..31 in timelocal.pl"
- if $_[3] > 31 || $_[3] < 1;
- croak "Hour out of range 0..23 in timelocal.pl"
- if $_[2] > 23 || $_[2] < 0;
- croak "Minute out of range 0..59 in timelocal.pl"
- if $_[1] > 59 || $_[1] < 0;
- croak "Second out of range 0..59 in timelocal.pl"
- if $_[0] > 59 || $_[0] < 0;
+ 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[5];
+ $year += $YearFix if $year < $epoch;
$lastguess = "";
+ $counter = 0;
while ($diff = $year - $g[5]) {
- $guess += $diff * (363 * $DAYS);
+ 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
@@ -93,7 +118,8 @@ sub cheat {
$lastguess = $thisguess;
}
while ($diff = $month - $g[4]) {
- $guess += $diff * (27 * $DAYS);
+ 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
@@ -105,7 +131,7 @@ sub cheat {
return -1; #date beyond this machine's integer limit
}
$g[3]--;
- $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAYS;
+ $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAY;
$cheat{$ym} = $guess;
}
diff --git a/gnu/usr.bin/perl/lib/Time/gmtime.pm b/gnu/usr.bin/perl/lib/Time/gmtime.pm
new file mode 100644
index 00000000000..c1d11d74dbb
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/Time/localtime.pm b/gnu/usr.bin/perl/lib/Time/localtime.pm
new file mode 100644
index 00000000000..94377525973
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/Time/tm.pm b/gnu/usr.bin/perl/lib/Time/tm.pm
new file mode 100644
index 00000000000..fd47ad19a95
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/UNIVERSAL.pm b/gnu/usr.bin/perl/lib/UNIVERSAL.pm
new file mode 100644
index 00000000000..dc02423029e
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/User/grent.pm b/gnu/usr.bin/perl/lib/User/grent.pm
new file mode 100644
index 00000000000..deb0a8d1be9
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/User/pwent.pm b/gnu/usr.bin/perl/lib/User/pwent.pm
new file mode 100644
index 00000000000..32301cadfc5
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/abbrev.pl b/gnu/usr.bin/perl/lib/abbrev.pl
index c233d4af7e6..62975e66f32 100644
--- a/gnu/usr.bin/perl/lib/abbrev.pl
+++ b/gnu/usr.bin/perl/lib/abbrev.pl
@@ -17,7 +17,7 @@ sub main'abbrev {
$len = 1;
foreach $cmp (@cmp) {
next if $cmp eq $name;
- while (substr($cmp,0,$len) eq $abbrev) {
+ while (@extra && substr($cmp,0,$len) eq $abbrev) {
$abbrev .= shift(@extra);
++$len;
}
diff --git a/gnu/usr.bin/perl/lib/autouse.pm b/gnu/usr.bin/perl/lib/autouse.pm
new file mode 100644
index 00000000000..ab95a19d8ab
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/autouse.pm
@@ -0,0 +1,166 @@
+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 BUGS
+
+If Module::func3() is autoused, and the module is loaded between the
+C<autouse> directive and a call to Module::func3(), warnings about
+redefinition would appear if warnings are enabled.
+
+If Module::func3() is autoused, warnings are disabled when loading the
+module via autoused functions.
+
+=head1 AUTHOR
+
+Ilya Zakharevich (ilya@math.ohio-state.edu)
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
diff --git a/gnu/usr.bin/perl/lib/base.pm b/gnu/usr.bin/perl/lib/base.pm
new file mode 100644
index 00000000000..e20a64bc9a4
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/base.pm
@@ -0,0 +1,49 @@
+=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);
+ }
+
+This module was introduced with Perl 5.004_04.
+
+=head1 BUGS
+
+Needs proper documentation!
+
+=cut
+
+package base;
+
+sub import {
+ my $class = shift;
+
+ foreach my $base (@_) {
+ unless (defined %{"$base\::"}) {
+ eval "require $base";
+ 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.)");
+ }
+ }
+ }
+
+ push @{caller(0) . '::ISA'}, @_;
+}
+
+1;
diff --git a/gnu/usr.bin/perl/lib/bigfloat.pl b/gnu/usr.bin/perl/lib/bigfloat.pl
index 9ad171f295a..d687c784f1c 100644
--- a/gnu/usr.bin/perl/lib/bigfloat.pl
+++ b/gnu/usr.bin/perl/lib/bigfloat.pl
@@ -41,8 +41,10 @@ $rnd_mode = 'even';
sub main'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));
+ 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';
}
diff --git a/gnu/usr.bin/perl/lib/bigint.pl b/gnu/usr.bin/perl/lib/bigint.pl
index e6ba644e3b3..bfd2efa88c8 100644
--- a/gnu/usr.bin/perl/lib/bigint.pl
+++ b/gnu/usr.bin/perl/lib/bigint.pl
@@ -103,13 +103,23 @@ sub main'bcmp { #(num_str, num_str) return cond_code
sub cmp { # post-normalized compare for internal use
local($cx, $cy) = @_;
- $cx cmp $cy
- &&
- (
- ord($cy) <=> ord($cx)
- ||
- ($cx cmp ',') * (length($cy) <=> length($cx) || $cy cmp $cx)
- );
+ 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
@@ -158,11 +168,11 @@ sub add { #(int_num_array, int_num_array) return int_num_array
$car = 0;
for $x (@x) {
last unless @y || $car;
- $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5);
+ $x -= 1e5 if $car = (($x += shift(@y) + $car) >= 1e5) ? 1 : 0;
}
for $y (@y) {
last unless $car;
- $y -= 1e5 if $car = (($y += $car) >= 1e5);
+ $y -= 1e5 if $car = (($y += $car) >= 1e5) ? 1 : 0;
}
(@x, @y, $car);
}
diff --git a/gnu/usr.bin/perl/lib/blib.pm b/gnu/usr.bin/perl/lib/blib.pm
new file mode 100644
index 00000000000..9e0f6c07c3d
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/blib.pm
@@ -0,0 +1,71 @@
+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 (@_)
+ {
+ $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/gnu/usr.bin/perl/lib/cacheout.pl b/gnu/usr.bin/perl/lib/cacheout.pl
index 48d594bf825..64378cffc6f 100644
--- a/gnu/usr.bin/perl/lib/cacheout.pl
+++ b/gnu/usr.bin/perl/lib/cacheout.pl
@@ -35,7 +35,7 @@ $seq = 0;
$numopen = 0;
if (open(PARAM,'/usr/include/sys/param.h')) {
- local($.);
+ local($_, $.);
while (<PARAM>) {
$maxopen = $1 - 4 if /^\s*#\s*define\s+NOFILE\s+(\d+)/;
}
diff --git a/gnu/usr.bin/perl/lib/chat2.inter b/gnu/usr.bin/perl/lib/chat2.inter
deleted file mode 100644
index 6934f1cc285..00000000000
--- a/gnu/usr.bin/perl/lib/chat2.inter
+++ /dev/null
@@ -1,495 +0,0 @@
-Article 20992 of comp.lang.perl:
-Path: netlabs!news.cerf.net!mvb.saic.com!MathWorks.Com!europa.eng.gtefsd.com!howland.reston.ans.net!cs.utexas.edu!swrinde!ihnp4.ucsd.edu!ames!koriel!male.EBay.Sun.COM!jethro.Corp.Sun.COM!eric
-From: eric.arnold@sun.com (Eric Arnold)
-Newsgroups: comp.lang.perl
-Subject: Re: Need a bidirectional filter for interactive Unix applications
-Date: 15 Apr 94 21:24:03 GMT
-Organization: Sun Microsystems
-Lines: 478
-Sender: news@sun.com
-Message-ID: <ERIC.94Apr15212403@sun.com>
-References: <dgfCo9F2J.Jzw@netcom.com> <1994Apr15.110134.4581@chemabs.uucp>
-NNTP-Posting-Host: animus.corp.sun.com
-X-Newsreader: prn Ver 1.09
-In-reply-to: btf64@cas.org's message of Fri, 15 Apr 1994 11:01:34 GMT
-
-In article <1994Apr15.110134.4581@chemabs.uucp>
- btf64@cas.org (Bernard T. French) writes:
-
->In article <dgfCo9F2J.Jzw@netcom.com> dgf@netcom.com (David Feldman) writes:
->>I need to write a bidirectional filter that would (ideally) sit between a
-..
->>program's stdin & stdout to point to a pty pair known to perl. The perl app-
->>lication would talk to the user's crt/keyboard, translate (application-specific)
->>the input & output streams, and pass these as appropriate to/from the pty pair,
-..
->
-> I'm afraid I can't offer you a perl solution, but err..... there is a
->Tcl solution. There is a Tcl extension called "expect" that is designed to
-
-There *is* an old, established Perl solution: "chat2.pl" which does
-everything (well, basically) "expect" does but you get it in the
-expressive Perl environment. "chat2.pl" is delivered with the Perl
-source.
-
-Randal: "interact()" still hasn't made it into Perl5alpha8
-"chat2.pl", so I've included a version which does.
-
--Eric
-
-
-## chat.pl: chat with a server
-## V2.01.alpha.7 91/06/16
-## Randal L. Schwartz
-
-package chat;
-
-$sockaddr = 'S n a4 x8';
-chop($thishost = `hostname`); $thisaddr = (gethostbyname($thishost))[4];
-$thisproc = pack($sockaddr, 2, 0, $thisaddr);
-
-# *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);
-
- *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, 2, 1, 6)) {
- # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
- # but who the heck would change these anyway? (:-)
- ($!) = ($!, 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;
- }
- 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, 2, 1, 6)) {
- # XXX hardwired $AF_SOCKET, $SOCK_STREAM, 'tcp'
- # but who the heck would change these anyway? (:-)
- ($!) = ($!, 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,$pty_handle) = &_getpty(S,TTY);
-
- #local($pty,$tty,$pty_handle) = &getpty(S,TTY);
- #$Tty = $tty;
-
- die "Cannot find a new pty" unless defined $pty;
- local($pid) = fork;
- die "Cannot fork: $!" unless defined $pid;
- unless ($pid) {
- close STDIN; close STDOUT; close STDERR;
- #close($pty_handle);
- 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);
- $PID{$next} = $pid;
- $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;
- }
- print S @_;
-}
-
-## &chat'close([$handle,])
-## $handle is from previous &chat'open().
-## like close $handle
-
-sub close { ## public
- local($pid);
- if ($_[0] =~ /$nextpat/) {
- $pid = $PID{$_[0]};
- *S = shift;
- } else {
- $pid = $PID{$next};
- }
- close(S);
- waitpid($pid,0);
- 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.
-
-sub _getpty { ## private
- local($_PTY,$_TTY) = @_;
- $_PTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
- $_TTY =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
- local($pty,$tty);
- for $bank (112..127) {
- next unless -e sprintf("/dev/pty%c0", $bank);
- for $unit (48..57) {
- $pty = sprintf("/dev/pty%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,$_PTY);
- }
- }
- undef;
-}
-
-
-sub getpty {
- local( $pty_handle, $tty_handle ) = @_;
-
-print "--------in getpty----------\n";
- $pty_handle =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
- $pty_handle =~ s/^([^']+)$/(caller)[$[]."'".$1/e;
-
- #$pty_handle = ++$next_handle;
- chop( @ptys = `ls /dev/pty*` );
-
- for $pty ( @ptys )
- {
- open($pty_handle,"+>$pty") || next;
- select((select($pty_handle), $| = 1)[0]);
- ($tty = $pty) =~ s/pty/tty/;
-
- open($tty_handle,"+>$tty") || next;
- select((select($tty_handle), $| = 1)[0]);
- ($tty = $pty) =~ s/pty/tty/;
-
- return ($pty, $tty, $pty_handle );
- }
- return undef;
-}
-
-
-
-# from: Randal L. Schwartz
-
-# Usage:
-#
-# ($chathandle = &chat'open_proc("/bin/sh")) || die "cannot open shell";
-# system("stty cbreak raw -echo >/dev/tty\n");
-# &chat'interact($chathandle);
-# &chat'close($chathandle);
-# system("stty -cbreak -raw echo >/dev/tty\n");
-
-sub interact
-{
- local( $chathandle ) = @_;
-
- &chat'print($chathandle, "stty sane\n");
- select(STDOUT) ; $| = 1; # unbuffer STDOUT
-
- #print "tty=$Tty,whoami=",`whoami`,"\n";
- #&change_utmp( "", $Tty, "eric", "", time() );
-
- {
- @ready = &chat'select(30, STDIN,$chathandle);
- print "after select, ready=",join(",",@ready),"\n";
- #(warn "[waiting]"), redo unless @ready;
- if (grep($_ eq $chathandle, @ready)) {
- print "checking $chathandle\n";
- last unless $text = &chat'expect($chathandle,0,'[\s\S]+','$&');
- print "$chathandle OK\n";
- print "got=($text)";
- #print $text;
- }
- if (grep($_ eq STDIN, @ready)) {
- print "checking STDIN\n";
- last unless sysread(STDIN,$buf,1024) > 0;
- print "STDIN OK\n";
- &chat'print($chathandle,$buf);
- }
- redo;
- }
- #&change_utmp( $Tty, "$Tty", "", "", 0 );
- print "leaving interact, \$!=$!\n";
-}
-
-## $handle = &chat'open_duphandle(handle);
-## duplicates an input file handle to conform to chat format
-
-sub open_duphandle { ## public
- *S = ++$next;
- open(S,"<&$_[0]");
- $next; # return symbol for switcharound
-}
-
-#Here is an example which uses this routine.
-#
-# # The following lines makes stdin unbuffered
-#
-# $BSD = -f '/vmunix';
-#
-# if ($BSD) {
-# system "stty cbreak </dev/tty >/dev/tty 2>&1";
-# }
-# else {
-# system "stty", '-icanon';
-# system "stty", 'eol', '^A';
-# }
-#
-# require 'mychat2.pl';
-#
-# &chat'open_duphandle(STDIN);
-#
-# print
-# &chat'expect(3,
-# '[A-Z]', '" :-)"',
-# '.', '" :-("',
-# TIMEOUT, '"-o-"',
-# EOF, '"\$\$"'),
-# "\n";
-
-
-1;
-
-
diff --git a/gnu/usr.bin/perl/lib/complete.pl b/gnu/usr.bin/perl/lib/complete.pl
index 1e08f9145ae..539f2f77983 100644
--- a/gnu/usr.bin/perl/lib/complete.pl
+++ b/gnu/usr.bin/perl/lib/complete.pl
@@ -35,7 +35,7 @@ CONFIG: {
sub Complete {
package Complete;
- local($[,$return) = 0;
+ local($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
if ($_[1] =~ /^StB\0/) {
($prompt, *_) = @_;
}
@@ -75,7 +75,8 @@ sub Complete {
# (^U) kill
$_ eq $kill && do {
if ($r) {
- undef($r, $return);
+ undef $r;
+ undef $return;
print("\r\n");
redo LOOP;
}
diff --git a/gnu/usr.bin/perl/lib/constant.pm b/gnu/usr.bin/perl/lib/constant.pm
new file mode 100644
index 00000000000..a0d4f9d5cda
--- /dev/null
+++ b/gnu/usr.bin/perl/lib/constant.pm
@@ -0,0 +1,163 @@
+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.
+
+=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/gnu/usr.bin/perl/lib/diagnostics.pm b/gnu/usr.bin/perl/lib/diagnostics.pm
index 3560f2d708d..78bf4457cba 100644
--- a/gnu/usr.bin/perl/lib/diagnostics.pm
+++ b/gnu/usr.bin/perl/lib/diagnostics.pm
@@ -1,18 +1,4 @@
-#!/usr/local/bin/perl
-eval 'exec perl -S $0 ${1+"$@"}'
- if 0;
-
-use Config;
-if ($^O eq 'VMS') {
- $diagnostics::PODFILE = VMS::Filespec::unixify($Config{'privlib'}) .
- '/pod/perldiag.pod';
-}
-else { $diagnostics::PODFILE= $Config{privlib} . "/pod/perldiag.pod"; }
-
package diagnostics;
-require 5.001;
-use English;
-use Carp;
=head1 NAME
@@ -41,9 +27,9 @@ Aa a program:
=head2 The C<diagnostics> Pragma
This module extends the terse diagnostics normally emitted by both the
-perl compiler and the perl interpeter, augmenting them wtih the more
+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 to compilation phase of your program rather
+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
@@ -62,8 +48,8 @@ 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 can generate nicer escape
-sequences for pgers.
+any other diagnostics. The $diagnostics::PRETTY variable can generate nicer
+escape sequences for pagers.
=head2 The I<splain> Program
@@ -98,7 +84,7 @@ afterwards, do this:
./splain < test.out
Note that this is not in general possible in shells of more dubious heritage,
-as the theorectical
+as the theoretical
(perl -w test.pl >/dev/tty) >& test.out
./splain < test.out
@@ -143,7 +129,7 @@ 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 diagnostic::splainthis() function
+to be honored, but only after the diagnostics::splainthis() function
(the module's $SIG{__WARN__} interceptor) has had its way with your
warnings.
@@ -159,27 +145,44 @@ 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 to this instead, and I<before> you load the module.
+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 5.001e.
+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<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995.
+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
-$OUTPUT_AUTOFLUSH = 1;
+$| = 1;
local $_;
@@ -191,7 +194,8 @@ CONFIG: {
unless (caller) {
$standalone++;
require Getopt::Std;
- Getopt::Std::getopts('pdvf:') || die "Usage: $0 [-v] [-p] [-f splainpod]";
+ 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;
@@ -315,7 +319,9 @@ EOFUNC
}
next;
}
- $header = $1;
+
+ # strip formatting directives in =item line
+ ($header = $1) =~ s/[A-Z]<(.*?)>/$1/g;
if ($header =~ /%[sd]/) {
$rhs = $lhs = $header;
@@ -328,13 +334,15 @@ EOFUNC
#$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}\n\t&& return 1;\n";
+ $transmo .= " s{^$lhs}\n {\Q$rhs\E}s\n\t&& return 1;\n";
} else {
$transmo .= " m{^\Q$header\E} && return 1;\n";
}
- print STDERR "Already saw $header" if $msg{$header};
+ print STDERR "$WHOAMI: Duplicate entry: \"$header\"\n"
+ if $msg{$header};
$msg{$header} = '';
}
@@ -353,7 +361,7 @@ EOFUNC
if ($standalone) {
if (!@ARGV and -t STDIN) { print STDERR "$0: Reading from STDIN\n" }
- while ($error = <>) {
+ while (defined ($error = <>)) {
splainthis($error) || print THITHER $error;
}
exit;
@@ -415,10 +423,27 @@ sub warn_trap {
sub death_trap {
my $exception = $_[0];
- splainthis($exception);
+
+ # 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;
- $SIG{__DIE__} = $SIG{__WARN__} = '';
+
+ # 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
@@ -428,6 +453,7 @@ sub death_trap {
sub splainthis {
local $_ = shift;
+ local $\;
### &finish_compilation unless %msg;
s/\.?\n+$//;
my $orig = $_;
@@ -481,7 +507,7 @@ sub unescape {
exists $HTML_Escapes{$1}
? do { $HTML_Escapes{$1} }
: do {
- warn "Unknown escape: $& in $_";
+ warn "Unknown escape: E<$1> in $_";
"E<$1>";
}
}
@@ -490,7 +516,7 @@ sub unescape {
sub shorten {
my $line = $_[0];
- if (length $line > 79) {
+ 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";
diff --git a/gnu/usr.bin/perl/lib/dotsh.pl b/gnu/usr.bin/perl/lib/dotsh.pl
index 8e9d9620e59..877467eb961 100644
--- a/gnu/usr.bin/perl/lib/dotsh.pl
+++ b/gnu/usr.bin/perl/lib/dotsh.pl
@@ -53,8 +53,8 @@ sub dotsh {
open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n";
while (<_SH_ENV>) {
chop;
- /=/;
- $ENV{$`} = $';
+ m/^([^=]*)=(.*)/s;
+ $ENV{$1} = $2;
}
close (_SH_ENV);
system "rm -f /tmp/_sh_env$$";
diff --git a/gnu/usr.bin/perl/lib/dumpvar.pl b/gnu/usr.bin/perl/lib/dumpvar.pl
index 06c09305816..c32bc2fb5e1 100644
--- a/gnu/usr.bin/perl/lib/dumpvar.pl
+++ b/gnu/usr.bin/perl/lib/dumpvar.pl
@@ -25,6 +25,7 @@ $subdump = 1;
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);
@@ -116,9 +117,9 @@ sub unwrap {
# Check for reused addresses
if (ref $v) {
- ($address) = $v =~ /(0x[0-9a-f]+)/ ;
+ ($address) = $v =~ /(0x[0-9a-f]+)\)$/ ;
if (defined $address) {
- ($type) = $v =~ /=(.*?)\(/ ;
+ ($type) = $v =~ /=(.*?)\([^=]+$/ ;
$address{$address}++ ;
if ( $address{$address} > 1 ) {
print "${sp}-> REUSED_ADDRESS\n" ;
@@ -134,7 +135,7 @@ sub unwrap {
}
}
- if ( ref $v eq 'HASH' or $type eq 'HASH') {
+ if ( UNIVERSAL::isa($v, 'HASH') ) {
@sortKeys = sort keys(%$v) ;
undef $more ;
$tHashDepth = $#sortKeys ;
@@ -167,7 +168,7 @@ sub unwrap {
}
print "$sp empty hash\n" unless @sortKeys;
print "$sp$more" if defined $more ;
- } elsif ( ref $v eq 'ARRAY' or $type eq 'ARRAY') {
+ } elsif ( UNIVERSAL::isa($v, 'ARRAY') ) {
$tArrayDepth = $#{$v} ;
undef $more ;
$tArrayDepth = $#{$v} < $arrayDepth-1 ? $#{$v} : $arrayDepth-1
@@ -197,13 +198,13 @@ sub unwrap {
}
print "$sp empty array\n" unless @$v;
print "$sp$more" if defined $more ;
- } elsif ( ref $v eq 'SCALAR' or ref $v eq 'REF' or $type eq 'SCALAR' ) {
+ } elsif ( UNIVERSAL::isa($v, 'SCALAR') or ref $v eq 'REF' ) {
print "$sp-> ";
DumpElem $$v, $s;
- } elsif ( ref $v eq 'CODE' or $type eq 'CODE' ) {
+ } elsif ( UNIVERSAL::isa($v, 'CODE') ) {
print "$sp-> ";
dumpsub (0, $v);
- } elsif (ref $v eq 'GLOB') {
+ } elsif ( UNIVERSAL::isa($v, 'GLOB') ) {
print "$sp-> ",&stringify($$v,1),"\n";
if ($globPrint) {
$s += 3;
@@ -222,8 +223,8 @@ sub unwrap {
sub matchvar {
$_[0] eq $_[1] or
- ($_[1] =~ /^([!~])(.)/) and
- ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$'/});
+ ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
+ ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
}
sub compactDump {
@@ -319,7 +320,7 @@ sub findsubs {
sub main::dumpvar {
my ($package,@vars) = @_;
- local(%address,$key,$val);
+ local(%address,$key,$val,$^W);
$package .= "::" unless $package =~ /::$/;
*stab = *{"main::"};
while ($package =~ /(\w+?::)/g){
diff --git a/gnu/usr.bin/perl/lib/find.pl b/gnu/usr.bin/perl/lib/find.pl
index 40e613e97ee..ee5dc5d1506 100644
--- a/gnu/usr.bin/perl/lib/find.pl
+++ b/gnu/usr.bin/perl/lib/find.pl
@@ -29,80 +29,19 @@
#
# Set the variable $dont_use_nlink if you're using AFS, since AFS cheats.
-sub find {
- chop($cwd = `pwd`);
- foreach $topdir (@_) {
- (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
- || (warn("Can't stat $topdir: $!\n"), next);
- if (-d _) {
- if (chdir($topdir)) {
- ($dir,$_) = ($topdir,'.');
- $name = $topdir;
- &wanted;
- ($fixtopdir = $topdir) =~ s,/$,, ;
- &finddir($fixtopdir,$topnlink);
- }
- else {
- warn "Can't cd to $topdir: $!\n";
- }
- }
- else {
- unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
- ($dir,$_) = ('.', $topdir);
- }
- $name = $topdir;
- chdir $dir && &wanted;
- }
- chdir $cwd;
- }
-}
-
-sub finddir {
- local($dir,$nlink) = @_;
- local($dev,$ino,$mode,$subcount);
- local($name);
-
- # Get the list of files in the current directory.
-
- opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return);
- local(@filenames) = readdir(DIR);
- closedir(DIR);
+use File::Find ();
- if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories.
- for (@filenames) {
- next if $_ eq '.';
- next if $_ eq '..';
- $name = "$dir/$_";
- $nlink = 0;
- &wanted;
- }
- }
- else { # This dir has subdirectories.
- $subcount = $nlink - 2;
- for (@filenames) {
- next if $_ eq '.';
- next if $_ eq '..';
- $nlink = $prune = 0;
- $name = "$dir/$_";
- &wanted;
- if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs?
+*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;
- # Get link count and check for directoriness.
-
- ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
-
- if (-d _) {
-
- # It really is a directory, so do it recursively.
-
- if (!$prune && chdir $_) {
- &finddir($name,$nlink);
- chdir '..';
- }
- --$subcount;
- }
- }
- }
- }
+sub find {
+ &File::Find::find(\&wanted, @_);
}
+
1;
diff --git a/gnu/usr.bin/perl/lib/finddepth.pl b/gnu/usr.bin/perl/lib/finddepth.pl
index 1fe6a375b6c..bfa44bb1bc9 100644
--- a/gnu/usr.bin/perl/lib/finddepth.pl
+++ b/gnu/usr.bin/perl/lib/finddepth.pl
@@ -27,79 +27,20 @@
# ($prune = 1);
# }
-sub finddepth {
- chop($cwd = `pwd`);
- foreach $topdir (@_) {
- (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
- || (warn("Can't stat $topdir: $!\n"), next);
- if (-d _) {
- if (chdir($topdir)) {
- ($fixtopdir = $topdir) =~ s,/$,, ;
- &finddepthdir($fixtopdir,$topnlink);
- ($dir,$_) = ($fixtopdir,'.');
- $name = $fixtopdir;
- &wanted;
- }
- else {
- warn "Can't cd to $topdir: $!\n";
- }
- }
- else {
- unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
- ($dir,$_) = ('.', $topdir);
- }
- chdir $dir && &wanted;
- }
- chdir $cwd;
- }
-}
-
-sub finddepthdir {
- local($dir,$nlink) = @_;
- local($dev,$ino,$mode,$subcount);
- local($name);
-
- # Get the list of files in the current directory.
-
- opendir(DIR,'.') || warn "Can't open $dir: $!\n";
- local(@filenames) = readdir(DIR);
- closedir(DIR);
- if ($nlink == 2) { # This dir has no subdirectories.
- for (@filenames) {
- next if $_ eq '.';
- next if $_ eq '..';
- $name = "$dir/$_";
- $nlink = 0;
- &wanted;
- }
- }
- else { # This dir has subdirectories.
- $subcount = $nlink - 2;
- for (@filenames) {
- next if $_ eq '.';
- next if $_ eq '..';
- $nlink = $prune = 0;
- $name = "$dir/$_";
- if ($subcount > 0) { # Seen all the subdirs?
+use File::Find ();
- # Get link count and check for directoriness.
+*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;
- ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
-
- if (-d _) {
-
- # It really is a directory, so do it recursively.
-
- if (!$prune && chdir $_) {
- &finddepthdir($name,$nlink);
- chdir '..';
- }
- --$subcount;
- }
- }
- &wanted;
- }
- }
+sub finddepth {
+ &File::Find::finddepth(\&wanted, @_);
}
+
1;
diff --git a/gnu/usr.bin/perl/lib/ftp.pl b/gnu/usr.bin/perl/lib/ftp.pl
index 78995b505d4..0a77114b6b0 100644
--- a/gnu/usr.bin/perl/lib/ftp.pl
+++ b/gnu/usr.bin/perl/lib/ftp.pl
@@ -5,11 +5,10 @@
# based on original version by Alan R. Martello <al@ee.pitt.edu>
# And by A.Macpherson@bnr.co.uk for multi-homed hosts
#
-# $Header: /home/cvs/src/gnu/usr.bin/perl/lib/Attic/ftp.pl,v 1.1.1.1 1996/08/19 10:12:34 downsj Exp $
+# $Header: /home/cvs/src/gnu/usr.bin/perl/lib/Attic/ftp.pl,v 1.2 1997/11/30 07:56:58 millert Exp $
# $Log: ftp.pl,v $
-# Revision 1.1.1.1 1996/08/19 10:12:34 downsj
-# Import of Perl 5.003 into the tree. Makefile.bsd-wrapper and
-# config.sh.OpenBSD are the only local changes.
+# Revision 1.2 1997/11/30 07:56:58 millert
+# perl 5.004_04
#
# Revision 1.17 1993/04/21 10:06:54 lmjm
# Send all status reports to STDERR not to STDOUT (to allow use by ftpcat).
@@ -92,8 +91,9 @@
# Initial revision
#
-require 'chat2.pl';
-eval "require 'socket.ph'" || eval "require 'sys/socket.ph'" || die "socket.ph missing: $!\n";
+require 'chat2.pl'; # into main
+eval "require 'socket.ph'" || eval "require 'sys/socket.ph'"
+ || die "socket.ph missing: $!\n";
package ftp;
@@ -144,7 +144,7 @@ $real_site = "";
$ftp_show = 0;
sub ftp'debug
{
- $ftp_show = @_[0];
+ $ftp_show = $_[0];
# if( $ftp_show ){
# print STDERR "ftp debugging on\n";
# }
@@ -152,7 +152,7 @@ sub ftp'debug
sub ftp'set_timeout
{
- $timeout = @_[0];
+ $timeout = $_[0];
$timeout_open = $timeout;
$timeout_read = 20 * $timeout;
if( $ftp_show ){
@@ -249,7 +249,7 @@ sub ftp'login
local( $remote_user, $remote_password ) = @_;
if( $proxy ){
- &ftp'send( "USER $remote_user@$site" );
+ &ftp'send( "USER $remote_user\@$site" );
}
else {
&ftp'send( "USER $remote_user" );
diff --git a/gnu/usr.bin/perl/lib/getcwd.pl b/gnu/usr.bin/perl/lib/getcwd.pl
index 8db8e20c069..9dd694500c6 100644
--- a/gnu/usr.bin/perl/lib/getcwd.pl
+++ b/gnu/usr.bin/perl/lib/getcwd.pl
@@ -44,9 +44,9 @@ sub getcwd
}
unless (@tst = lstat("$dotdots/$dir"))
{
- warn "lstat($dotdots/$dir): $!";
- closedir(getcwd'PARENT); #');
- return '';
+ # warn "lstat($dotdots/$dir): $!";
+ # closedir(getcwd'PARENT); #');
+ # return '';
}
}
while ($dir eq '.' || $dir eq '..' || $tst[$[] != $pst[$[] ||
@@ -54,7 +54,7 @@ sub getcwd
}
$cwd = "$dir/$cwd";
closedir(getcwd'PARENT); #');
- } while ($dir);
+ } while ($dir ne '');
chop($cwd);
$cwd;
}
diff --git a/gnu/usr.bin/perl/lib/getopt.pl b/gnu/usr.bin/perl/lib/getopt.pl
index a6023c80bc9..f871e418501 100644
--- a/gnu/usr.bin/perl/lib/getopt.pl
+++ b/gnu/usr.bin/perl/lib/getopt.pl
@@ -24,10 +24,10 @@ sub Getopt {
shift(@ARGV);
$rest = shift(@ARGV);
}
- eval "\$opt_$first = \$rest;";
+ ${"opt_$first"} = $rest;
}
else {
- eval "\$opt_$first = 1;";
+ ${"opt_$first"} = 1;
if ($rest ne '') {
$ARGV[0] = "-$rest";
}
diff --git a/gnu/usr.bin/perl/lib/getopts.pl b/gnu/usr.bin/perl/lib/getopts.pl
index a0818d1e3a0..852aae89b18 100644
--- a/gnu/usr.bin/perl/lib/getopts.pl
+++ b/gnu/usr.bin/perl/lib/getopts.pl
@@ -8,23 +8,22 @@ sub Getopts {
local($argumentative) = @_;
local(@args,$_,$first,$rest);
local($errs) = 0;
- local($[) = 0;
@args = split( / */, $argumentative );
while(@ARGV && ($_ = $ARGV[0]) =~ /^-(.)(.*)/) {
($first,$rest) = ($1,$2);
$pos = index($argumentative,$first);
- if($pos >= $[) {
- if($args[$pos+1] eq ':') {
+ if($pos >= 0) {
+ if($pos < $#args && $args[$pos+1] eq ':') {
shift(@ARGV);
if($rest eq '') {
++$errs unless @ARGV;
$rest = shift(@ARGV);
}
- eval "\$opt_$first = \$rest;";
+ ${"opt_$first"} = $rest;
}
else {
- eval "\$opt_$first = 1";
+ ${"opt_$first"} = 1;
if($rest eq '') {
shift(@ARGV);
}
diff --git a/gnu/usr.bin/perl/lib/importenv.pl b/gnu/usr.bin/perl/lib/importenv.pl
index d56f32633b8..c28ffd054d4 100644
--- a/gnu/usr.bin/perl/lib/importenv.pl
+++ b/gnu/usr.bin/perl/lib/importenv.pl
@@ -8,7 +8,7 @@
local($tmp,$key) = '';
-foreach $key (keys(ENV)) {
+foreach $key (keys(%ENV)) {
$tmp .= "\$$key = \$ENV{'$key'};" if $key =~ /^[A-Za-z]\w*$/;
}
eval $tmp;
diff --git a/gnu/usr.bin/perl/lib/lib.pm b/gnu/usr.bin/perl/lib/lib.pm
index 546ae87b891..4d32f963551 100644
--- a/gnu/usr.bin/perl/lib/lib.pm
+++ b/gnu/usr.bin/perl/lib/lib.pm
@@ -1,20 +1,30 @@
package lib;
+use vars qw(@ORIG_INC);
use Config;
my $archname = $Config{'archname'};
-@ORIG_INC = (); # (avoid typo warning)
@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 ...
+ }
unshift(@INC, $_);
# Put a corresponding archlib directory infront of $_ if it
# looks like $_ has an archlib directory below it.
- unshift(@INC, "$_/$archname") if -d "$_/$archname/auto";
+ if (-d "$_/$archname") {
+ unshift(@INC, "$_/$archname") if -d "$_/$archname/auto";
+ unshift(@INC, "$_/$archname/$]") if -d "$_/$archname/$]/auto";
+ }
}
}
@@ -60,7 +70,6 @@ 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
@@ -80,7 +89,6 @@ 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
@@ -106,7 +114,6 @@ 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
@@ -118,7 +125,7 @@ can say
=head1 SEE ALSO
-AddINC - optional module which deals with paths relative to the source file.
+FindBin - optional module which deals with paths relative to the source file.
=head1 AUTHOR
diff --git a/gnu/usr.bin/perl/lib/locale.pm b/gnu/usr.bin/perl/lib/locale.pm
new file mode 100644
index 00000000000..48213ab86ce
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/lib/look.pl b/gnu/usr.bin/perl/lib/look.pl
index 4c14e64727a..e8dc8aacb6a 100644
--- a/gnu/usr.bin/perl/lib/look.pl
+++ b/gnu/usr.bin/perl/lib/look.pl
@@ -10,7 +10,7 @@ sub look {
$blksize,$blocks) = stat(FH);
$blksize = 8192 unless $blksize;
$key =~ s/[^\w\s]//g if $dict;
- $key =~ y/A-Z/a-z/ if $fold;
+ $key = lc $key if $fold;
$max = int($size / $blksize);
while ($max - $min > 1) {
$mid = int(($max + $min) / 2);
@@ -19,7 +19,7 @@ sub look {
$_ = <FH>;
chop;
s/[^\w\s]//g if $dict;
- y/A-Z/a-z/ if $fold;
+ $_ = lc $_ if $fold;
if ($_ lt $key) {
$min = $mid;
}
@@ -33,7 +33,7 @@ sub look {
while (<FH>) {
chop;
s/[^\w\s]//g if $dict;
- y/A-Z/a-z/ if $fold;
+ $_ = lc $_ if $fold;
last if $_ ge $key;
$min = tell(FH);
}
diff --git a/gnu/usr.bin/perl/lib/newgetopt.pl b/gnu/usr.bin/perl/lib/newgetopt.pl
index 38cad59c73e..0b7eed8bfe9 100644
--- a/gnu/usr.bin/perl/lib/newgetopt.pl
+++ b/gnu/usr.bin/perl/lib/newgetopt.pl
@@ -1,6 +1,6 @@
# newgetopt.pl -- new options parsing.
# Now just a wrapper around the Getopt::Long module.
-# $Id: newgetopt.pl,v 1.15 1995/12/26 14:57:33 jv Exp $
+# $Id: newgetopt.pl,v 1.17 1996-10-02 11:17:16+02 jv Exp $
{ package newgetopt;
@@ -15,12 +15,16 @@
$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.
@@ -45,8 +49,14 @@ sub NGetOpt {
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;
}
diff --git a/gnu/usr.bin/perl/lib/open2.pl b/gnu/usr.bin/perl/lib/open2.pl
index dcd68a8cd3a..8cf08c2e8bd 100644
--- a/gnu/usr.bin/perl/lib/open2.pl
+++ b/gnu/usr.bin/perl/lib/open2.pl
@@ -1,54 +1,12 @@
-# &open2: tom christiansen, <tchrist@convex.com>
+# This is a compatibility interface to IPC::Open2. New programs should
+# do
#
-# usage: $pid = &open2('rdr', 'wtr', 'some cmd and args');
-# or $pid = &open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args');
+# use IPC::Open2;
#
-# 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
-# pipe or fork or exec fails
-
-package open2;
-$fh = 'FHOPEN000'; # package static in case called more than once
-
-sub main'open2 {
- local($kidpid);
- local($dad_rdr, $dad_wtr, @cmd) = @_;
-
- $dad_rdr ne '' || die "open2: rdr should not be null";
- $dad_wtr ne '' || die "open2: wtr should not be null";
-
- # force unqualified filehandles into callers' package
- local($package) = caller;
- $dad_rdr =~ s/^[^']+$/$package'$&/;
- $dad_wtr =~ s/^[^']+$/$package'$&/;
-
- local($kid_rdr) = ++$fh;
- local($kid_wtr) = ++$fh;
-
- pipe($dad_rdr, $kid_wtr) || die "open2: pipe 1 failed: $!";
- pipe($kid_rdr, $dad_wtr) || die "open2: pipe 2 failed: $!";
+# instead of
+#
+# require 'open2.pl';
- if (($kidpid = fork) < 0) {
- die "open2: fork failed: $!";
- } elsif ($kidpid == 0) {
- close $dad_rdr; close $dad_wtr;
- open(STDIN, "<&$kid_rdr");
- open(STDOUT, ">&$kid_wtr");
- warn "execing @cmd\n" if $debug;
- exec @cmd;
- die "open2: exec of @cmd failed";
- }
- close $kid_rdr; close $kid_wtr;
- select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
- $kidpid;
-}
-1; # so require is happy
+package main;
+use IPC::Open2 'open2';
+1
diff --git a/gnu/usr.bin/perl/lib/open3.pl b/gnu/usr.bin/perl/lib/open3.pl
index 7c8b6ae2884..7fcc9318610 100644
--- a/gnu/usr.bin/perl/lib/open3.pl
+++ b/gnu/usr.bin/perl/lib/open3.pl
@@ -1,106 +1,12 @@
-# &open3: Marc Horowitz <marc@mit.edu>
-# derived mostly from &open2 by tom christiansen, <tchrist@convex.com>
+# This is a compatibility interface to IPC::Open3. New programs should
+# do
#
-# $Id: open3.pl,v 1.1 1993/11/23 06:26:15 marc Exp $
+# use IPC::Open3;
#
-# usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...);
+# instead of
#
-# 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 0 on failure.
+# require 'open3.pl';
-
-# 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
-# pipe or fork or exec fails
-
-package open3;
-
-$fh = 'FHOPEN000'; # package static in case called more than once
-
-sub main'open3 {
- local($kidpid);
- local($dad_wtr, $dad_rdr, $dad_err, @cmd) = @_;
- local($dup_wtr, $dup_rdr, $dup_err);
-
- $dad_wtr || die "open3: wtr should not be null";
- $dad_rdr || die "open3: 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
- local($package) = caller;
- $dad_wtr =~ s/^[^']+$/$package'$&/;
- $dad_rdr =~ s/^[^']+$/$package'$&/;
- $dad_err =~ s/^[^']+$/$package'$&/;
-
- local($kid_rdr) = ++$fh;
- local($kid_wtr) = ++$fh;
- local($kid_err) = ++$fh;
-
- if (!$dup_wtr) {
- pipe($kid_rdr, $dad_wtr) || die "open3: pipe 1 (stdin) failed: $!";
- }
- if (!$dup_rdr) {
- pipe($dad_rdr, $kid_wtr) || die "open3: pipe 2 (stdout) failed: $!";
- }
- if ($dad_err ne $dad_rdr && !$dup_err) {
- pipe($dad_err, $kid_err) || die "open3: pipe 3 (stderr) failed: $!";
- }
-
- if (($kidpid = fork) < 0) {
- die "open2: fork failed: $!";
- } elsif ($kidpid == 0) {
- if ($dup_wtr) {
- open(STDIN, ">&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr));
- } else {
- close($dad_wtr);
- open(STDIN, ">&$kid_rdr");
- }
- if ($dup_rdr) {
- open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr));
- } else {
- close($dad_rdr);
- open(STDOUT, ">&$kid_wtr");
- }
- if ($dad_rdr ne $dad_err) {
- if ($dup_err) {
- open(STDERR, ">&$dad_err")
- if (fileno(STDERR) != fileno($dad_err));
- } else {
- close($dad_err);
- open(STDERR, ">&$kid_err");
- }
- } else {
- open(STDERR, ">&STDOUT") if (fileno(STDERR) != fileno(STDOUT));
- }
- local($")=(" ");
- exec @cmd;
- die "open2: exec of @cmd failed";
- }
-
- close $kid_rdr; close $kid_wtr; close $kid_err;
- if ($dup_wtr) {
- close($dad_wtr);
- }
-
- select((select($dad_wtr), $| = 1)[0]); # unbuffer pipe
- $kidpid;
-}
-1; # so require is happy
+package main;
+use IPC::Open3 'open3';
+1
diff --git a/gnu/usr.bin/perl/lib/overload.pm b/gnu/usr.bin/perl/lib/overload.pm
index 54d2cbb4411..c9044db0dc5 100644
--- a/gnu/usr.bin/perl/lib/overload.pm
+++ b/gnu/usr.bin/perl/lib/overload.pm
@@ -1,12 +1,27 @@
package overload;
+sub nil {}
+
sub OVERLOAD {
$package = shift;
my %arg = @_;
- my $hash = \%{$package . "::OVERLOAD"};
+ my ($sub, $fb);
+ $ {$package . "::OVERLOAD"}{dummy}++; # Register with magic by touching.
+ *{$package . "::()"} = \&nil; # Make it findable via fetchmethod.
for (keys %arg) {
- $hash->{$_} = $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 {
@@ -18,44 +33,73 @@ sub import {
sub unimport {
$package = (caller())[0];
- my $hash = \%{$package . "::OVERLOAD"};
+ ${$package . "::OVERLOAD"}{dummy}++; # Upgrade the table
shift;
for (@_) {
- delete $hash->{$_};
+ if ($_ eq 'fallback') {
+ undef $ {$package . "::()"};
+ } else {
+ delete $ {$package . "::"}{"(" . $_};
+ }
}
}
sub Overloaded {
- defined ($package = ref $_[0]) and defined %{$package . "::OVERLOAD"};
+ 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 {
- defined ($package = ref $_[0]) and
- defined %{$package . "::OVERLOAD"} and
- exists $ {$package . "::OVERLOAD"}{'""'} and
- defined &{$ {$package . "::OVERLOAD"}{'""'}};
+ my $package = shift;
+ $package = ref $package if ref $package;
+ #$package->can('(""')
+ ov_method mycan($package, '(""'), $package;
}
sub Method {
- defined ($package = ref $_[0]) and
- defined %{$package . "::OVERLOAD"} and
- $ {$package . "::OVERLOAD"}{$_[1]};
+ 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 {
- $package = ref $_[0];
- bless $_[0], Overload::Fake; # Non-overloaded package
+ my $package = ref $_[0];
+ return "$_[0]" unless $package;
+ bless $_[0], overload::Fake; # Non-overloaded package
my $str = "$_[0]";
bless $_[0], $package; # Back
- $str;
+ $package . substr $str, index $str, '=';
}
sub StrVal {
- (OverloadedStringify) ?
- (AddrRef) :
+ (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;
+}
+
1;
__END__
@@ -105,9 +149,10 @@ 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.
-Legal keys are listed below.
+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
@@ -117,6 +162,10 @@ 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
@@ -186,7 +235,9 @@ arrays, C<cmp> is used to compare values subject to C<use overload>.
"&", "^", "|", "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.
+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>
@@ -201,7 +252,7 @@ postfix form.
"atan2", "cos", "sin", "exp", "abs", "log", "sqrt",
If C<abs> is unavailable, it can be autogenerated using methods
-for "<" or "<=>" combined with either unary minus or subtraction.
+for "E<lt>" or "E<lt>=E<gt>" combined with either unary minus or subtraction.
=item * I<Boolean, string and numeric conversion>
@@ -223,12 +274,46 @@ see L<SPECIAL SYMBOLS FOR C<use overload>>.
See L<"Fallback"> for an explanation of when a missing method can be autogenerated.
+=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
+=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
@@ -275,6 +360,9 @@ 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
@@ -361,6 +449,11 @@ can be expressed in terms of C<$aE<lt>0> and C<-$a> (or C<0-$a>).
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.
@@ -369,7 +462,7 @@ can be expressed in terms of string conversion.
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
@@ -433,31 +526,40 @@ Returns C<undef> or a reference to the method that implements C<op>.
What follows is subject to change RSN.
-The table of methods for all operations is cached as magic in the
-symbol table hash for the package. The table is rechecked for changes due to
-C<use overload>, C<no overload>, and @ISA only during
-C<bless>ing; so if they are changed 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.)
+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 and the current operation is overloadable 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.
+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
@@ -469,19 +571,31 @@ to be changed are constant (but this is not enforced).
=head1 AUTHOR
-Ilya Zakharevich <F<ilya@math.mps.ohio-state.edu>>.
+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).
+
=head1 BUGS
-Because it is used for overloading, the per-package associative array
-%OVERLOAD now has a special meaning in Perl.
+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.
-As shipped, mathemagical properties are not inherited via the @ISA tree.
+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.
This document is confusing.
diff --git a/gnu/usr.bin/perl/lib/perl5db.pl b/gnu/usr.bin/perl/lib/perl5db.pl
index 5c8d2727b72..d5dbfbdd68b 100644
--- a/gnu/usr.bin/perl/lib/perl5db.pl
+++ b/gnu/usr.bin/perl/lib/perl5db.pl
@@ -2,7 +2,8 @@ package DB;
# Debugger for Perl 5.00x; perl5db.pl patch level:
-$header = 'perl5db.pl patch level 0.94';
+$VERSION = 1.01;
+$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
@@ -16,14 +17,35 @@ $header = 'perl5db.pl patch level 0.94';
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
#
-# Perl supplies the values for @line and %sub. It effectively inserts
-# a &DB'DB(<linenum>); in front of every place that can have a
+# 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 this file). In fact the same is
+# (for subroutines defined outside of the package DB). In fact the same is
# true if $deep is not defined.
#
# $Log: perldb.pl,v $
@@ -63,6 +85,65 @@ $header = 'perl5db.pl patch level 0.94';
# 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():
@@ -76,12 +157,11 @@ warn ( # Do not ;-)
$dumpvar::quoteHighBit,
$dumpvar::printUndef,
$dumpvar::globPrint,
- $readline::Tk_toloop,
$dumpvar::usageOnly,
@ARGS,
$Carp::CarpLevel,
$panic,
- $first_time,
+ $second_time,
) if 0;
# Command-line + PERLLIB:
@@ -91,16 +171,14 @@ warn ( # Do not ;-)
$trace = $signal = $single = 0; # Uninitialized warning suppression
# (local $^W cannot help - other packages!).
-@stack = (0);
-
-$option{PrintRet} = 1;
+$inhibit_exit = $option{PrintRet} = 1;
@options = qw(hashDepth arrayDepth DumpDBFiles DumpPackages
compactDump veryCompact quote HighBit undefPrint
- globPrint PrintRet UsageOnly frame
- TTY noTTY ReadLine NonStop LineInfo
- recallCommand ShellBang pager tkRunning
- signalLevel warnLevel dieLevel);
+ globPrint PrintRet UsageOnly frame AutoTrace
+ TTY noTTY ReadLine NonStop LineInfo maxTraceLen
+ recallCommand ShellBang pager tkRunning ornaments
+ signalLevel warnLevel dieLevel inhibit_exit);
%optionVars = (
hashDepth => \$dumpvar::hashDepth,
@@ -110,9 +188,11 @@ $option{PrintRet} = 1;
HighBit => \$dumpvar::quoteHighBit,
undefPrint => \$dumpvar::printUndef,
globPrint => \$dumpvar::globPrint,
- tkRunning => \$readline::Tk_toloop,
UsageOnly => \$dumpvar::usageOnly,
- frame => \$frame,
+ frame => \$frame,
+ AutoTrace => \$trace,
+ inhibit_exit => \$inhibit_exit,
+ maxTraceLen => \$maxtrace,
);
%optionAction = (
@@ -130,6 +210,8 @@ $option{PrintRet} = 1;
signalLevel => \&signalLevel,
warnLevel => \&warnLevel,
dieLevel => \&dieLevel,
+ tkRunning => \&tkRunning,
+ ornaments => \&ornaments,
);
%optionRequire = (
@@ -140,12 +222,19 @@ $option{PrintRet} = 1;
# 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";
@@ -169,9 +258,12 @@ if (exists $ENV{PERLDB_RESTART}) {
delete $ENV{PERLDB_RESTART};
# $restart = 1;
@hist = get_list('PERLDB_HIST');
- my @visited = get_list("PERLDB_VISITED");
- for (0 .. $#visited) {
- %{$postponed{$visited[$_]}} = get_list("PERLDB_FILE_$_");
+ %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);
@@ -181,6 +273,10 @@ if (exists $ENV{PERLDB_RESTART}) {
}
@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) {
@@ -194,14 +290,18 @@ if ($notty) {
if (-e "/dev/tty") {
$console = "/dev/tty";
- } elsif (-e "con") {
+ } elsif (-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) { # In OS/2
+ if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
$console = undef;
}
@@ -249,41 +349,28 @@ if (defined &afterinit) { # May be defined in $rcfile
&afterinit();
}
+$I_m_init = 1;
+
############################################################ Subroutines
sub DB {
- unless ($first_time++) { # Do when-running init
- if ($runnonstop) { # Disable until signal
+ # _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;
+ # return; # Would not print trace!
}
- # Define a subroutine in which we will stop
-# eval <<'EOE';
-# sub at_end::db {"Debuggee terminating";}
-# END {
-# $DB::step = 1;
-# print $OUT "Debuggee terminating.\n";
-# &at_end::db;}
-# EOE
}
+ $runnonstop = 0 if $single or $signal; # Disable it if interactive.
&save;
- if ($doret) {
- $doret = 0;
- if ($option{PrintRet}) {
- print $OUT "$retctx context return from $lastsub:",
- ($retctx eq 'list') ? "\n" : " " ;
- dumpit( ($retctx eq 'list') ? \@ret : $ret );
- }
- }
($package, $filename, $line) = caller;
$filename_ini = $filename;
$usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
"package $package;"; # this won't let them modify, alas
- local(*dbline) = "::_<$filename";
- install_breakpoints($filename) unless $visited{$filename}++;
+ local(*dbline) = $main::{'_<' . $filename};
$max = $#dbline;
if (($stop,$action) = split(/\0/,$dbline{$line})) {
if ($stop eq '1') {
@@ -293,7 +380,9 @@ sub DB {
$dbline{$line} =~ s/;9($|\0)/$1/;
}
}
- if ($single || $trace || $signal) {
+ my $was_signal = $signal;
+ $signal = 0;
+ if ($single || $trace || $was_signal) {
$term || &setterm;
if ($emacs) {
$position = "\032\032$filename:$line:0\n";
@@ -305,48 +394,60 @@ sub DB {
$after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
if (length($prefix) > 30) {
$position = "$prefix$line):\n$line:\t$dbline[$line]$after";
- print $LINEINFO $position;
$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";
- print $LINEINFO $incr_pos;
$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 || $signal) {
+ if ($single || $was_signal) {
local $level = $level + 1;
- $evalarg = $pre, &eval if $pre;
+ 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) .
" "))) {
- #{ # <-- Do we know what this brace is for?
$single = 0;
$signal = 0;
$cmd =~ s/\\$/\n/ && do {
$cmd .= &readline(" cont: ");
redo CMD;
};
- $cmd =~ /^q$/ && exit 0;
$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 $OUT $help;
next CMD; };
@@ -355,8 +456,10 @@ sub DB {
next CMD; };
$cmd =~ /^h\s+(\S)$/ && do {
my $asked = "\Q$1";
- if ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/m) {
+ if ($help =~ /^$asked/m) {
+ while ($help =~ /^($asked([\s\S]*?)\n)(\Z|[^\s$asked])/mg) {
print $OUT $1;
+ }
} else {
print $OUT "`$asked' is not a debugger command.\n";
}
@@ -373,6 +476,8 @@ sub DB {
}
}
next CMD; };
+ $cmd =~ /^v$/ && do {
+ list_versions(); next CMD};
$cmd =~ s/^X\b/V $package/;
$cmd =~ /^V$/ && do {
$cmd = "V $package"; };
@@ -383,6 +488,7 @@ sub DB {
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";
@@ -390,9 +496,14 @@ sub DB {
select ($savout);
next CMD; };
$cmd =~ s/^x\b/ / && do { # So that will be evaled
- $onetimeDump = 1; };
+ $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";
@@ -400,32 +511,37 @@ sub DB {
}
if (!defined $main::{'_<' . $file}) {
if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
- $file = substr($try,2);
- print "\n$file:\n";
+ $try = substr($try,2);
+ print $OUT "Choosing $try matching `$file':\n";
+ $file = $try;
}}
}
if (!defined $main::{'_<' . $file}) {
- print $OUT "There's no code here matching $file.\n";
+ print $OUT "No file matching `$file' is loaded.\n";
next CMD;
} elsif ($file ne $filename) {
- *dbline = "::_<$file";
- $visited{$file}++;
+ *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 = "main::".$subname unless $subname =~ /::/;
+ $subname = $package."::".$subname
+ unless $subname =~ /::/;
$subname = "main".$subname if substr($subname,0,2) eq "::";
- @pieces = split(/:/,$sub{$subname});
+ @pieces = split(/:/,find_sub($subname));
$subrange = pop @pieces;
$file = join(':', @pieces);
if ($file ne $filename) {
- *dbline = "::_<$file";
- $visited{$file}++;
+ *dbline = $main::{'_<' . $file};
$max = $#dbline;
$filename = $file;
}
@@ -439,9 +555,10 @@ sub DB {
next CMD;
} };
$cmd =~ /^\.$/ && do {
+ $incr = -1; # for backward motion.
$start = $line;
$filename = $filename_ini;
- *dbline = "::_<$filename";
+ *dbline = $main::{'_<' . $filename};
$max = $#dbline;
print $LINEINFO $position;
next CMD };
@@ -452,8 +569,10 @@ sub DB {
#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-$window*2) . '+'; };
+ $cmd = 'l ' . ($start) . '+'; };
$cmd =~ /^l$/ && do {
$incr = $window - 1;
$cmd = 'l ' . $start . '-' . ($start + $incr); };
@@ -468,6 +587,7 @@ sub DB {
$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;
@@ -477,7 +597,7 @@ sub DB {
$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];
@@ -488,7 +608,13 @@ sub DB {
$start = $max if $start > $max;
next CMD; };
$cmd =~ /^D$/ && do {
- print $OUT "Deleting all breakpoints...\n";
+ 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]+//;
@@ -497,19 +623,89 @@ sub DB {
}
}
}
- next CMD; };
+ }
+ 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 $OUT "$i:\t", $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"
+ print $OUT " break if (", $stop, ")\n"
if $stop;
- print $OUT " action: ", $action, "\n"
+ 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;
+ }
+ }
+ 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;
@@ -519,12 +715,12 @@ sub DB {
unless $subname =~ /::/;
$subname = "main".$subname if substr($subname,0,2) eq "::";
# Filename below can contain ':'
- ($file,$i) = ($sub{$subname} =~ /^(.*):(.*)$/);
+ ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
$i += 0;
if ($i) {
$filename = $file;
- *dbline = "::_<$filename";
- $visited{$filename}++;
+ *dbline = $main::{'_<' . $filename};
+ $had_breakpoints{$filename} = 1;
$max = $#dbline;
++$i while $dbline[$i] == 0 && $i < $max;
$dbline{$i} =~ s/^[^\0]*/$cond/;
@@ -538,6 +734,7 @@ sub DB {
if ($dbline[$i] == 0) {
print $OUT "Line $i not breakable.\n";
} else {
+ $had_breakpoints{$filename} = 1;
$dbline{$i} =~ s/^[^\0]*/$cond/;
}
next CMD; };
@@ -547,13 +744,20 @@ sub DB {
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; };
+ }
+ next CMD; };
$cmd =~ /^O\s*$/ && do {
for (@options) {
&dump_option($_);
@@ -562,11 +766,26 @@ sub DB {
$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 = action($1);
+ $pre = [], next CMD unless $1;
+ $pre = [action($1)];
next CMD; };
$cmd =~ /^>\s*(.*)/ && do {
- $post = action($1);
+ $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;
@@ -578,22 +797,27 @@ sub DB {
}
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 {
- $i = $1;
+ end_report(), next CMD if $finished and $level <= 1;
+ $subname = $i = $1;
if ($i =~ /\D/) { # subroutine name
- ($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/);
+ $subname = $package."::".$subname
+ unless $subname =~ /::/;
+ ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
$i += 0;
if ($i) {
$filename = $file;
- *dbline = "::_<$filename";
- $visited{$filename}++;
+ *dbline = $main::{'_<' . $filename};
+ $had_breakpoints{$filename}++;
$max = $#dbline;
++$i while $dbline[$i] == 0 && $i < $max;
} else {
@@ -613,11 +837,12 @@ sub DB {
}
last CMD; };
$cmd =~ /^r$/ && do {
+ end_report(), next CMD if $finished and $level <= 1;
$stack[$#stack] |= 1;
- $doret = 1;
+ $doret = $option{PrintRet} ? $#stack - 1 : -2;
last CMD; };
$cmd =~ /^R$/ && do {
- print $OUT "Warning: a lot of settings and command-line options may be lost!\n";
+ 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
@@ -638,52 +863,67 @@ sub DB {
set_list("PERLDB_HIST",
$term->Features->{getHistory}
? $term->GetHistory : @hist);
- my @visited = keys %visited;
- set_list("PERLDB_VISITED", @visited);
+ my @had_breakpoints = keys %had_breakpoints;
+ set_list("PERLDB_VISITED", @had_breakpoints);
set_list("PERLDB_OPT", %option);
- for (0 .. $#visited) {
- *dbline = "::_<$visited[$_]";
- set_list("PERLDB_FILE_$_", %dbline);
+ 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 {
- local($p,$f,$l,$s,$h,$a,$e,$r,@a,@sub);
- 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';
- push(@sub, "$w$s$a called from $f line $l\n");
- last if $signal;
- }
- for ($i=0; $i <= $#sub; $i++) {
- last if $signal;
- print $OUT $sub[$i];
- }
+ print_trace($OUT, 1); # skip DB
next CMD; };
$cmd =~ /^\/(.*)$/ && do {
$inpat = $1;
@@ -697,6 +937,7 @@ sub DB {
$pat = $inpat;
}
$end = $start;
+ $incr = -1;
eval '
for (;;) {
++$start;
@@ -725,6 +966,7 @@ sub DB {
$pat = $inpat;
}
$end = $start;
+ $incr = -1;
eval '
for (;;) {
--$start;
@@ -747,8 +989,8 @@ sub DB {
$cmd = $hist[$i] . "\n";
print $OUT $cmd;
redo CMD; };
- $cmd =~ /^$sh$sh\s*/ && do {
- &system($');
+ $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
+ &system($1);
next CMD; };
$cmd =~ /^$rc([^$rc].*)$/ && do {
$pat = "^$1";
@@ -766,8 +1008,8 @@ sub DB {
$cmd =~ /^$sh$/ && do {
&system($ENV{SHELL}||"/bin/sh");
next CMD; };
- $cmd =~ /^$sh\s*/ && do {
- &system($ENV{SHELL}||"/bin/sh","-c",$');
+ $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;
@@ -777,8 +1019,8 @@ sub DB {
unless $hist[$i] =~ /^.?$/;
};
next CMD; };
- $cmd =~ s/^p$/print \$DB::OUT \$_/;
- $cmd =~ s/^p\b/print \$DB::OUT /;
+ $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~";
@@ -812,7 +1054,7 @@ sub DB {
}
next CMD;
}
- $SIG{PIPE}= "DB::catch" if $pager =~ /^\|/
+ $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
&& "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE};
$selected= select(OUT);
$|= 1;
@@ -824,11 +1066,10 @@ sub DB {
$cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
$cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
} # PIPE:
- #} # <-- Do we know what this brace is for?
$evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
if ($onetimeDump) {
$onetimeDump = undef;
- } else {
+ } elsif ($term_pid == $$) {
print $OUT "\n";
}
} continue { # CMD:
@@ -841,7 +1082,7 @@ sub DB {
( $? & 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";
+ $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 {
@@ -852,8 +1093,9 @@ sub DB {
$piped= "";
}
} # CMD:
- if ($post) {
- $evalarg = $post; &eval;
+ $exiting = 1 unless defined $cmd;
+ foreach $evalarg (@$post) {
+ &eval;
}
} # if ($single || $signal)
($@, $!, $,, $/, $\, $^W) = @saved;
@@ -864,23 +1106,43 @@ sub DB {
# BEGIN {warn 4}
sub sub {
- print $LINEINFO ' ' x $#stack, "entering $sub\n" if $frame;
+ 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);
- $retctx = "list";
- $lastsub = $sub;
-print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
+ ($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;
+ print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
+ "list context return from $sub:\n"), dumpit( \@ret ),
+ $doret = -2 if $doret eq $#stack or $frame & 16;
@ret;
} else {
- $ret = &$sub;
+ if (defined wantarray) {
+ $ret = &$sub;
+ } else {
+ &$sub; undef $ret;
+ };
$single |= pop(@stack);
- $retctx = "scalar";
- $lastsub = $sub;
-print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
+ ($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;
+ print ($OUT ($frame & 16 ? ' ' x $#stack : ""),
+ "scalar context return from $sub: "), dumpit( $ret ),
+ $doret = -2 if $doret eq $#stack or $frame & 16;
$ret;
}
}
@@ -905,38 +1167,161 @@ sub eval {
$^D = $od;
}
my $at = $@;
+ local $saved[0]; # Preserve the old value of $@
eval "&DB::save";
if ($at) {
print $OUT $at;
- } elsif ($onetimeDump) {
+ } elsif ($onetimeDump eq 'dump') {
dumpit(\@res);
+ } elsif ($onetimeDump eq 'methods') {
+ methods($res[0]);
}
}
-sub install_breakpoints {
- my $filename = shift;
- return unless exists $postponed{$filename};
- my %break = %{$postponed{$filename}};
- for (keys %break) {
- my $i = $_;
- #if (/\D/) { # Subroutine name
- #}
- $dbline{$i} = $break{$_}; # Cannot be done before the file is around
+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 {
+ 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($OUT);
- do 'dumpvar.pl' unless defined &main::dumpValue;
+ 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) {
- local $frame = 0;
&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 ? '@' : "\$";
+ $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/\\$//) {
@@ -972,7 +1357,9 @@ sub system {
sub setterm {
local $frame = 0;
- eval "require Term::ReadLine;" or die $@;
+ 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: $!";
@@ -995,9 +1382,13 @@ sub setterm {
} else {
$term = new Term::ReadLine 'perldb', $IN, $OUT;
- $readline::rl_basic_word_break_characters .= "[:"
- if defined $readline::rl_basic_word_break_characters
- and index($readline::rl_basic_word_break_characters, ":") == -1;
+ $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;
@@ -1005,6 +1396,30 @@ sub setterm {
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 $OUT "Forked, but do not know how to change a TTY.\n",
+ "Define \$DB::fork_TTY or get_fork_TTY().\n";
+ }
}
sub readline {
@@ -1017,11 +1432,20 @@ sub readline {
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}};
@@ -1032,12 +1456,11 @@ sub dump_option {
and not defined $option{$opt}
or defined $optionVars{$opt}
and not defined $ {$optionVars{$opt}}) {
- $val = 'N/A';
+ $val = $default;
} else {
$val = $option{$opt};
}
- $val =~ s/[\\\']/\\$&/g;
- printf $OUT "%20s = '%s'\n", $opt, $val;
+ $val
}
sub parse_options {
@@ -1070,7 +1493,8 @@ sub parse_options {
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; require '$optionRequire{$option}'"
+ 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
@@ -1091,7 +1515,7 @@ sub set_list {
for $i (0 .. $#list) {
$val = $list[$i];
$val =~ s/\\/\\\\/g;
- $val =~ s/[\0-\37\177\200-\377]/"\\0x" . unpack('H2',$&)/eg;
+ $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
$ENV{"$ {stem}_$i"} = $val;
}
}
@@ -1111,6 +1535,7 @@ sub get_list {
sub catch {
$signal = 1;
+ return; # Put nothing on the stack - malloc/free land!
}
sub warn {
@@ -1120,38 +1545,56 @@ sub warn {
}
sub TTY {
- if ($term) {
- &warn("Too late to set TTY!\n") if @_;
- } else {
- $tty = shift if @_;
- }
+ 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!\n") if @_;
- } else {
- $notty = shift if @_;
+ &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!\n") if @_;
- } else {
- $rl = shift if @_;
+ &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!\n") if @_;
- } else {
- $runnonstop = shift if @_;
+ &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
}
+ $runnonstop = shift if @_;
$runnonstop;
}
@@ -1175,6 +1618,16 @@ sub shellBang {
$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;
@@ -1200,6 +1653,29 @@ sub LineInfo {
$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 = "
T Stack trace.
@@ -1207,8 +1683,8 @@ s [expr] Single step [in expr].
n [expr] Next, steps over subroutine calls [in expr].
<CR> Repeat last n or s command.
r Return from current subroutine.
-c [line] Continue; optionally inserts a one-time-only breakpoint
- at the specified line.
+c [line|sub] Continue; optionally inserts a one-time-only breakpoint
+ at the specified position.
l min+incr List incr+1 lines starting at min.
l min-max List lines min through max.
l line List single line.
@@ -1217,10 +1693,10 @@ l List next window of lines.
- List previous window of lines.
w [line] List window around line.
. Return to the executed line.
-f filename Switch to viewing filename.
+f filename Switch to viewing filename. Must be loaded.
/pattern/ Search forwards for pattern; final / is optional.
?pattern? Search backwards for pattern; final ? is optional.
-L List all breakpoints and actions for the current file.
+L List all breakpoints and actions.
S [[!]pattern] List subroutine names [not] matching pattern.
t Toggle trace mode.
t expr Trace through execution of expr.
@@ -1229,6 +1705,12 @@ b [line] [condition]
condition breaks if it evaluates to true, defaults to '1'.
b subname [condition]
Set breakpoint at first line of subroutine.
+b load filename Set breakpoint on `require'ing the given file.
+b postpone subname [condition]
+ Set breakpoint at first line of subroutine after
+ it is compiled.
+b compile subname
+ Stop after the subroutine is compiled.
d [line] Delete the breakpoint for line.
D Delete all breakpoints.
a [line] command
@@ -1240,11 +1722,17 @@ V [pkg [vars]] List some (default all) variables in package (default current).
Use ~pattern and !pattern for positive and negative regexps.
X [vars] Same as \"V currentpackage [vars]\".
x expr Evals expression in array context, dumps the result.
+m expr Evals expression in array context, prints methods callable
+ on the first element of the result.
+m class Prints methods callable via the given class.
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.
recallCommand, ShellBang: chars used to recall command or spawn shell;
pager: program for output of \"|cmd\";
+ tkRunning: run Tk while prompting (with ReadLine);
+ signalLevel warnLevel dieLevel: level of verbosity;
+ inhibit_exit Allows stepping off the end of the script.
The following options affect what happens with V, X, and x commands:
arrayDepth, hashDepth: print only first N elements ('' for all);
compactDump, veryCompact: change style of array and hash dump;
@@ -1252,15 +1740,20 @@ O [opt[=val]] [opt\"val\"] [opt?]...
DumpDBFiles: dump arrays holding debugged files;
DumpPackages: dump symbol tables of packages;
quote, HighBit, undefPrint: change style of string dump;
- tkRunning: run Tk while prompting (with ReadLine);
- signalLevel warnLevel dieLevel: level of verbosity;
Option PrintRet affects printing of return value after r command,
frame affects printing messages on entry and exit from subroutines.
+ AutoTrace affects printing messages on every possible breaking point.
+ maxTraceLen gives maximal length of evals/args listed in stack trace.
+ ornaments affects screen appearance of the command line.
During startup options are initialized from \$ENV{PERLDB_OPTS}.
You can put additional initialization options TTY, noTTY,
- ReadLine, and NonStop there.
-< command Define command to run before each prompt.
-> command Define command to run after each prompt.
+ ReadLine, and NonStop there (or use `R' after you set them).
+< command Define Perl command to run before each prompt.
+<< command Add to the list of Perl commands to run before each prompt.
+> command Define Perl command to run after each prompt.
+>> command Add to the list of Perl commands to run after each prompt.
+\{ commandline Define debugger command to run before each prompt.
+\{{ commandline Add to the list of debugger commands to run before each prompt.
$prc number Redo a previous command (default previous command).
$prc -number Redo number'th-to-last command.
$prc pattern Redo last command that started with pattern.
@@ -1270,16 +1763,20 @@ $psh$psh cmd Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
$psh [cmd] Run cmd in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
See 'O shellBang' too.
H -number Display last number commands (default all).
-p expr Same as \"print DB::OUT expr\" in current package.
+p expr Same as \"print {DB::OUT} expr\" in current package.
|dbcmd Run debugger command, piping DB::OUT to current pager.
||dbcmd Same as |dbcmd but DB::OUT is temporarilly select()ed as well.
\= [alias value] Define a command alias, or list current aliases.
command Execute as a perl statement in current package.
-R Pure-man-restart of debugger, debugger state and command-line
- options are lost.
+v Show versions of loaded modules.
+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 Options
+ and the following command-line options: -w, -I, -e.
h [db_command] Get help [on a specific debugger command], enter |h to page.
h h Summary of debugger commands.
-q or ^D Quit.
+q or ^D Quit. Set \$DB::finished to 0 to debug global destruction.
";
$summary = <<"END_SUM";
@@ -1288,12 +1785,12 @@ List/search source lines: Control script execution:
- or . List previous/current line s [expr] Single step [in expr]
w [line] List around line n [expr] Next, steps over subs
f filename View source in file <CR> Repeat last n or s
- /pattern/ Search forward r Return from subroutine
- ?pattern? Search backward c [line] Continue until line
+ /pattern/ ?patt? Search forw/backw r Return from subroutine
+ v Show versions of modules c [ln|sub] Continue until position
Debugger controls: L List break pts & actions
O [...] Set debugger options t [expr] Toggle trace [trace expr]
- < command Command for before prompt b [ln] [c] Set breakpoint
- > command Command for after prompt b sub [c] Set breakpoint for sub
+ <[<] or {[{] [cmd] Do before prompt b [ln/event] [c] Set breakpoint
+ >[>] [cmd] Do after prompt b sub [c] Set breakpoint for sub
$prc [N|pat] Redo a previous command d [line] Delete a breakpoint
H [-num] Display last num commands D Delete all breakpoints
= [a val] Define/list an alias a [ln] cmd Do cmd before line
@@ -1301,66 +1798,71 @@ Debugger controls: L List break pts & actions
|[|]dbcmd Send output to pager $psh\[$psh\] syscmd Run cmd in a subprocess
q or ^D Quit R Attempt a restart
Data Examination: expr Execute perl code, also see: s,n,t expr
+ x|m expr Evals expr in array context, dumps the result or lists methods.
+ p expr Print expression (uses script's current package).
S [[!]pat] List subroutine names [not] matching pattern
V [Pk [Vars]] List Variables in Package. Vars can be ~pattern or !pattern.
X [Vars] Same as \"V current_package [Vars]\".
- x expr Evals expression in array context, dumps the result.
- p expr Print expression (uses script's current package).
END_SUM
- # '); # Fix balance of Emacs parsing
+ # ')}}; # Fix balance of Emacs parsing
}
sub diesignal {
local $frame = 0;
- $SIG{'ABRT'} = DEFAULT;
+ local $doret = -2;
+ $SIG{'ABRT'} = 'DEFAULT';
kill 'ABRT', $$ if $panic++;
- print $DB::OUT "Got $_[0]!\n"; # in the case cannot continue
- local $SIG{__WARN__} = '';
- require Carp;
- local $Carp::CarpLevel = 2; # mydie + confess
- &warn(Carp::longmess("Signal @_"));
+ 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__} = '';
- require Carp;
- #&warn("Entering dbwarn\n");
+ 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("Warning in dbwarn\n");
&warn($mess);
- #&warn("Exiting dbwarn\n");
}
sub dbdie {
local $frame = 0;
+ local $doret = -2;
local $SIG{__DIE__} = '';
local $SIG{__WARN__} = '';
my $i = 0; my $ineval = 0; my $sub;
- #&warn("Entering dbdie\n");
- if ($dieLevel != 2) {
- while ((undef,undef,undef,$sub) = caller(++$i)) {
- $ineval = 1, last if $sub eq '(eval)';
- }
- {
+ if ($dieLevel > 2) {
local $SIG{__WARN__} = \&dbwarn;
- &warn(@_) if $dieLevel > 2; # Ineval is false during destruction?
- }
- #&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
- die @_ if $ineval and $dieLevel < 2;
+ &warn(@_); # Yell no matter what
+ return;
}
- require Carp;
+ 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);
- #&warn("dieing loudly in dbdie\n");
die $mess;
}
@@ -1369,7 +1871,7 @@ sub warnLevel {
$prevwarn = $SIG{__WARN__} unless $warnLevel;
$warnLevel = shift;
if ($warnLevel) {
- $SIG{__WARN__} = 'DB::dbwarn';
+ $SIG{__WARN__} = \&DB::dbwarn;
} else {
$SIG{__WARN__} = $prevwarn;
}
@@ -1382,10 +1884,11 @@ sub dieLevel {
$prevdie = $SIG{__DIE__} unless $dieLevel;
$dieLevel = shift;
if ($dieLevel) {
- $SIG{__DIE__} = 'DB::dbdie'; # if $dieLevel < 2;
- #$SIG{__DIE__} = 'DB::diehard' if $dieLevel >= 2;
+ $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";
+ ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
+ if $I_m_init;
print $OUT "Dump printed too.\n" if $dieLevel > 2;
} else {
$SIG{__DIE__} = $prevdie;
@@ -1401,8 +1904,8 @@ sub signalLevel {
$prevbus = $SIG{BUS} unless $signalLevel;
$signalLevel = shift;
if ($signalLevel) {
- $SIG{SEGV} = 'DB::diesignal';
- $SIG{BUS} = 'DB::diesignal';
+ $SIG{SEGV} = \&DB::diesignal;
+ $SIG{BUS} = \&DB::diesignal;
} else {
$SIG{SEGV} = $prevsegv;
$SIG{BUS} = $prevbus;
@@ -1411,6 +1914,46 @@ sub signalLevel {
$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.
@@ -1423,24 +1966,123 @@ BEGIN { # This does not compile, alas.
$window = 10;
$preview = 3;
$sub = '';
- #$SIG{__WARN__} = "DB::dbwarn";
- #$SIG{__DIE__} = 'DB::dbdie';
- #$SIG{SEGV} = "DB::diesignal";
- #$SIG{BUS} = "DB::diesignal";
- $SIG{INT} = "DB::catch";
- #$SIG{FPE} = "DB::catch";
- #warn "SIGFPE installed";
- $warnLevel = 1 unless defined $warnLevel;
- $dieLevel = 1 unless defined $dieLevel;
- $signalLevel = 1 unless defined $signalLevel;
+ $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/gnu/usr.bin/perl/lib/sigtrap.pm b/gnu/usr.bin/perl/lib/sigtrap.pm
index e099ac46581..c081123b6b4 100644
--- a/gnu/usr.bin/perl/lib/sigtrap.pm
+++ b/gnu/usr.bin/perl/lib/sigtrap.pm
@@ -2,38 +2,84 @@ package sigtrap;
=head1 NAME
-sigtrap - Perl pragma to enable stack backtrace on unexpected signals
-
-=head1 SYNOPSIS
-
- use sigtrap;
- use sigtrap qw(BUS SEGV PIPE SYS ABRT TRAP);
-
-=head1 DESCRIPTION
-
-The C<sigtrap> pragma initializes some default signal handlers that print
-a stack dump of your Perl program, then sends itself a SIGABRT. This
-provides a nice starting point if something horrible goes wrong.
-
-By default, handlers are installed for the ABRT, BUS, EMT, FPE, ILL, PIPE,
-QUIT, SEGV, SYS, TERM, and TRAP signals.
-
-See L<perlmod/Pragmatic Modules>.
+sigtrap - Perl pragma to enable simple signal handling
=cut
-require Carp;
+use Carp;
+
+$VERSION = 1.02;
+$Verbose ||= 0;
sub import {
- my $pack = shift;
- my @sigs = @_;
- @sigs or @sigs = qw(QUIT ILL TRAP ABRT EMT FPE BUS SEGV SYS PIPE TERM);
- foreach $sig (@sigs) {
- $SIG{$sig} = 'sigtrap::trap';
+ 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 trap {
+sub handler_die {
+ croak "Caught a SIG$_[0]";
+}
+
+sub handler_traceback {
package DB; # To get subroutine args.
$SIG{'ABRT'} = DEFAULT;
kill 'ABRT', $$ if $panic++;
@@ -77,3 +123,167 @@ sub trap {
}
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/gnu/usr.bin/perl/lib/splain b/gnu/usr.bin/perl/lib/splain
deleted file mode 100644
index f40c51e0308..00000000000
--- a/gnu/usr.bin/perl/lib/splain
+++ /dev/null
@@ -1,503 +0,0 @@
-#!/usr/local/bin/perl
-eval 'exec perl -S $0 ${1+"$@"}'
- if 0;
-
-use Config;
-$diagnostics::PODFILE= $Config{privlib} . "/pod/perldiag.pod";
-
-package diagnostics;
-require 5.001;
-use English;
-use Carp;
-
-=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 wtih the more
-explicative and endearing descriptions found in L<perldiag>. Like the
-other pragmata, it affects to 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 can generate nicer escape
-sequences for pgers.
-
-=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 theorectical
-
- (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 diagnostic::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 to 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 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<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995.
-
-=cut
-
-$DEBUG ||= 0;
-my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
-
-$OUTPUT_AUTOFLUSH = 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:') || 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;
- }
- $header = $1;
-
- 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;
- }
- $transmo .= " s{^$lhs}\n {\Q$rhs\E}\n\t&& return 1;\n";
- } else {
- $transmo .= " m{^\Q$header\E} && return 1;\n";
- }
-
- print STDERR "Already saw $header" 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 ($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];
- splainthis($exception);
- if (caller eq $WHOAMI) { print STDERR "INTERNAL EXCEPTION: $exception"; }
- &$olddie if defined $olddie and $olddie and $olddie ne \&death_trap;
- $SIG{__DIE__} = $SIG{__WARN__} = '';
- 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;
- ### &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: $& in $_";
- "E<$1>";
- }
- }
- }egx;
-}
-
-sub shorten {
- my $line = $_[0];
- if (length $line > 79) {
- 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/gnu/usr.bin/perl/lib/strict.pm b/gnu/usr.bin/perl/lib/strict.pm
index 6f6028cad4e..8492e933fd6 100644
--- a/gnu/usr.bin/perl/lib/strict.pm
+++ b/gnu/usr.bin/perl/lib/strict.pm
@@ -55,7 +55,7 @@ name without fully qualifying it.
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 "=>" symbol.
+appears in curly braces or on the left hand side of the "=E<gt>" symbol.
use strict 'subs';
@@ -74,10 +74,11 @@ See L<perlmod/Pragmatic Modules>.
sub bits {
my $bits = 0;
+ my $sememe;
foreach $sememe (@_) {
- $bits |= 0x00000002 if $sememe eq 'refs';
- $bits |= 0x00000200 if $sememe eq 'subs';
- $bits |= 0x00000400 if $sememe eq 'vars';
+ $bits |= 0x00000002, next if $sememe eq 'refs';
+ $bits |= 0x00000200, next if $sememe eq 'subs';
+ $bits |= 0x00000400, next if $sememe eq 'vars';
}
$bits;
}
diff --git a/gnu/usr.bin/perl/lib/subs.pm b/gnu/usr.bin/perl/lib/subs.pm
index 84c913a346a..512bc9be9a5 100644
--- a/gnu/usr.bin/perl/lib/subs.pm
+++ b/gnu/usr.bin/perl/lib/subs.pm
@@ -15,9 +15,15 @@ This will predeclare all the subroutine whose names are
in the list, allowing you to use them without parentheses
even before they're declared.
-See L<perlmod/Pragmatic Modules> and L<strict/subs>.
+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<perlmod/Pragmatic Modules> and L<strict/strict subs>.
=cut
+
require 5.000;
sub import {
diff --git a/gnu/usr.bin/perl/lib/syslog.pl b/gnu/usr.bin/perl/lib/syslog.pl
index 29c3a1cc9af..9e03399e4df 100644
--- a/gnu/usr.bin/perl/lib/syslog.pl
+++ b/gnu/usr.bin/perl/lib/syslog.pl
@@ -37,7 +37,7 @@ if ($] >= 5) {
require 'syslog.ph';
- eval 'use Socket' ||
+ eval 'use Socket; 1' ||
eval { require "socket.ph" } ||
require "sys/socket.ph";
@@ -140,10 +140,10 @@ sub main'syslog {
sub xlate {
local($name) = @_;
- $name =~ y/a-z/A-Z/;
+ $name = uc $name;
$name = "LOG_$name" unless $name =~ /^LOG_/;
$name = "syslog'$name";
- eval(&$name) || -1;
+ defined &$name ? &$name : -1;
}
sub connect {
diff --git a/gnu/usr.bin/perl/lib/termcap.pl b/gnu/usr.bin/perl/lib/termcap.pl
index e8f108df067..37313432fde 100644
--- a/gnu/usr.bin/perl/lib/termcap.pl
+++ b/gnu/usr.bin/perl/lib/termcap.pl
@@ -14,7 +14,7 @@ sub Tgetent {
local($TERMCAP,$_,$entry,$loop,$field);
warn "Tgetent: no ospeed set" unless $ospeed;
- foreach $key (keys(TC)) {
+ foreach $key (keys %TC) {
delete $TC{$key};
}
$TERM = $ENV{'TERM'} unless $TERM;
@@ -63,6 +63,9 @@ sub Tgetent {
$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;
diff --git a/gnu/usr.bin/perl/lib/timelocal.pl b/gnu/usr.bin/perl/lib/timelocal.pl
index 75f1ac1851a..ad322756e38 100644
--- a/gnu/usr.bin/perl/lib/timelocal.pl
+++ b/gnu/usr.bin/perl/lib/timelocal.pl
@@ -4,106 +4,15 @@
;# $time = timelocal($sec,$min,$hours,$mday,$mon,$year);
;# $time = timegm($sec,$min,$hours,$mday,$mon,$year);
-;# 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.
+;# 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.
-;# 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.
+;# 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.
-;# Both routines return -1 if the integer limit is hit. I.e. for dates
-;# after the 1st of January, 2038 on most machines.
+use Time::Local;
-CONFIG: {
- package timelocal;
-
- local($[) = 0;
- @epoch = localtime(0);
- $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT
- if ($tzmin > 0) {
- $tzmin = 24 * 60 - $tzmin; # minutes west of GMT
- $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line
- }
-
- $SEC = 1;
- $MIN = 60 * $SEC;
- $HR = 60 * $MIN;
- $DAYS = 24 * $HR;
- $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0;
- 1;
-}
-
-sub timegm {
- package timelocal;
-
- local($[) = 0;
- $ym = pack(C2, @_[5,4]);
- $cheat = $cheat{$ym} || &cheat;
- return -1 if $cheat<0;
- $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS;
-}
-
-sub timelocal {
- package timelocal;
-
- local($[) = 0;
- $time = &main'timegm + $tzmin*$MIN;
- return -1 if $cheat<0;
- @test = localtime($time);
- $time -= $HR if $test[2] != $_[2];
- $time;
-}
-
-package timelocal;
-
-sub cheat {
- $year = $_[5];
- $month = $_[4];
- die "Month out of range 0..11 in timelocal.pl\n"
- if $month > 11 || $month < 0;
- die "Day out of range 1..31 in timelocal.pl\n"
- if $_[3] > 31 || $_[3] < 1;
- die "Hour out of range 0..23 in timelocal.pl\n"
- if $_[2] > 23 || $_[2] < 0;
- die "Minute out of range 0..59 in timelocal.pl\n"
- if $_[1] > 59 || $_[1] < 0;
- die "Second out of range 0..59 in timelocal.pl\n"
- if $_[0] > 59 || $_[0] < 0;
- $guess = $^T;
- @g = gmtime($guess);
- $year += $YearFix if $year < $epoch[5];
- $lastguess = "";
- while ($diff = $year - $g[5]) {
- $guess += $diff * (363 * $DAYS);
- @g = gmtime($guess);
- if (($thisguess = "@g") eq $lastguess){
- return -1; #date beyond this machine's integer limit
- }
- $lastguess = $thisguess;
- }
- while ($diff = $month - $g[4]) {
- $guess += $diff * (27 * $DAYS);
- @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] * $DAYS;
- $cheat{$ym} = $guess;
-}
+*timelocal::cheat = \&Time::Local::cheat;
diff --git a/gnu/usr.bin/perl/lib/validate.pl b/gnu/usr.bin/perl/lib/validate.pl
index 21d0505ad4d..ec4a04b5436 100644
--- a/gnu/usr.bin/perl/lib/validate.pl
+++ b/gnu/usr.bin/perl/lib/validate.pl
@@ -91,11 +91,11 @@ sub valmess {
$mess =~ s/ does not / should not / ||
$mess =~ s/ not / /;
}
- print stderr $mess,"\n";
+ print STDERR $mess,"\n";
}
else {
$this =~ s/\$file/'$file'/g;
- print stderr "Can't do $this.\n";
+ print STDERR "Can't do $this.\n";
}
if ($disposition eq 'die') { exit 1; }
++$warnings;
diff --git a/gnu/usr.bin/perl/lib/vars.pm b/gnu/usr.bin/perl/lib/vars.pm
index b9519291c4b..5723ac6c2cb 100644
--- a/gnu/usr.bin/perl/lib/vars.pm
+++ b/gnu/usr.bin/perl/lib/vars.pm
@@ -1,30 +1,22 @@
package vars;
-=head1 NAME
-
-vars - Perl pragma to predeclare global variable names
-
-=head1 SYNOPSIS
-
- use vars qw($frob @mung %seen);
-
-=head1 DESCRIPTION
+require 5.002;
-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.
-
-See L<perlmod/Pragmatic Modules>.
-
-=cut
-require 5.000;
-use Carp;
+# 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) {
- croak "Can't declare another package's variables" if $sym =~ /::/;
+ if ($sym =~ /::/) {
+ require Carp;
+ Carp::croak("Can't declare another package's variables");
+ }
($ch, $sym) = unpack('a1a*', $sym);
*{"${callpack}::$sym"} =
( $ch eq "\$" ? \$ {"${callpack}::$sym"}
@@ -32,8 +24,43 @@ sub import {
: $ch eq "\%" ? \% {"${callpack}::$sym"}
: $ch eq "\*" ? \* {"${callpack}::$sym"}
: $ch eq "\&" ? \& {"${callpack}::$sym"}
- : croak "'$ch$sym' is not a valid variable name\n");
+ : do {
+ require Carp;
+ Carp::croak("'$ch$sym' is not a valid variable name\n");
+ });
}
};
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<perlmod/Pragmatic Modules>.
+
+=cut
diff --git a/gnu/usr.bin/perl/makeaperl.SH b/gnu/usr.bin/perl/makeaperl.SH
index 6af94195d01..16b74350e01 100644
--- a/gnu/usr.bin/perl/makeaperl.SH
+++ b/gnu/usr.bin/perl/makeaperl.SH
@@ -17,10 +17,11 @@ 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 perl -S \$0 "\$@"'
- if 0;
+ eval 'exec $perlpath -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
!GROK!THIS!
$spitshell >>makeaperl <<'!NO!SUBS!'
diff --git a/gnu/usr.bin/perl/makedepend.SH b/gnu/usr.bin/perl/makedepend.SH
index acd9d7ecef3..7a89fa98210 100644
--- a/gnu/usr.bin/perl/makedepend.SH
+++ b/gnu/usr.bin/perl/makedepend.SH
@@ -1,3 +1,4 @@
+#! /bin/sh
case $CONFIG in
'')
if test -f config.sh; then TOP=.;
@@ -16,17 +17,23 @@ esac
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
#
-## To use an alternate make, set \$altmake in config.sh.
-MAKE=${altmake-make}
+MAKE=$make
!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
@@ -53,17 +60,24 @@ 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)\|\.o\):.*;/{' \
+ -e '/^\.c\$(OBJ_EXT):.*;/{' \
-e 's/\$\*\.c//' \
-e 's/^[^;]*;[ ]*//p' \
-e q \
-e '}' \
- -e '/^\.c\(\$(OBJ_EXT)\|\.o\): *$/{' \
+ -e '/^\.c\$(OBJ_EXT): *$/{' \
-e N \
-e 's/\$\*\.c//' \
-e 's/^.*\n[ ]*//p' \
@@ -104,6 +118,7 @@ for file in `$cat .clist`; do
$cppstdin $finc -I/usr/local/include -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' \
@@ -119,21 +134,27 @@ $sed <$mf >$mf.new -e '1,/^# AUTOMATICALLY/!d'
$MAKE shlist || ($echo "Searching for .SH files..."; \
$echo *.SH | $tr ' ' '\012' | $egrep -v '\*' >.shlist)
-# Now extract the dependency on makedepend.SH
-# (it should reside in the main Makefile):
+# Now extract the dependencies on makedepend.SH and Makefile.SH
+# (they should reside in the main Makefile):
mv .shlist .shlist.old
$egrep -v '^makedepend\.SH' <.shlist.old >.shlist
+mv .shlist .shlist.old
+$egrep -v '^Makefile\.SH' <.shlist.old >.shlist
+mv .shlist .shlist.old
+$egrep -v '^perl_exp\.SH' <.shlist.old >.shlist
+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 \; \
- /bin/sh $file >> .deptmp
+ $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)\|\.o\):\) *\(.*/.*\.c\) *$|\1 \3; '"$defrule \2|" .deptmp \
+ $sed 's|^\(.*\$(OBJ_EXT):\) *\(.*/.*\.c\) *$|\1 \2; '"$defrule \2|" .deptmp \
>>$mf.new
else
$MAKE hlist || ($echo "Searching for .h files..."; \
@@ -155,11 +176,12 @@ else
$sed -f .hsed >> $mf.new
for file in `$cat .shlist`; do
$echo `$expr X$file : 'X\(.*\).SH'`: $file $TOP/config.sh \; \
- /bin/sh $file >> $mf.new
+ $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
diff --git a/gnu/usr.bin/perl/malloc.c b/gnu/usr.bin/perl/malloc.c
index 581cbd37550..e8e9ca3eb12 100644
--- a/gnu/usr.bin/perl/malloc.c
+++ b/gnu/usr.bin/perl/malloc.c
@@ -2,10 +2,14 @@
*
*/
+#if defined(PERL_CORE) && !defined(DEBUGGING_MSTATS)
+# define DEBUGGING_MSTATS
+#endif
+
#ifndef lint
-#ifdef DEBUGGING
-#define RCHECK
-#endif
+# if defined(DEBUGGING) && !defined(NO_RCHECK)
+# define RCHECK
+# endif
/*
* malloc.c (Caltech) 2/21/82
* Chris Kingsley, kingsley@cit-20.
@@ -14,6 +18,7 @@
* 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.
*/
@@ -21,13 +26,26 @@
#include "EXTERN.h"
#include "perl.h"
+#ifdef DEBUGGING
+#undef DEBUG_m
+#define DEBUG_m(a) if (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
#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
@@ -55,7 +73,7 @@ union overhead {
#define ov_rmagic ovu.ovu_rmagic
};
-#ifdef debug
+#ifdef DEBUGGING
static void botch _((char *s));
#endif
static void morecore _((int bucket));
@@ -64,11 +82,150 @@ static int findbucket _((union overhead *freep, int srchlen));
#define MAGIC 0xff /* magic # on accounting info */
#define RMAGIC 0x55555555 /* magic # on range info */
#ifdef RCHECK
-#define RSLOP sizeof (u_int)
+# define RSLOP sizeof (u_int)
+# ifdef TWO_POT_OPTIMIZE
+# define MAX_SHORT_BUCKET 12
+# else
+# define MAX_SHORT_BUCKET 13
+# endif
#else
-#define RSLOP 0
+# define RSLOP 0
#endif
+#ifdef PACK_MALLOC
+/*
+ * In this case it is assumed that if we do sbrk() in 2K units, we
+ * will get 2K aligned blocks. The bucket number of the given subblock is
+ * on the boundary of 2K block 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).
+ *
+ * We suppose that starts of all the chunks in a 2K block 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, if 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 the chunk
+ * is immediately overwritten after freeing.
+ */
+# define MAX_PACKED 6
+# define MAX_2_POT_ALGO ((1<<(MAX_PACKED + 1)) - M_OVERHEAD)
+# define TWOK_MASK ((1<<11) - 1)
+# define TWOK_MASKED(x) ((u_int)(x) & ~TWOK_MASK)
+# define TWOK_SHIFT(x) ((u_int)(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 + 3)) + \
+ (bucket > MAX_NONSHIFT ? 1 : 0)))
+# define CHUNK_SHIFT 0
+
+static u_char n_blks[11 - 3] = {224, 120, 62, 31, 16, 8, 4, 2};
+static u_short blk_shift[11 - 3] = {256, 128, 64, 32,
+ 16*sizeof(union overhead),
+ 8*sizeof(union overhead),
+ 4*sizeof(union overhead),
+ 2*sizeof(union overhead),
+# define MAX_NONSHIFT 2 /* Shift 64 greater than chunk 32. */
+};
+
+#else /* !PACK_MALLOC */
+
+# define OV_MAGIC(block,bucket) (block)->ov_magic
+# define OV_INDEX(block) (block)->ov_index
+# define CHUNK_SHIFT 1
+#endif /* !PACK_MALLOC */
+
+# define M_OVERHEAD (sizeof(union overhead) + RSLOP)
+
+/*
+ * 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_TWO_POT
+# define FIRST_BIG_TWO_POT 14 /* 16K */
+# endif
+# define FIRST_BIG_BLOCK (1<<FIRST_BIG_TWO_POT) /* 16K */
+/* 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)
+
+#endif /* TWO_POT_OPTIMIZE */
+
+#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 char *
+emergency_sbrk(size)
+ MEM_SIZE size;
+{
+ if (size >= BIG_SIZE) {
+ /* Give the possibility to recover: */
+ die("Out of memory during request for %i bytes", size);
+ /* croak may eat too much memory. */
+ }
+
+ if (!emergency_buffer) {
+ /* First offense, give a possibility to recover by dieing. */
+ /* No malloc involved here: */
+ GV **gvp = (GV**)hv_fetch(defstash, "^M", 2, 0);
+ SV *sv;
+ char *pv;
+
+ if (!gvp) gvp = (GV**)hv_fetch(defstash, "\015", 1, 0);
+ if (!gvp || !(sv = GvSV(*gvp)) || !SvPOK(sv)
+ || (SvLEN(sv) < (1<<11) - M_OVERHEAD))
+ return (char *)-1; /* Now die die die... */
+
+ /* Got it, now detach SvPV: */
+ pv = SvPV(sv, na);
+ /* Check alignment: */
+ if (((u_int)(pv - M_OVERHEAD)) & ((1<<11) - 1)) {
+ PerlIO_puts(PerlIO_stderr(),"Bad alignment of $^M!\n");
+ return (char *)-1; /* die die die */
+ }
+
+ emergency_buffer = pv - M_OVERHEAD;
+ emergency_buffer_size = SvLEN(sv) + M_OVERHEAD;
+ SvPOK_off(sv);
+ SvREADONLY_on(sv);
+ die("Out of memory!"); /* croak may eat too much memory. */
+ }
+ else if (emergency_buffer_size >= size) {
+ emergency_buffer_size -= size;
+ return emergency_buffer + emergency_buffer_size;
+ }
+
+ return (char *)-1; /* poor guy... */
+}
+
+#else /* !(defined(TWO_POT_OPTIMIZE) && defined(PERL_CORE)) */
+# define emergency_sbrk(size) -1
+#endif /* !(defined(TWO_POT_OPTIMIZE) && defined(PERL_CORE)) */
+
/*
* nextf[i] is the pointer to the next free block of size 2^(i+3). The
* smallest allocatable block is 8 bytes. The overhead information
@@ -76,7 +233,13 @@ static int findbucket _((union overhead *freep, int srchlen));
*/
#define NBUCKETS 30
static union overhead *nextf[NBUCKETS];
+
+#ifdef USE_PERL_SBRK
+#define sbrk(a) Perl_sbrk(a)
+char * Perl_sbrk _((int size));
+#else
extern char *sbrk();
+#endif
#ifdef DEBUGGING_MSTATS
/*
@@ -84,17 +247,18 @@ extern char *sbrk();
* for a given block size.
*/
static u_int nmalloc[NBUCKETS];
-#include <stdio.h>
+static u_int goodsbrk;
+static u_int sbrk_slack;
+static u_int start_slack;
#endif
-#ifdef debug
-#define ASSERT(p) if (!(p)) botch("p"); else
+#ifdef DEBUGGING
+#define ASSERT(p) if (!(p)) botch(STRINGIFY(p)); else
static void
botch(s)
char *s;
{
-
- printf("assertion botched: %s\n", s);
+ PerlIO_printf(PerlIO_stderr(), "assertion botched: %s\n", s);
abort();
}
#else
@@ -109,22 +273,23 @@ malloc(nbytes)
register int bucket = 0;
register MEM_SIZE shiftr;
-#ifdef safemalloc
-#ifdef DEBUGGING
+#if defined(DEBUGGING) || defined(RCHECK)
MEM_SIZE size = nbytes;
#endif
-#ifdef MSDOS
+#ifdef PERL_CORE
+#ifdef HAS_64K_LIMIT
if (nbytes > 0xffff) {
- fprintf(stderr, "Allocation too large: %lx\n", (long)nbytes);
+ PerlIO_printf(PerlIO_stderr(),
+ "Allocation too large: %lx\n", (long)nbytes);
my_exit(1);
}
-#endif /* MSDOS */
+#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
if ((long)nbytes < 0)
- croak("panic: malloc");
+ croak("panic: malloc");
#endif
-#endif /* safemalloc */
+#endif /* PERL_CORE */
/*
* Convert amount of memory requested into
@@ -132,8 +297,19 @@ malloc(nbytes)
* which satisfies request. Account for
* space used per block for accounting.
*/
- nbytes += sizeof (union overhead) + RSLOP;
- nbytes = (nbytes + 3) &~ 3;
+#ifdef PACK_MALLOC
+ if (nbytes == 0)
+ nbytes = 1;
+ else if (nbytes > MAX_2_POT_ALGO)
+#endif
+ {
+#ifdef TWO_POT_OPTIMIZE
+ if (nbytes >= FIRST_BIG_BOUND)
+ nbytes -= PERL_PAGESIZE;
+#endif
+ nbytes += M_OVERHEAD;
+ nbytes = (nbytes + 3) &~ 3;
+ }
shiftr = (nbytes - 1) >> 2;
/* apart from this loop, this is O(1) */
while (shiftr >>= 1)
@@ -145,9 +321,9 @@ malloc(nbytes)
if (nextf[bucket] == NULL)
morecore(bucket);
if ((p = (union overhead *)nextf[bucket]) == NULL) {
-#ifdef safemalloc
+#ifdef PERL_CORE
if (!nomemok) {
- fputs("Out of memory!\n", stderr);
+ PerlIO_puts(PerlIO_stderr(),"Out of memory!\n");
my_exit(1);
}
#else
@@ -155,34 +331,34 @@ malloc(nbytes)
#endif
}
-#ifdef safemalloc
- DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",
- (unsigned long)(p+1),an++,(long)size));
-#endif /* safemalloc */
+#ifdef PERL_CORE
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) malloc %ld bytes\n",
+ (unsigned long)(p+1),(unsigned long)(an++),(long)size));
+#endif /* PERL_CORE */
/* remove from linked list */
#ifdef RCHECK
if (*((int*)p) & (sizeof(union overhead) - 1))
- fprintf(stderr,"Corrupt malloc ptr 0x%lx at 0x%lx\n",
+ 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;
- p->ov_magic = MAGIC;
- p->ov_index= bucket;
-#ifdef DEBUGGING_MSTATS
- nmalloc[bucket]++;
+ 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.
*/
+ nbytes = (size + M_OVERHEAD + 3) &~ 3;
if (nbytes <= 0x10000)
p->ov_size = nbytes - 1;
p->ov_rmagic = RMAGIC;
*((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
#endif
- return ((Malloc_t)(p + 1));
+ return ((Malloc_t)(p + CHUNK_SHIFT));
}
/*
@@ -195,10 +371,14 @@ morecore(bucket)
register union overhead *op;
register int rnu; /* 2^rnu bytes will be requested */
register int nblks; /* become nblks blocks of the desired size */
- register MEM_SIZE siz;
+ register MEM_SIZE siz, needed;
+ int slack = 0;
if (nextf[bucket])
return;
+ if (bucket == (sizeof(MEM_SIZE)*8 - 3)) {
+ croak("Allocation too large");
+ }
/*
* Insure memory is allocated
* on a page boundary. Should
@@ -206,12 +386,17 @@ morecore(bucket)
*/
#ifndef atarist /* on the atari we dont have to worry about this */
op = (union overhead *)sbrk(0);
-#ifndef I286
- if ((int)op & 0x3ff)
- (void)sbrk(1024 - ((int)op & 0x3ff));
-#else
+# ifndef I286
+ if ((UV)op & (0x7FF >> CHUNK_SHIFT)) {
+ slack = (0x800 >> CHUNK_SHIFT) - ((UV)op & (0x7FF >> CHUNK_SHIFT));
+ (void)sbrk(slack);
+# if defined(DEBUGGING_MSTATS)
+ sbrk_slack += slack;
+# endif
+ }
+# else
/* The sbrk(0) call on the I286 always returns the next segment */
-#endif
+# endif
#endif /* atarist */
#if !(defined(I286) || defined(atarist))
@@ -223,19 +408,31 @@ morecore(bucket)
rnu = (bucket <= 11) ? 14 : bucket + 3;
#endif
nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */
- if (rnu < bucket)
- rnu = bucket;
- op = (union overhead *)sbrk(1L << rnu);
+ needed = (MEM_SIZE)1 << rnu;
+#ifdef TWO_POT_OPTIMIZE
+ needed += (bucket >= (FIRST_BIG_TWO_POT - 3) ? PERL_PAGESIZE : 0);
+#endif
+ op = (union overhead *)sbrk(needed);
/* no more room! */
- if ((int)op == -1)
+ if (op == (union overhead *)-1) {
+ op = (union overhead *)emergency_sbrk(needed);
+ if (op == (union overhead *)-1)
return;
+ }
+#ifdef DEBUGGING_MSTATS
+ goodsbrk += needed;
+#endif
/*
* Round up to minimum allocation size boundary
* and deduct from block count to reflect.
*/
#ifndef I286
- if ((int)op & 7) {
- op = (union overhead *)(((MEM_SIZE)op + 8) &~ 7);
+# ifdef PACK_MALLOC
+ if ((UV)op & 0x7FF)
+ croak("panic: Off-page sbrk");
+# endif
+ if ((UV)op & 7) {
+ op = (union overhead *)(((UV)op + 8) & ~7);
nblks--;
}
#else
@@ -245,12 +442,39 @@ morecore(bucket)
* Add new memory allocated to that on
* free list for this hash bucket.
*/
- nextf[bucket] = op;
siz = 1 << (bucket + 3);
+#ifdef PACK_MALLOC
+ *(u_char*)op = bucket; /* Fill index. */
+ if (bucket <= MAX_PACKED - 3) {
+ op = (union overhead *) ((char*)op + blk_shift[bucket]);
+ nblks = n_blks[bucket];
+# ifdef DEBUGGING_MSTATS
+ start_slack += blk_shift[bucket];
+# endif
+ } else if (bucket <= 11 - 1 - 3) {
+ op = (union overhead *) ((char*)op + blk_shift[bucket]);
+ /* nblks = n_blks[bucket]; */
+ siz -= sizeof(union overhead);
+ } else op++; /* One chunk per block. */
+#endif /* !PACK_MALLOC */
+ nextf[bucket] = op;
+#ifdef DEBUGGING_MSTATS
+ nmalloc[bucket] += nblks;
+#endif
while (--nblks > 0) {
op->ov_next = (union overhead *)((caddr_t)op + siz);
op = (union overhead *)((caddr_t)op + siz);
}
+ /* Not all sbrks return zeroed memory.*/
+ op->ov_next = (union overhead *)NULL;
+#ifdef PACK_MALLOC
+ if (bucket == 7 - 3) { /* Special case, explanation is above. */
+ union overhead *n_op = nextf[7 - 3]->ov_next;
+ nextf[7 - 3] = (union overhead *)((caddr_t)nextf[7 - 3]
+ - sizeof(union overhead));
+ nextf[7 - 3]->ov_next = n_op;
+ }
+#endif /* !PACK_MALLOC */
}
Free_t
@@ -260,18 +484,29 @@ free(mp)
register MEM_SIZE size;
register union overhead *op;
char *cp = (char*)mp;
-
-#ifdef safemalloc
- DEBUG_m(fprintf(stderr,"0x%lx: (%05d) free\n",(unsigned long)cp,an++));
-#endif /* safemalloc */
-
- if (cp == NULL)
- return;
- op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
-#ifdef debug
- ASSERT(op->ov_magic == MAGIC); /* make sure it was in use */
-#else
- if (op->ov_magic != MAGIC) {
+#ifdef PACK_MALLOC
+ u_char bucket;
+#endif
+
+#ifdef PERL_CORE
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) free\n",(unsigned long)cp,(unsigned long)(an++)));
+#endif /* PERL_CORE */
+
+ if (cp == NULL)
+ return;
+ op = (union overhead *)((caddr_t)cp
+ - sizeof (union overhead) * CHUNK_SHIFT);
+#ifdef PACK_MALLOC
+ bucket = OV_INDEX(op);
+#endif
+ if (OV_MAGIC(op, bucket) != MAGIC) {
+ static int bad_free_warn = -1;
+ if (bad_free_warn == -1) {
+ char *pbf = getenv("PERL_BADFREE");
+ bad_free_warn = (pbf) ? atoi(pbf) : 1;
+ }
+ if (!bad_free_warn)
+ return;
#ifdef RCHECK
warn("%s free() ignored",
op->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
@@ -280,20 +515,16 @@ free(mp)
#endif
return; /* sanity */
}
-#endif
#ifdef RCHECK
ASSERT(op->ov_rmagic == RMAGIC);
- if (op->ov_index <= 13)
+ if (OV_INDEX(op) <= MAX_SHORT_BUCKET)
ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC);
op->ov_rmagic = RMAGIC - 1;
#endif
- ASSERT(op->ov_index < NBUCKETS);
- size = op->ov_index;
+ ASSERT(OV_INDEX(op) < NBUCKETS);
+ size = OV_INDEX(op);
op->ov_next = nextf[size];
nextf[size] = op;
-#ifdef DEBUGGING_MSTATS
- nmalloc[size]--;
-#endif
}
/*
@@ -321,29 +552,31 @@ realloc(mp, nbytes)
int was_alloced = 0;
char *cp = (char*)mp;
-#ifdef safemalloc
#ifdef DEBUGGING
MEM_SIZE size = nbytes;
#endif
-#ifdef MSDOS
+#ifdef PERL_CORE
+#ifdef HAS_64K_LIMIT
if (nbytes > 0xffff) {
- fprintf(stderr, "Reallocation too large: %lx\n", size);
+ PerlIO_printf(PerlIO_stderr(),
+ "Reallocation too large: %lx\n", size);
my_exit(1);
}
-#endif /* MSDOS */
+#endif /* HAS_64K_LIMIT */
if (!cp)
return malloc(nbytes);
#ifdef DEBUGGING
if ((long)nbytes < 0)
croak("panic: realloc");
#endif
-#endif /* safemalloc */
+#endif /* PERL_CORE */
- op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
- if (op->ov_magic == MAGIC) {
- was_alloced++;
- i = op->ov_index;
+ op = (union overhead *)((caddr_t)cp
+ - sizeof (union overhead) * CHUNK_SHIFT);
+ i = OV_INDEX(op);
+ if (OV_MAGIC(op, i) == MAGIC) {
+ was_alloced = 1;
} else {
/*
* Already free, doing "compaction".
@@ -360,23 +593,43 @@ realloc(mp, nbytes)
(i = findbucket(op, reall_srchlen)) < 0)
i = 0;
}
- onb = (1L << (i + 3)) - sizeof (*op) - RSLOP;
- /* avoid the copy if same size block */
+ onb = (1L << (i + 3)) -
+#ifdef PACK_MALLOC
+ (i <= (MAX_PACKED - 3) ? 0 : M_OVERHEAD)
+#else
+ M_OVERHEAD
+#endif
+#ifdef TWO_POT_OPTIMIZE
+ + (i >= (FIRST_BIG_TWO_POT - 3) ? PERL_PAGESIZE : 0)
+#endif
+ ;
+ /*
+ * avoid the copy if same size block.
+ * We are not agressive with boundary cases. Note that it is
+ * possible for small number of cases give false negative if
+ * both new size and old one are in the bucket for
+ * FIRST_BIG_TWO_POT, but the new one is near the lower end.
+ */
if (was_alloced &&
- nbytes <= onb && nbytes > (onb >> 1) - sizeof(*op) - RSLOP) {
+ nbytes <= onb && (nbytes > ( (onb >> 1) - M_OVERHEAD )
+#ifdef TWO_POT_OPTIMIZE
+ || (i == (FIRST_BIG_TWO_POT - 3)
+ && nbytes >= LAST_SMALL_BOUND )
+#endif
+ )) {
#ifdef RCHECK
/*
* Record new allocated size of block and
* bound space with magic numbers.
*/
- if (op->ov_index <= 13) {
+ if (OV_INDEX(op) <= MAX_SHORT_BUCKET) {
/*
* 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 += sizeof (union overhead) + RSLOP;
+ nbytes += M_OVERHEAD;
nbytes = (nbytes + 3) &~ 3;
op->ov_size = nbytes - 1;
*((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC;
@@ -393,15 +646,15 @@ realloc(mp, nbytes)
free(cp);
}
-#ifdef safemalloc
+#ifdef PERL_CORE
#ifdef DEBUGGING
if (debug & 128) {
- fprintf(stderr,"0x%lx: (%05d) rfree\n",(unsigned long)res,an++);
- fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",
- (unsigned long)res,an++,(long)size);
+ PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) rfree\n",(unsigned long)res,(unsigned long)(an++));
+ PerlIO_printf(Perl_debug_log, "0x%lx: (%05lu) realloc %ld bytes\n",
+ (unsigned long)res,(unsigned long)(an++),(long)size);
}
#endif
-#endif /* safemalloc */
+#endif /* PERL_CORE */
return ((Malloc_t)res);
}
@@ -429,6 +682,20 @@ findbucket(freep, srchlen)
return (-1);
}
+Malloc_t
+calloc(elements, size)
+ register MEM_SIZE elements;
+ register MEM_SIZE size;
+{
+ long sz = elements * size;
+ Malloc_t p = malloc(sz);
+
+ if (p) {
+ memset((void*)p, 0, sz);
+ }
+ return p;
+}
+
#ifdef DEBUGGING_MSTATS
/*
* mstats - print out statistics about malloc
@@ -443,7 +710,7 @@ dump_mstats(s)
{
register int i, j;
register union overhead *p;
- int topbucket=0, totfree=0, totused=0;
+ int topbucket=0, totfree=0, total=0;
u_int nfree[NBUCKETS];
for (i=0; i < NBUCKETS; i++) {
@@ -451,22 +718,23 @@ dump_mstats(s)
;
nfree[i] = j;
totfree += nfree[i] * (1 << (i + 3));
- totused += nmalloc[i] * (1 << (i + 3));
- if (nfree[i] || nmalloc[i])
+ total += nmalloc[i] * (1 << (i + 3));
+ if (nmalloc[i])
topbucket = i;
}
if (s)
- fprintf(stderr, "Memory allocation statistics %s (buckets 8..%d)\n",
+ PerlIO_printf(PerlIO_stderr(), "Memory allocation statistics %s (buckets 8..%d)\n",
s, (1 << (topbucket + 3)) );
- fprintf(stderr, " %7d free: ", totfree);
+ PerlIO_printf(PerlIO_stderr(), "%8d free:", totfree);
for (i=0; i <= topbucket; i++) {
- fprintf(stderr, (i<5)?" %5d":" %3d", nfree[i]);
+ PerlIO_printf(PerlIO_stderr(), (i<5 || i==7)?" %5d": (i<9)?" %3d":" %d", nfree[i]);
}
- fprintf(stderr, "\n %7d used: ", totused);
+ PerlIO_printf(PerlIO_stderr(), "\n%8d used:", total - totfree);
for (i=0; i <= topbucket; i++) {
- fprintf(stderr, (i<5)?" %5d":" %3d", nmalloc[i]);
+ PerlIO_printf(PerlIO_stderr(), (i<5 || i==7)?" %5d": (i<9)?" %3d":" %d", nmalloc[i] - nfree[i]);
}
- fprintf(stderr, "\n");
+ PerlIO_printf(PerlIO_stderr(), "\nTotal sbrk(): %8d. Odd ends: sbrk(): %7d, malloc(): %7d bytes.\n",
+ goodsbrk + sbrk_slack, sbrk_slack, start_slack);
}
#else
void
@@ -476,3 +744,81 @@ dump_mstats(s)
}
#endif
#endif /* lint */
+
+
+#ifdef USE_PERL_SBRK
+
+# ifdef NeXT
+# define PERL_SBRK_VIA_MALLOC
+# endif
+
+# ifdef PERL_SBRK_VIA_MALLOC
+# if defined(HIDEMYMALLOC) || defined(EMBEDMYMALLOC)
+# undef malloc
+# 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 */
+
+# define SYSTEM_ALLOC(a) malloc(a)
+
+# 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)
+
+char *
+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 {
+#ifndef PERL_CORE
+ reqsize = size;
+#endif
+ 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;
+ }
+ }
+
+#ifdef PERL_CORE
+ 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));
+#endif
+
+ return (void *)got;
+}
+
+#endif /* ! defined USE_PERL_SBRK */
diff --git a/gnu/usr.bin/perl/mg.c b/gnu/usr.bin/perl/mg.c
index 5e649bb9b98..ee87d47859b 100644
--- a/gnu/usr.bin/perl/mg.c
+++ b/gnu/usr.bin/perl/mg.c
@@ -1,6 +1,6 @@
/* mg.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -15,11 +15,16 @@
#include "EXTERN.h"
#include "perl.h"
-/* Omit -- it causes too much grief on mixed systems.
+/* 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.
@@ -33,15 +38,13 @@ typedef struct magic_state MGS;
static void restore_magic _((void *p));
-static MGS *
-save_magic(sv)
+static void
+save_magic(mgs, sv)
+MGS* mgs;
SV* sv;
{
- MGS* mgs;
-
assert(SvMAGICAL(sv));
- mgs = (MGS*)safemalloc(sizeof(MGS));
mgs->mgs_sv = sv;
mgs->mgs_flags = SvMAGICAL(sv) | SvREADONLY(sv);
SAVEDESTRUCTOR(restore_magic, mgs);
@@ -49,15 +52,13 @@ SV* sv;
SvMAGICAL_off(sv);
SvREADONLY_off(sv);
SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
-
- return mgs;
}
static void
restore_magic(p)
void* p;
{
- MGS *mgs = (MGS*)p;
+ MGS* mgs = (MGS*)p;
SV* sv = mgs->mgs_sv;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
@@ -69,8 +70,6 @@ void* p;
if (SvGMAGICAL(sv))
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
}
-
- Safefree(mgs);
}
@@ -96,12 +95,13 @@ int
mg_get(sv)
SV* sv;
{
- MGS* mgs;
+ MGS mgs;
MAGIC* mg;
MAGIC** mgp;
+ int mgp_valid = 0;
ENTER;
- mgs = save_magic(sv);
+ save_magic(&mgs, sv);
mgp = &SvMAGIC(sv);
while ((mg = *mgp) != 0) {
@@ -109,12 +109,17 @@ SV* sv;
if (!(mg->mg_flags & MGf_GSKIP) && vtbl && vtbl->svt_get) {
(*vtbl->svt_get)(sv, mg);
/* Ignore this magic if it's been deleted */
- if (*mgp == mg && (mg->mg_flags & MGf_GSKIP))
- mgs->mgs_flags = 0;
+ 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 (*mgp == mg)
+ 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;
@@ -125,19 +130,19 @@ int
mg_set(sv)
SV* sv;
{
- MGS* mgs;
+ MGS mgs;
MAGIC* mg;
MAGIC* nextmg;
ENTER;
- mgs = save_magic(sv);
+ 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;
+ mgs.mgs_flags = 0;
}
if (vtbl && vtbl->svt_set)
(*vtbl->svt_set)(sv, mg);
@@ -158,8 +163,10 @@ SV* sv;
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
MGVTBL* vtbl = mg->mg_virtual;
if (vtbl && vtbl->svt_len) {
+ MGS mgs;
+
ENTER;
- save_magic(sv);
+ save_magic(&mgs, sv);
/* omit MGf_GSKIP -- not changed here */
len = (*vtbl->svt_len)(sv, mg);
LEAVE;
@@ -175,10 +182,11 @@ int
mg_clear(sv)
SV* sv;
{
+ MGS mgs;
MAGIC* mg;
ENTER;
- save_magic(sv);
+ save_magic(&mgs, sv);
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
MGVTBL* vtbl = mg->mg_virtual;
@@ -210,7 +218,7 @@ mg_copy(sv, nsv, key, klen)
SV* sv;
SV* nsv;
char *key;
-STRLEN klen;
+I32 klen;
{
int count = 0;
MAGIC* mg;
@@ -235,7 +243,10 @@ SV* sv;
if (vtbl && vtbl->svt_free)
(*vtbl->svt_free)(sv, mg);
if (mg->mg_ptr && mg->mg_type != 'g')
- Safefree(mg->mg_ptr);
+ 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);
@@ -256,49 +267,47 @@ MAGIC *mg;
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 (curpm) {
+ if (curpm && (rx = curpm->op_pmregexp)) {
paren = atoi(mg->mg_ptr);
getparen:
- if (curpm->op_pmregexp &&
- paren <= curpm->op_pmregexp->nparens &&
- (s = curpm->op_pmregexp->startp[paren]) &&
- (t = curpm->op_pmregexp->endp[paren]) ) {
+ if (paren <= rx->nparens &&
+ (s = rx->startp[paren]) &&
+ (t = rx->endp[paren]))
+ {
i = t - s;
if (i >= 0)
return i;
}
}
return 0;
- break;
case '+':
- if (curpm) {
- paren = curpm->op_pmregexp->lastparen;
- if (!paren)
- return 0;
- goto getparen;
+ if (curpm && (rx = curpm->op_pmregexp)) {
+ paren = rx->lastparen;
+ if (paren)
+ goto getparen;
}
return 0;
- break;
case '`':
- if (curpm) {
- if (curpm->op_pmregexp &&
- (s = curpm->op_pmregexp->subbeg) ) {
- i = curpm->op_pmregexp->startp[0] - s;
+ if (curpm && (rx = curpm->op_pmregexp)) {
+ if ((s = rx->subbeg) && rx->startp[0]) {
+ i = rx->startp[0] - s;
if (i >= 0)
return i;
}
}
return 0;
case '\'':
- if (curpm) {
- if (curpm->op_pmregexp &&
- (s = curpm->op_pmregexp->endp[0]) ) {
- return (STRLEN) (curpm->op_pmregexp->subend - s);
+ if (curpm && (rx = curpm->op_pmregexp)) {
+ if (rx->subend && (s = rx->endp[0])) {
+ i = rx->subend - s;
+ if (i >= 0)
+ return i;
}
}
return 0;
@@ -323,6 +332,7 @@ MAGIC *mg;
register I32 paren;
register char *s;
register I32 i;
+ register REGEXP *rx;
char *t;
switch (*mg->mg_ptr) {
@@ -330,7 +340,7 @@ MAGIC *mg;
sv_setsv(sv, bodytarget);
break;
case '\004': /* ^D */
- sv_setiv(sv,(I32)(debug & 32767));
+ sv_setiv(sv, (IV)(debug & 32767));
break;
case '\005': /* ^E */
#ifdef VMS
@@ -339,57 +349,86 @@ MAGIC *mg;
# include <starlet.h>
char msg[255];
$DESCRIPTOR(msgdsc,msg);
- sv_setnv(sv,(double)vaxc$errno);
+ 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
- sv_setnv(sv,(double)errno);
+#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
+ sv_setnv(sv, (double)errno);
sv_setpv(sv, errno ? Strerror(errno) : "");
#endif
+#endif
SvNOK_on(sv); /* what a wonderful hack! */
break;
case '\006': /* ^F */
- sv_setiv(sv,(I32)maxsysfd);
+ sv_setiv(sv, (IV)maxsysfd);
break;
case '\010': /* ^H */
- sv_setiv(sv,(I32)hints);
+ sv_setiv(sv, (IV)hints);
break;
case '\t': /* ^I */
if (inplace)
sv_setpv(sv, inplace);
else
- sv_setsv(sv,&sv_undef);
+ sv_setsv(sv, &sv_undef);
break;
case '\017': /* ^O */
- sv_setpv(sv,osname);
+ sv_setpv(sv, osname);
break;
case '\020': /* ^P */
- sv_setiv(sv,(I32)perldb);
+ sv_setiv(sv, (IV)perldb);
+ break;
+ case '\023': /* ^S */
+ if (lex_state != LEX_NOTPARSING)
+ SvOK_off(sv);
+ else if (in_eval)
+ sv_setiv(sv, 1);
+ else
+ sv_setiv(sv, 0);
break;
case '\024': /* ^T */
- sv_setiv(sv,(I32)basetime);
+#ifdef BIG_TIME
+ sv_setnv(sv, basetime);
+#else
+ sv_setiv(sv, (IV)basetime);
+#endif
break;
case '\027': /* ^W */
- sv_setiv(sv,(I32)dowarn);
+ sv_setiv(sv, (IV)dowarn);
break;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
- if (curpm) {
- paren = atoi(GvENAME(mg->mg_obj));
+ if (curpm && (rx = curpm->op_pmregexp)) {
+ paren = atoi(GvENAME((GV*)mg->mg_obj));
getparen:
- if (curpm->op_pmregexp &&
- paren <= curpm->op_pmregexp->nparens &&
- (s = curpm->op_pmregexp->startp[paren]) &&
- (t = curpm->op_pmregexp->endp[paren]) ) {
+ if (paren <= rx->nparens &&
+ (s = rx->startp[paren]) &&
+ (t = rx->endp[paren]))
+ {
i = t - s;
+ getrx:
if (i >= 0) {
- MAGIC *tmg;
+ bool was_tainted;
+ if (tainting) {
+ was_tainted = tainted;
+ tainted = FALSE;
+ }
sv_setpvn(sv,s,i);
- if (tainting && (tmg = mg_find(sv,'t')))
- tmg->mg_len = 0; /* guarantee $1 untainted */
+ if (tainting)
+ tainted = was_tainted || rx->exec_tainted;
break;
}
}
@@ -397,32 +436,27 @@ MAGIC *mg;
sv_setsv(sv,&sv_undef);
break;
case '+':
- if (curpm) {
- paren = curpm->op_pmregexp->lastparen;
+ if (curpm && (rx = curpm->op_pmregexp)) {
+ paren = rx->lastparen;
if (paren)
goto getparen;
}
sv_setsv(sv,&sv_undef);
break;
case '`':
- if (curpm) {
- if (curpm->op_pmregexp &&
- (s = curpm->op_pmregexp->subbeg) ) {
- i = curpm->op_pmregexp->startp[0] - s;
- if (i >= 0) {
- sv_setpvn(sv,s,i);
- break;
- }
+ if (curpm && (rx = curpm->op_pmregexp)) {
+ if ((s = rx->subbeg) && rx->startp[0]) {
+ i = rx->startp[0] - s;
+ goto getrx;
}
}
sv_setsv(sv,&sv_undef);
break;
case '\'':
- if (curpm) {
- if (curpm->op_pmregexp &&
- (s = curpm->op_pmregexp->endp[0]) ) {
- sv_setpvn(sv,s, curpm->op_pmregexp->subend - s);
- break;
+ if (curpm && (rx = curpm->op_pmregexp)) {
+ if (rx->subend && (s = rx->endp[0])) {
+ i = rx->subend - s;
+ goto getrx;
}
}
sv_setsv(sv,&sv_undef);
@@ -430,12 +464,16 @@ MAGIC *mg;
case '.':
#ifndef lint
if (GvIO(last_in_gv)) {
- sv_setiv(sv,(I32)IoLINES(GvIO(last_in_gv)));
+ sv_setiv(sv, (IV)IoLINES(GvIO(last_in_gv)));
}
#endif
break;
case '?':
- sv_setiv(sv,(I32)statusvalue);
+ sv_setiv(sv, (IV)STATUS_CURRENT);
+#ifdef COMPLEX_STATUS
+ LvTARGOFF(sv) = statusvalue;
+ LvTARGLEN(sv) = statusvalue_vms;
+#endif
break;
case '^':
s = IoTOP_NAME(GvIOp(defoutgv));
@@ -454,13 +492,13 @@ MAGIC *mg;
break;
#ifndef lint
case '=':
- sv_setiv(sv,(I32)IoPAGE_LEN(GvIOp(defoutgv)));
+ sv_setiv(sv, (IV)IoPAGE_LEN(GvIOp(defoutgv)));
break;
case '-':
- sv_setiv(sv,(I32)IoLINES_LEFT(GvIOp(defoutgv)));
+ sv_setiv(sv, (IV)IoLINES_LEFT(GvIOp(defoutgv)));
break;
case '%':
- sv_setiv(sv,(I32)IoPAGE(GvIOp(defoutgv)));
+ sv_setiv(sv, (IV)IoPAGE(GvIOp(defoutgv)));
break;
#endif
case ':':
@@ -468,10 +506,10 @@ MAGIC *mg;
case '/':
break;
case '[':
- sv_setiv(sv,(I32)curcop->cop_arybase);
+ sv_setiv(sv, (IV)curcop->cop_arybase);
break;
case '|':
- sv_setiv(sv, (IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
+ sv_setiv(sv, (IV)(IoFLAGS(GvIOp(defoutgv)) & IOf_FLUSH) != 0 );
break;
case ',':
sv_setpvn(sv,ofs,ofslen);
@@ -484,43 +522,45 @@ MAGIC *mg;
break;
case '!':
#ifdef VMS
- sv_setnv(sv,(double)((errno == EVMSERR) ? vaxc$errno : errno));
+ sv_setnv(sv, (double)((errno == EVMSERR) ? vaxc$errno : errno));
+ sv_setpv(sv, errno ? Strerror(errno) : "");
#else
- sv_setnv(sv,(double)errno);
+ {
+ 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,(I32)uid);
+ sv_setiv(sv, (IV)uid);
break;
case '>':
- sv_setiv(sv,(I32)euid);
+ sv_setiv(sv, (IV)euid);
break;
case '(':
- s = buf;
- (void)sprintf(s,"%d",(int)gid);
+ sv_setiv(sv, (IV)gid);
+ sv_setpvf(sv, "%Vd", (IV)gid);
goto add_groups;
case ')':
- s = buf;
- (void)sprintf(s,"%d",(int)egid);
+ sv_setiv(sv, (IV)egid);
+ sv_setpvf(sv, "%Vd", (IV)egid);
add_groups:
- while (*s) s++;
#ifdef HAS_GETGROUPS
-#ifndef NGROUPS
-#define NGROUPS 32
-#endif
{
Groups_t gary[NGROUPS];
-
i = getgroups(NGROUPS,gary);
- while (--i >= 0) {
- (void)sprintf(s," %ld", (long)gary[i]);
- while (*s) s++;
- }
+ while (--i >= 0)
+ sv_catpvf(sv, " %Vd", (IV)gary[i]);
}
#endif
- sv_setpv(sv,buf);
+ SvIOK_on(sv); /* what a wonderful hack! */
break;
case '*':
break;
@@ -548,34 +588,74 @@ SV* sv;
MAGIC* mg;
{
register char *s;
- STRLEN len;
+ char *ptr;
+ STRLEN len, klen;
I32 i;
+
s = SvPV(sv,len);
- my_setenv(mg->mg_ptr,s);
+ 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 **envsvp;
- if (envsvp = hv_fetch(GvHVn(envgv),mg->mg_ptr,mg->mg_len,FALSE))
- s = SvPV(*envsvp,len);
+ SV **valp;
+ if ((valp = hv_fetch(GvHVn(envgv), ptr, klen, FALSE)))
+ s = SvPV(*valp, len);
}
#endif
+
+#if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32)
/* And you'll never guess what the dog had */
/* in its mouth... */
if (tainting) {
- if (s && strEQ(mg->mg_ptr,"PATH")) {
+ 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) {
- s = cpytill(tokenbuf,s,strend,':',&i);
+ struct stat st;
+ s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf,
+ s, strend, ':', &i);
s++;
- if (*tokenbuf != '/'
- || (Stat(tokenbuf,&statbuf) && (statbuf.st_mode & 2)) )
+ if (i >= sizeof tokenbuf /* too long -- assume the worst */
+ || *tokenbuf != '/'
+ || (Stat(tokenbuf, &st) == 0 && (st.st_mode & 2)) ) {
MgTAINTEDDIR_on(mg);
+ return 0;
+ }
}
}
}
+#endif /* neither OS2 nor AMIGAOS nor WIN32 */
+
return 0;
}
@@ -584,52 +664,116 @@ magic_clearenv(sv,mg)
SV* sv;
MAGIC* mg;
{
- my_setenv(mg->mg_ptr,Nullch);
+ my_setenv(MgPV(mg,na),Nullch);
return 0;
}
-#ifdef HAS_SIGACTION
-/* set up reliable signal() clone */
-
-typedef void (*Sigfunc) _((int));
-
-static
-Sigfunc rsignal(signo,handler)
-int signo;
-Sigfunc handler;
+int
+magic_set_all_env(sv,mg)
+SV* sv;
+MAGIC* mg;
{
- struct sigaction act,oact;
-
- act.sa_handler = handler;
- sigemptyset(&act.sa_mask);
- act.sa_flags = 0;
-#ifdef SIGALRM
- if (signo == SIGALRM) {
+#if defined(VMS)
+ die("Can't make list assignment to %%ENV on this system");
#else
- if (0) {
-#endif
-#ifdef SA_INTERRUPT
- act.sa_flags |= SA_INTERRUPT; /* SunOS */
-#endif
- } else {
-#ifdef SA_RESTART
- act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
-#endif
+ if (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), na));
+ }
}
- if (sigaction(signo, &act, &oact) < 0)
- return(SIG_ERR);
- else
- return(oact.sa_handler);
+#endif
+ return 0;
}
+int
+magic_clear_all_env(sv,mg)
+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;
-/* ah well, so much for reliability */
-
-#define rsignal(x,y) signal(x,y)
+ if (environ == 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,mg)
+SV* sv;
+MAGIC* mg;
+{
+ I32 i;
+ /* Are we fetching a signal entry? */
+ i = whichsig(MgPV(mg,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,&sv_undef);
+ psig_ptr[i] = SvREFCNT_inc(sv);
+ SvTEMP_off(sv);
+ }
+ }
+ return 0;
+}
+int
+magic_clearsig(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ I32 i;
+ /* Are we clearing a signal entry? */
+ i = whichsig(MgPV(mg,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,mg)
@@ -640,7 +784,7 @@ MAGIC* mg;
I32 i;
SV** svp;
- s = mg->mg_ptr;
+ s = MgPV(mg,na);
if (*s == '_') {
if (strEQ(s,"__DIE__"))
svp = &diehook;
@@ -663,10 +807,16 @@ MAGIC* mg;
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,sighandler);
+ (void)rsignal(i, sighandler);
else
*svp = SvREFCNT_inc(sv);
return 0;
@@ -674,23 +824,26 @@ MAGIC* mg;
s = SvPV_force(sv,na);
if (strEQ(s,"IGNORE")) {
if (i)
- (void)rsignal(i,SIG_IGN);
+ (void)rsignal(i, SIG_IGN);
else
*svp = 0;
}
else if (strEQ(s,"DEFAULT") || !*s) {
if (i)
- (void)rsignal(i,SIG_DFL);
+ (void)rsignal(i, SIG_DFL);
else
*svp = 0;
}
else {
- if (!strchr(s,':') && !strchr(s,'\'')) {
- sprintf(tokenbuf, "main::%s",s);
- sv_setpv(sv,tokenbuf);
- }
+ /*
+ * 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,sighandler);
+ (void)rsignal(i, sighandler);
else
*svp = SvREFCNT_inc(sv);
}
@@ -720,6 +873,18 @@ MAGIC* mg;
}
#endif /* OVERLOAD */
+int
+magic_setnkeys(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ if (LvTARG(sv)) {
+ hv_ksplit((HV*)LvTARG(sv), SvIV(sv));
+ LvTARG(sv) = Nullsv; /* Don't allow a ref to reassign this. */
+ }
+ return 0;
+}
+
static int
magic_methpack(sv,mg,meth)
SV* sv;
@@ -733,8 +898,12 @@ char *meth;
PUSHMARK(sp);
EXTEND(sp, 2);
PUSHs(mg->mg_obj);
- if (mg->mg_ptr)
- PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
+ 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)));
PUTBACK;
@@ -768,8 +937,12 @@ MAGIC* mg;
PUSHMARK(sp);
EXTEND(sp, 3);
PUSHs(mg->mg_obj);
- if (mg->mg_ptr)
- PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
+ 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)));
PUSHs(sv);
@@ -849,7 +1022,8 @@ MAGIC* mg;
gv = DBline;
i = SvTRUE(sv);
- svp = av_fetch(GvAV(gv),atoi(mg->mg_ptr), FALSE);
+ svp = av_fetch(GvAV(gv),
+ atoi(MgPV(mg,na)), FALSE);
if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
o->op_private = i;
else
@@ -927,6 +1101,7 @@ MAGIC* mg;
else if (pos > len)
pos = len;
mg->mg_len = pos;
+ mg->mg_flags &= ~MGf_MINMATCH;
return 0;
}
@@ -936,7 +1111,13 @@ magic_getglob(sv,mg)
SV* sv;
MAGIC* mg;
{
- gv_efullname(sv,((GV*)sv));/* a gv value, be nice */
+ 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;
}
@@ -957,14 +1138,8 @@ MAGIC* mg;
if (sv == (SV*)gv)
return 0;
if (GvGP(sv))
- gp_free(sv);
+ gp_free((GV*)sv);
GvGP(sv) = gp_ref(GvGP(gv));
- if (!GvAV(gv))
- gv_AVadd(gv);
- if (!GvHV(gv))
- gv_HVadd(gv);
- if (!GvIOp(gv))
- GvIOp(gv) = newIO();
return 0;
}
@@ -984,10 +1159,8 @@ magic_gettaint(sv,mg)
SV* sv;
MAGIC* mg;
{
- if (mg->mg_len & 1)
- tainted = TRUE;
- else if (mg->mg_len & 2 && mg->mg_obj == sv) /* kludge */
- tainted = TRUE;
+ TAINT_IF((mg->mg_len & 1) ||
+ (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */
return 0;
}
@@ -1019,6 +1192,97 @@ MAGIC* mg;
}
int
+magic_getdefelem(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ SV *targ = Nullsv;
+ if (LvTARGLEN(sv)) {
+ if (mg->mg_obj) {
+ HV* hv = (HV*)LvTARG(sv);
+ HE* he = hv_fetch_ent(hv, mg->mg_obj, FALSE, 0);
+ if (he)
+ targ = HeVAL(he);
+ }
+ else {
+ AV* av = (AV*)LvTARG(sv);
+ if ((I32)LvTARGOFF(sv) <= AvFILL(av))
+ targ = AvARRAY(av)[LvTARGOFF(sv)];
+ }
+ if (targ && targ != &sv_undef) {
+ /* 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 : &sv_undef);
+ return 0;
+}
+
+int
+magic_setdefelem(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ if (LvTARGLEN(sv))
+ vivify_defelem(sv);
+ if (LvTARG(sv)) {
+ sv_setsv(LvTARG(sv), sv);
+ SvSETMAGIC(LvTARG(sv));
+ }
+ return 0;
+}
+
+int
+magic_freedefelem(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ SvREFCNT_dec(LvTARG(sv));
+ return 0;
+}
+
+void
+vivify_defelem(sv)
+SV* sv;
+{
+ MAGIC* mg;
+ SV* value;
+
+ if (!LvTARGLEN(sv) || !(mg = mg_find(sv, 'y')))
+ return;
+ if (mg->mg_obj) {
+ HV* hv = (HV*)LvTARG(sv);
+ HE* he = hv_fetch_ent(hv, mg->mg_obj, TRUE, 0);
+ if (!he || (value = HeVAL(he)) == &sv_undef)
+ croak(no_helem, SvPV(mg->mg_obj, 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) == &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,mg)
SV* sv;
MAGIC* mg;
@@ -1039,6 +1303,16 @@ MAGIC* mg;
}
int
+magic_setfm(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ sv_unmagic(sv, 'f');
+ SvCOMPILED_off(sv);
+ return 0;
+}
+
+int
magic_setuvar(sv,mg)
SV* sv;
MAGIC* mg;
@@ -1050,6 +1324,25 @@ MAGIC* mg;
return 0;
}
+#ifdef USE_LOCALE_COLLATE
+int
+magic_setcollxfrm(sv,mg)
+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,mg)
SV* sv;
@@ -1070,7 +1363,8 @@ MAGIC* mg;
#ifdef VMS
set_vaxc_errno(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
#else
- SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),4); /* will anyone ever use this? */
+ /* will anyone ever use this? */
+ SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv), 4);
#endif
break;
case '\006': /* ^F */
@@ -1096,17 +1390,14 @@ MAGIC* mg;
osname = Nullch;
break;
case '\020': /* ^P */
- i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
- if (i != perldb) {
- if (perldb)
- oldlastpm = curpm;
- else
- curpm = oldlastpm;
- }
- perldb = i;
+ perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
break;
case '\024': /* ^T */
+#ifdef BIG_TIME
+ basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
+#else
basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+#endif
break;
case '\027': /* ^W */
dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
@@ -1116,7 +1407,7 @@ MAGIC* mg;
if (localizing == 1)
save_sptr((SV**)&last_in_gv);
}
- else if (SvOK(sv))
+ else if (SvOK(sv) && GvIO(last_in_gv))
IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
break;
case '^':
@@ -1141,9 +1432,18 @@ MAGIC* mg;
IoPAGE(GvIOp(defoutgv)) = (long)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
break;
case '|':
- IoFLAGS(GvIOp(defoutgv)) &= ~IOf_FLUSH;
- if ((SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) != 0) {
- IoFLAGS(GvIOp(defoutgv)) |= IOf_FLUSH;
+ {
+ IO *io = GvIOp(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 '*':
@@ -1159,7 +1459,12 @@ MAGIC* mg;
case '\\':
if (ors)
Safefree(ors);
- ors = savepv(SvPV(sv,orslen));
+ if (SvOK(sv) || SvGMAGICAL(sv))
+ ors = savepv(SvPV(sv,orslen));
+ else {
+ ors = Nullch;
+ orslen = 0;
+ }
break;
case ',':
if (ofs)
@@ -1175,10 +1480,23 @@ MAGIC* mg;
compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
break;
case '?':
- statusvalue = FIXSTATUS(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+#ifdef COMPLEX_STATUS
+ if (localizing == 2) {
+ statusvalue = LvTARGOFF(sv);
+ 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) : sv_2iv(sv),SvIV(sv) == EVMSERR ? 4 : vaxc$errno); /* will anyone ever use this? */
+ SETERRNO(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv),
+ (SvIV(sv) == EVMSERR) ? 4 : vaxc$errno);
break;
case '<':
uid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
@@ -1262,7 +1580,30 @@ MAGIC* mg;
tainting |= (uid && (euid != uid || egid != gid));
break;
case ')':
+#ifdef HAS_SETGROUPS
+ {
+ char *p = SvPV(sv, na);
+ Groups_t gary[NGROUPS];
+
+ SET_NUMERIC_STANDARD();
+ while (isSPACE(*p))
+ ++p;
+ 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 */
egid = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+#endif /* HAS_SETGROUPS */
if (delaymagic) {
delaymagic |= DM_EGID;
break; /* don't do magic till later */
@@ -1297,15 +1638,28 @@ MAGIC* mg;
s += strlen(s);
/* See if all the arguments are contiguous in memory */
for (i = 1; i < origargc; i++) {
- if (origargv[i] == s + 1)
+ if (origargv[i] == s + 1
+#ifdef OS2
+ || origargv[i] == s + 2
+#endif
+ )
s += strlen(++s); /* this one is ok too */
+ else
+ break;
}
- if (origenviron[0] == s + 1) { /* can grab env area too? */
- my_setenv("NoNeSuCh", Nullch);
+ /* can grab env area too? */
+ if (origenviron && (origenviron[0] == s + 1
+#ifdef OS2
+ || (origenviron[0] == s + 9 && (s += 8))
+#endif
+ )) {
+ my_setenv("NoNe SuCh", Nullch);
/* force copy of environment */
for (i = 0; origenviron[i]; i++)
if (origenviron[i] == s + 1)
s += strlen(++s);
+ else
+ break;
}
origalen = s - origargv[0];
}
@@ -1313,9 +1667,11 @@ MAGIC* mg;
i = len;
if (i >= origalen) {
i = origalen;
- SvCUR_set(sv, i);
- *SvEND(sv) = '\0';
+ /* don't allow system to limit $0 seen by script */
+ /* SvCUR_set(sv, i); *SvEND(sv) = '\0'; */
Copy(s, origargv[0], i, char);
+ s = origargv[0]+i;
+ *s = '\0';
}
else {
Copy(s, origargv[0], i, char);
@@ -1352,6 +1708,21 @@ char *sig;
return 0;
}
+static SV* sig_sv;
+
+static void
+unwind_handler_stack(p)
+ void *p;
+{
+ U32 flags = *(U32*)p;
+
+ if (flags & 1)
+ 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(sig)
int sig;
@@ -1359,44 +1730,76 @@ int sig;
dSP;
GV *gv;
HV *st;
- SV *sv;
+ SV *sv, *tSv = Sv;
CV *cv;
AV *oldstack;
- char *signame;
-
-#ifdef OS2 /* or anybody else who requires SIG_ACK */
- signal(sig, SIG_ACK);
-#endif
-
- signame = sig_name[sig];
- cv = sv_2cv(*hv_fetch(GvHVn(siggv),signame,strlen(signame),
- TRUE),
- &st, &gv, TRUE);
- if (!cv || !CvROOT(cv) &&
- *signame == 'C' && instr(signame,"LD")) {
-
- if (signame[1] == 'H')
- cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE),
- &st, &gv, TRUE);
- else
- cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE),
- &st, &gv, TRUE);
- /* gag */
+ OP *myop = op;
+ U32 flags = 0;
+ I32 o_save_i = savestack_ix, type;
+ CONTEXT *cx;
+ XPV *tXpv = Xpv;
+
+ if (savestack_ix + 15 <= savestack_max)
+ flags |= 1;
+ if (cxstack_ix < cxstack_max - 2)
+ flags |= 2;
+ if (markstack_ptr < markstack_max - 2)
+ flags |= 4;
+ if (retstack_ix < retstack_max - 2)
+ flags |= 8;
+ if (scopestack_ix < scopestack_max - 3)
+ flags |= 16;
+
+ if (flags & 2) { /* POPBLOCK may decrease cxstack too early. */
+ cxstack_ix++; /* Protect from overwrite. */
+ cx = &cxstack[cxstack_ix];
+ type = cx->cx_type; /* Can be during partial write. */
+ cx->cx_type = CXt_NULL; /* Make it safe for unwind. */
+ }
+ 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) {
+ savestack_ix += 5; /* Protect save in progress. */
+ o_save_i = savestack_ix;
+ SAVEDESTRUCTOR(unwind_handler_stack, (void*)&flags);
+ }
+ if (flags & 4)
+ markstack_ptr++; /* Protect mark. */
+ if (flags & 8) {
+ retstack_ix++;
+ retstack[retstack_ix] = NULL;
}
+ if (flags & 16)
+ 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 (dowarn)
warn("SIG%s handler \"%s\" not defined.\n",
- signame, GvENAME(gv) );
+ sig_name[sig], GvENAME(gv) );
return;
}
- oldstack = stack;
- if (stack != signalstack)
+ oldstack = curstack;
+ if (curstack != signalstack)
AvFILL(signalstack) = 0;
- SWITCHSTACK(stack, signalstack);
+ SWITCHSTACK(curstack, signalstack);
- sv = sv_newmortal();
- sv_setpv(sv,signame);
+ 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]);
+ }
PUSHMARK(sp);
PUSHs(sv);
PUTBACK;
@@ -1404,6 +1807,23 @@ int sig;
perl_call_sv((SV*)cv, G_DISCARD);
SWITCHSTACK(signalstack, oldstack);
-
+ if (flags & 1)
+ savestack_ix -= 8; /* Unprotect save in progress. */
+ if (flags & 2) {
+ cxstack[cxstack_ix].cx_type = type;
+ cxstack_ix -= 1;
+ }
+ if (flags & 4)
+ markstack_ptr--;
+ if (flags & 8)
+ retstack_ix--;
+ if (flags & 16)
+ scopestack_ix -= 1;
+ if (flags & 64)
+ SvREFCNT_dec(sv);
+ op = myop; /* Apparently not needed... */
+
+ Sv = tSv; /* Restore global temporaries. */
+ Xpv = tXpv;
return;
}
diff --git a/gnu/usr.bin/perl/mg.h b/gnu/usr.bin/perl/mg.h
index ab24eb03abb..c4647465572 100644
--- a/gnu/usr.bin/perl/mg.h
+++ b/gnu/usr.bin/perl/mg.h
@@ -1,6 +1,6 @@
/* mg.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -32,5 +32,10 @@ struct magic {
#define MGf_MINMATCH 1
-#define MgTAINTEDDIR(mg) (mg->mg_flags & MGf_TAINTEDDIR)
-#define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR)
+#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/gnu/usr.bin/perl/minimod.pl b/gnu/usr.bin/perl/minimod.pl
index b9b70715b20..82760ee63d0 100644
--- a/gnu/usr.bin/perl/minimod.pl
+++ b/gnu/usr.bin/perl/minimod.pl
@@ -40,7 +40,7 @@ $tail=<<'EOF!TAIL';
END
while (<MINI>) {
- print;
+ print unless /dXSUB_SYS/;
}
close MINI;
@@ -65,7 +65,9 @@ sub writemain{
my ($tail1,$tail2) = ( $tail =~ /\A(.*\n)(\s*\}.*)\Z/s );
print $tail1;
- print " char *file = __FILE__;\n";
+ print "\tchar *file = __FILE__;\n";
+ print "\tdXSUB_SYS;\n" if $] > 5.002;
+
foreach $_ (@exts){
my($pname) = canon('/', $_);
my($mname, $cname, $ccode);
diff --git a/gnu/usr.bin/perl/miniperlmain.c b/gnu/usr.bin/perl/miniperlmain.c
index bc81e997372..402f2ef065e 100644
--- a/gnu/usr.bin/perl/miniperlmain.c
+++ b/gnu/usr.bin/perl/miniperlmain.c
@@ -2,6 +2,10 @@
* "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
+
#ifdef __cplusplus
extern "C" {
#endif
@@ -33,20 +37,20 @@ char **env;
PERL_SYS_INIT(&argc,&argv);
- perl_init_i18nl14n(1);
+ perl_init_i18nl10n(1);
if (!do_undump) {
my_perl = perl_alloc();
if (!my_perl)
exit(1);
perl_construct( my_perl );
+ perl_destruct_level = 0;
}
exitstatus = perl_parse( my_perl, xs_init, argc, argv, (char **) NULL );
- if (exitstatus)
- exit( exitstatus );
-
- exitstatus = perl_run( my_perl );
+ if (!exitstatus) {
+ exitstatus = perl_run( my_perl );
+ }
perl_destruct( my_perl );
perl_free( my_perl );
diff --git a/gnu/usr.bin/perl/myconfig b/gnu/usr.bin/perl/myconfig
index 9038197aafa..86da2edce87 100644
--- a/gnu/usr.bin/perl/myconfig
+++ b/gnu/usr.bin/perl/myconfig
@@ -21,21 +21,23 @@ $spitshell <<!GROK!THIS!
Summary of my $package ($baserev patchlevel $PATCHLEVEL subversion $SUBVERSION) configuration:
Platform:
- osname=$osname, osver=$osvers, archname=$archname
+ osname=$osname, osvers=$osvers, archname=$archname
uname='$myuname'
hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction
+ bincompat3=$bincompat3 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
voidflags=$voidflags, castflags=$castflags, d_casti32=$d_casti32, d_castneg=$d_castneg
- intsize=$intsize, alignbytes=$alignbytes, usemymalloc=$usemymalloc, randbits=$randbits
+ intsize=$intsize, 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'
diff --git a/gnu/usr.bin/perl/nostdio.h b/gnu/usr.bin/perl/nostdio.h
new file mode 100644
index 00000000000..256a638c9a7
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/op.c b/gnu/usr.bin/perl/op.c
index d56ed9ad8d4..8e8811da934 100644
--- a/gnu/usr.bin/perl/op.c
+++ b/gnu/usr.bin/perl/op.c
@@ -1,6 +1,6 @@
/* op.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -26,8 +26,10 @@
* think the expression is of the right type: croak actually does a Siglongjmp.
*/
#define CHECKOP(type,op) \
- ((op_mask && op_mask[type]) \
- ? (croak("%s trapped by operation mask", op_desc[type]), (OP*)op) \
+ ((op_mask && op_mask[type]) \
+ ? ( op_free((OP*)op), \
+ croak("%s trapped by operation mask", op_desc[type]), \
+ Nullop ) \
: (*check[type])((OP*)op))
#else
#define CHECKOP(type,op) (*check[type])(op)
@@ -37,19 +39,20 @@ static I32 list_assignment _((OP *op));
static OP *bad_type _((I32 n, char *t, char *name, OP *kid));
static OP *modkids _((OP *op, I32 type));
static OP *no_fh_allowed _((OP *op));
+static bool scalar_mod_type _((OP *op, I32 type));
static OP *scalarboolean _((OP *op));
static OP *too_few_arguments _((OP *op, char* name));
static OP *too_many_arguments _((OP *op, char* name));
static void null _((OP* op));
-static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, I32 seq,
+static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
CV* startcv, I32 cx_ix));
static char*
-CvNAME(cv)
-CV* cv;
+gv_ename(gv)
+GV* gv;
{
SV* tmpsv = sv_newmortal();
- gv_efullname(tmpsv, CvGV(cv));
+ gv_efullname3(tmpsv, gv, Nullch);
return SvPV(tmpsv,na);
}
@@ -57,9 +60,8 @@ static OP *
no_fh_allowed(op)
OP *op;
{
- sprintf(tokenbuf,"Missing comma after first argument to %s function",
- op_desc[op->op_type]);
- yyerror(tokenbuf);
+ yyerror(form("Missing comma after first argument to %s function",
+ op_desc[op->op_type]));
return op;
}
@@ -68,8 +70,7 @@ too_few_arguments(op, name)
OP* op;
char* name;
{
- sprintf(tokenbuf,"Not enough arguments for %s", name);
- yyerror(tokenbuf);
+ yyerror(form("Not enough arguments for %s", name));
return op;
}
@@ -78,8 +79,7 @@ too_many_arguments(op, name)
OP *op;
char* name;
{
- sprintf(tokenbuf,"Too many arguments for %s", name);
- yyerror(tokenbuf);
+ yyerror(form("Too many arguments for %s", name));
return op;
}
@@ -90,9 +90,8 @@ char *t;
char *name;
OP *kid;
{
- sprintf(tokenbuf, "Type of arg %d to %s must be %s (not %s)",
- (int) n, name, t, op_desc[kid->op_type]);
- yyerror(tokenbuf);
+ yyerror(form("Type of arg %d to %s must be %s (not %s)",
+ (int)n, name, t, op_desc[kid->op_type]));
return op;
}
@@ -102,11 +101,10 @@ OP *op;
{
int type = op->op_type;
if (type != OP_AELEM && type != OP_HELEM) {
- sprintf(tokenbuf, "Can't use subscript on %s", op_desc[type]);
- yyerror(tokenbuf);
- if (type == OP_RV2HV || type == OP_ENTERSUB)
+ yyerror(form("Can't use subscript on %s", op_desc[type]));
+ if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV)
warn("(Did you mean $ or @ instead of %c?)\n",
- type == OP_RV2HV ? '%' : '&');
+ type == OP_ENTERSUB ? '&' : '%');
}
}
@@ -120,10 +118,26 @@ char *name;
SV *sv;
if (!(isALPHA(name[1]) || name[1] == '_' && (int)strlen(name) > 2)) {
- if (!isprint(name[1]))
- sprintf(name+1, "^%c", name[1] ^ 64); /* XXX is tokenbuf, really */
+ if (!isPRINT(name[1])) {
+ name[3] = '\0';
+ name[2] = toCTRL(name[1]);
+ name[1] = '^';
+ }
croak("Can't use global %s in \"my\"",name);
}
+ if (dowarn && AvFILL(comppad_name) >= 0) {
+ SV **svp = AvARRAY(comppad_name);
+ for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) {
+ if ((sv = svp[off])
+ && sv != &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);
@@ -147,11 +161,11 @@ static PADOFFSET
pad_findlex(name, newoff, seq, startcv, cx_ix)
char *name;
PADOFFSET newoff;
-I32 seq;
+U32 seq;
CV* startcv;
I32 cx_ix;
#else
-pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix)
+pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix)
#endif
{
CV *cv;
@@ -162,9 +176,10 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix)
int saweval;
for (cv = startcv; cv; cv = CvOUTSIDE(cv)) {
- AV* curlist = CvPADLIST(cv);
- SV** svp = av_fetch(curlist, 0, FALSE);
+ AV *curlist = CvPADLIST(cv);
+ SV **svp = av_fetch(curlist, 0, FALSE);
AV *curname;
+
if (!svp || *svp == &sv_undef)
continue;
curname = (AV*)*svp;
@@ -173,24 +188,63 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix)
if ((sv = svp[off]) &&
sv != &sv_undef &&
seq <= SvIVX(sv) &&
- seq > (I32)SvNVX(sv) &&
+ seq > I_32(SvNVX(sv)) &&
strEQ(SvPVX(sv), name))
{
- I32 depth = CvDEPTH(cv) ? CvDEPTH(cv) : 1;
- AV *oldpad = (AV*)*av_fetch(curlist, depth, FALSE);
- SV *oldsv = *av_fetch(oldpad, off, TRUE);
+ 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 *sv = NEWSV(1103,0);
+ SV *namesv = NEWSV(1103,0);
newoff = pad_alloc(OP_PADSV, SVs_PADMY);
- sv_upgrade(sv, SVt_PVNV);
- sv_setpv(sv, name);
- av_store(comppad_name, newoff, sv);
- SvNVX(sv) = (double)curcop->cop_seq;
- SvIVX(sv) = 999999999; /* A ref, intro immediately */
- SvFLAGS(sv) |= SVf_FAKE;
+ sv_upgrade(namesv, SVt_PVNV);
+ sv_setpv(namesv, name);
+ av_store(comppad_name, newoff, namesv);
+ SvNVX(namesv) = (double)curcop->cop_seq;
+ SvIVX(namesv) = 999999999; /* A ref, intro immediately */
+ SvFAKE_on(namesv); /* A ref, not a real var */
+ if (CvANON(compcv) || SvTYPE(compcv) == SVt_PVFM) {
+ /* "It's closures all the way down." */
+ CvCLONE_on(compcv);
+ if (cv == startcv) {
+ if (CvANON(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 (dowarn && !CvUNIQUE(cv))
+ warn(
+ "Variable \"%s\" may be unavailable",
+ name);
+ break;
+ }
+ }
+ }
+ }
+ else if (!CvUNIQUE(compcv)) {
+ if (dowarn && !SvFAKE(sv) && !CvUNIQUE(cv))
+ warn("Variable \"%s\" will not stay shared", name);
+ }
}
av_store(comppad, newoff, SvREFCNT_inc(oldsv));
- CvCLONE_on(compcv);
return newoff;
}
}
@@ -212,10 +266,14 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix)
}
break;
case CXt_EVAL:
- if (cx->blk_eval.old_op_type != OP_ENTEREVAL &&
- cx->blk_eval.old_op_type != OP_ENTERTRY)
- return 0; /* require must have its own scope */
- saweval = i;
+ 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)
@@ -238,26 +296,34 @@ pad_findmy(name)
char *name;
{
I32 off;
+ I32 pendoff = 0;
SV *sv;
SV **svp = AvARRAY(comppad_name);
- I32 seq = cop_seqmax;
+ U32 seq = cop_seqmax;
/* The one we're looking for is probably just before comppad_name_fill. */
for (off = AvFILL(comppad_name); off > 0; off--) {
if ((sv = svp[off]) &&
sv != &sv_undef &&
- seq <= SvIVX(sv) &&
- seq > (I32)SvNVX(sv) &&
+ (!SvIVX(sv) ||
+ (seq <= SvIVX(sv) &&
+ seq > I_32(SvNVX(sv)))) &&
strEQ(SvPVX(sv), name))
{
- return (PADOFFSET)off;
+ 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(compcv), cxstack_ix);
- if (off)
+ if (off) {
+ /* If there is a pending local definition, this new alias must die */
+ if (pendoff)
+ SvIVX(AvARRAY(comppad_name)[off]) = seq;
return off;
+ }
return 0;
}
@@ -301,14 +367,26 @@ U32 tmptype;
retval = AvFILL(comppad);
}
else {
- do {
- sv = *av_fetch(comppad, ++padix, TRUE);
- } while (SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY));
+ SV **names = AvARRAY(comppad_name);
+ SSize_t names_fill = AvFILL(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 (++padix <= names_fill &&
+ (sv = names[padix]) && sv != &sv_undef)
+ continue;
+ sv = *av_fetch(comppad, padix, TRUE);
+ if (!(SvFLAGS(sv) & (SVs_PADTMP|SVs_PADMY)))
+ break;
+ }
retval = padix;
}
SvFLAGS(sv) |= tmptype;
curpad = AvARRAY(comppad);
- DEBUG_X(fprintf(stderr, "Pad alloc %ld for %s\n", (long) retval, op_name[optype]));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad alloc %ld for %s\n", (long) retval, op_name[optype]));
return (PADOFFSET)retval;
}
@@ -322,7 +400,7 @@ pad_sv(PADOFFSET po)
{
if (!po)
croak("panic: pad_sv po");
- DEBUG_X(fprintf(stderr, "Pad sv %d\n", po));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %lu\n", (unsigned long)po));
return curpad[po]; /* eventually we'll turn this into a macro */
}
@@ -340,8 +418,8 @@ pad_free(PADOFFSET po)
croak("panic: pad_free curpad");
if (!po)
croak("panic: pad_free po");
- DEBUG_X(fprintf(stderr, "Pad free %d\n", po));
- if (curpad[po] && curpad[po] != &sv_undef)
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %lu\n", (unsigned long)po));
+ if (curpad[po] && !SvIMMORTAL(curpad[po]))
SvPADTMP_off(curpad[po]);
if ((I32)po < padix)
padix = po - 1;
@@ -359,7 +437,7 @@ pad_swipe(PADOFFSET po)
croak("panic: pad_swipe curpad");
if (!po)
croak("panic: pad_swipe po");
- DEBUG_X(fprintf(stderr, "Pad swipe %d\n", po));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %lu\n", (unsigned long)po));
SvPADTMP_off(curpad[po]);
curpad[po] = NEWSV(1107,0);
SvPADTMP_on(curpad[po]);
@@ -374,10 +452,10 @@ pad_reset()
if (AvARRAY(comppad) != curpad)
croak("panic: pad_reset curpad");
- DEBUG_X(fprintf(stderr, "Pad reset\n"));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad reset\n"));
if (!tainting) { /* Can't mix tainted and non-tainted temporaries. */
for (po = AvMAX(comppad); po > padix_floor; po--) {
- if (curpad[po] && curpad[po] != &sv_undef)
+ if (curpad[po] && !SvIMMORTAL(curpad[po]))
SvPADTMP_off(curpad[po]);
}
padix = padix_floor;
@@ -393,7 +471,7 @@ OP *op;
{
register OP *kid, *nextkid;
- if (!op)
+ if (!op || op->op_seq == (U16)-1)
return;
if (op->op_flags & OPf_KIDS) {
@@ -410,12 +488,18 @@ OP *op;
case OP_ENTEREVAL:
op->op_targ = 0; /* Was holding hints. */
break;
+ default:
+ if (!(op->op_flags & OPf_REF) || (check[op->op_type] != ck_ftst))
+ break;
+ /* FALL THROUGH */
case OP_GVSV:
case OP_GV:
+ case OP_AELEMFAST:
SvREFCNT_dec(cGVOP->op_gv);
break;
case OP_NEXTSTATE:
case OP_DBSTATE:
+ Safefree(cCOP->cop_label);
SvREFCNT_dec(cCOP->cop_filegv);
break;
case OP_CONST:
@@ -439,8 +523,6 @@ OP *op;
pregfree(cPMOP->op_pmregexp);
SvREFCNT_dec(cPMOP->op_pmshort);
break;
- default:
- break;
}
if (op->op_targ > 0)
@@ -524,11 +606,11 @@ OP *op;
OP *kid;
/* assumes no premature commitment */
- if (!op || (op->op_flags & OPf_KNOW) || error_count)
+ if (!op || (op->op_flags & OPf_WANT) || error_count
+ || op->op_type == OP_RETURN)
return op;
- op->op_flags &= ~OPf_LIST;
- op->op_flags |= OPf_KNOW;
+ op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_SCALAR;
switch (op->op_type) {
case OP_REPEAT:
@@ -559,8 +641,16 @@ OP *op;
break;
case OP_LEAVE:
case OP_LEAVETRY:
- scalar(cLISTOP->op_first);
- /* FALL THROUGH */
+ kid = cLISTOP->op_first;
+ scalar(kid);
+ while (kid = kid->op_sibling) {
+ if (kid->op_sibling)
+ scalarvoid(kid);
+ else
+ scalar(kid);
+ }
+ curcop = &compiling;
+ break;
case OP_SCOPE:
case OP_LINESEQ:
case OP_LIST:
@@ -584,17 +674,19 @@ OP *op;
char* useless = 0;
SV* sv;
- if (!op || error_count)
- return op;
- if (op->op_flags & OPf_LIST)
+ /* assumes no premature commitment */
+ if (!op || (op->op_flags & OPf_WANT) == OPf_WANT_LIST || error_count
+ || op->op_type == OP_RETURN)
return op;
- op->op_flags |= OPf_KNOW;
+ op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_VOID;
switch (op->op_type) {
default:
if (!(opargs[op->op_type] & OA_FOLDCONST))
break;
+ /* FALL THROUGH */
+ case OP_REPEAT:
if (op->op_flags & OPf_STACKED)
break;
/* FALL THROUGH */
@@ -621,8 +713,6 @@ OP *op;
case OP_AELEM:
case OP_AELEMFAST:
case OP_ASLICE:
- case OP_VALUES:
- case OP_KEYS:
case OP_HELEM:
case OP_HSLICE:
case OP_UNPACK:
@@ -713,46 +803,47 @@ OP *op;
op->op_ppaddr = ppaddr[OP_PREDEC];
break;
- case OP_REPEAT:
- scalarvoid(cBINOP->op_first);
- useless = op_desc[op->op_type];
- break;
-
case OP_OR:
case OP_AND:
case OP_COND_EXPR:
for (kid = cUNOP->op_first->op_sibling; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
+
case OP_NULL:
if (op->op_targ == OP_NEXTSTATE || op->op_targ == OP_DBSTATE)
curcop = ((COP*)op); /* for warning below */
if (op->op_flags & OPf_STACKED)
break;
+ /* FALL THROUGH */
case OP_ENTERTRY:
case OP_ENTER:
case OP_SCALAR:
if (!(op->op_flags & OPf_KIDS))
break;
+ /* FALL THROUGH */
case OP_SCOPE:
case OP_LEAVE:
case OP_LEAVETRY:
case OP_LEAVELOOP:
- op->op_private |= OPpLEAVE_VOID;
case OP_LINESEQ:
case OP_LIST:
for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
+ case OP_ENTEREVAL:
+ scalarkids(op);
+ break;
+ case OP_REQUIRE:
+ /* all requires must return a boolean value */
+ op->op_flags &= ~OPf_WANT;
+ return scalar(op);
case OP_SPLIT:
if ((kid = ((LISTOP*)op)->op_first) && kid->op_type == OP_PUSHRE) {
if (!kPMOP->op_pmreplroot)
deprecate("implicit split to @_");
}
break;
- case OP_DELETE:
- op->op_private |= OPpLEAVE_VOID;
- break;
}
if (useless && dowarn)
warn("Useless use of %s in void context", useless);
@@ -778,10 +869,11 @@ OP *op;
OP *kid;
/* assumes no premature commitment */
- if (!op || (op->op_flags & OPf_KNOW) || error_count)
+ if (!op || (op->op_flags & OPf_WANT) || error_count
+ || op->op_type == OP_RETURN)
return op;
- op->op_flags |= (OPf_KNOW | OPf_LIST);
+ op->op_flags = (op->op_flags & ~OPf_WANT) | OPf_WANT_LIST;
switch (op->op_type) {
case OP_FLOP:
@@ -809,8 +901,16 @@ OP *op;
break;
case OP_LEAVE:
case OP_LEAVETRY:
- list(cLISTOP->op_first);
- /* FALL THROUGH */
+ kid = cLISTOP->op_first;
+ list(kid);
+ while (kid = kid->op_sibling) {
+ if (kid->op_sibling)
+ scalarvoid(kid);
+ else
+ list(kid);
+ }
+ curcop = &compiling;
+ break;
case OP_SCOPE:
case OP_LINESEQ:
for (kid = cLISTOP->op_first; kid; kid = kid->op_sibling) {
@@ -821,6 +921,10 @@ OP *op;
}
curcop = &compiling;
break;
+ case OP_REQUIRE:
+ /* all requires must return a boolean value */
+ op->op_flags &= ~OPf_WANT;
+ return scalar(op);
}
return op;
}
@@ -875,12 +979,14 @@ I32 type;
{
OP *kid;
SV *sv;
- char mtype;
if (!op || error_count)
return op;
switch (op->op_type) {
+ case OP_UNDEF:
+ modcount++;
+ return op;
case OP_CONST:
if (!(op->op_private & (OPpCONST_ARYBASE)))
goto nomod;
@@ -897,6 +1003,10 @@ I32 type;
else
croak("That use of $[ is unsupported");
break;
+ case OP_STUB:
+ if (op->op_flags & OPf_PARENS)
+ break;
+ goto nomod;
case OP_ENTERSUB:
if ((type == OP_UNDEF || type == OP_REFGEN) &&
!(op->op_flags & OPf_STACKED)) {
@@ -912,10 +1022,9 @@ I32 type;
/* grep, foreach, subcalls, refgen */
if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
break;
- sprintf(tokenbuf, "Can't modify %s in %s",
- op_desc[op->op_type],
- type ? op_desc[type] : "local");
- yyerror(tokenbuf);
+ yyerror(form("Can't modify %s in %s",
+ op_desc[op->op_type],
+ type ? op_desc[type] : "local"));
return op;
case OP_PREINC:
@@ -950,12 +1059,16 @@ I32 type;
case OP_RV2AV:
case OP_RV2HV:
+ if (!type && cUNOP->op_first->op_type != OP_GV)
+ croak("Can't localize through a reference");
if (type == OP_REFGEN && op->op_flags & OPf_PARENS) {
modcount = 10000;
return op; /* Treat \(@foo) like ordinary list. */
}
/* FALL THROUGH */
case OP_RV2GV:
+ if (scalar_mod_type(op, type))
+ goto nomod;
ref(cUNOP->op_first, op->op_type);
/* FALL THROUGH */
case OP_AASSIGN:
@@ -969,10 +1082,9 @@ I32 type;
break;
case OP_RV2SV:
if (!type && cUNOP->op_first->op_type != OP_GV)
- croak("Can't localize a reference");
+ croak("Can't localize through a reference");
ref(cUNOP->op_first, op->op_type);
/* FALL THROUGH */
- case OP_UNDEF:
case OP_GV:
case OP_AV2ARYLEN:
case OP_SASSIGN:
@@ -983,6 +1095,10 @@ I32 type;
case OP_PADAV:
case OP_PADHV:
modcount = 10000;
+ if (type == OP_REFGEN && op->op_flags & OPf_PARENS)
+ return op; /* Treat \(@foo) like ordinary list. */
+ if (scalar_mod_type(op, type))
+ goto nomod;
/* FALL THROUGH */
case OP_PADSV:
modcount++;
@@ -994,21 +1110,16 @@ I32 type;
case OP_PUSHMARK:
break;
+ case OP_KEYS:
+ if (type != OP_SASSIGN)
+ goto nomod;
+ /* FALL THROUGH */
case OP_POS:
- mtype = '.';
- goto makelv;
case OP_VEC:
- mtype = 'v';
- goto makelv;
case OP_SUBSTR:
- mtype = 'x';
- makelv:
pad_free(op->op_targ);
op->op_targ = pad_alloc(op->op_type, SVs_PADMY);
- sv = PAD_SV(op->op_targ);
- sv_upgrade(sv, SVt_PVLV);
- sv_magic(sv, Nullsv, mtype, Nullch, 0);
- curpad[op->op_targ] = sv;
+ assert(SvTYPE(PAD_SV(op->op_targ)) == SVt_NULL);
if (op->op_flags & OPf_KIDS)
mod(cBINOP->op_first->op_sibling, type);
break;
@@ -1016,6 +1127,9 @@ I32 type;
case OP_AELEM:
case OP_HELEM:
ref(cBINOP->op_first, op->op_type);
+ if (type == OP_ENTERSUB &&
+ !(op->op_private & (OPpLVAL_INTRO | OPpDEREF)))
+ op->op_private |= OPpLVAL_DEFER;
modcount++;
break;
@@ -1052,6 +1166,52 @@ I32 type;
return op;
}
+static bool
+scalar_mod_type(op, type)
+OP *op;
+I32 type;
+{
+ switch (type) {
+ case OP_SASSIGN:
+ if (op->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_ANDASSIGN: /* may work later */
+ case OP_ORASSIGN: /* may work later */
+ return TRUE;
+ default:
+ return FALSE;
+ }
+}
+
OP *
refkids(op, type)
OP *op;
@@ -1095,8 +1255,10 @@ I32 type;
ref(cUNOP->op_first, op->op_type);
/* FALL THROUGH */
case OP_PADSV:
- if (type == OP_RV2AV || type == OP_RV2HV) {
- op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV);
+ if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
+ op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
op->op_flags |= OPf_MOD;
}
break;
@@ -1123,8 +1285,10 @@ I32 type;
case OP_AELEM:
case OP_HELEM:
ref(cBINOP->op_first, op->op_type);
- if (type == OP_RV2AV || type == OP_RV2HV) {
- op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV : OPpDEREF_HV);
+ if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
+ op->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
+ : type == OP_RV2HV ? OPpDEREF_HV
+ : OPpDEREF_SV);
op->op_flags |= OPf_MOD;
}
break;
@@ -1164,8 +1328,7 @@ OP *op;
type != OP_PADHV &&
type != OP_PUSHMARK)
{
- sprintf(tokenbuf, "Can't declare %s in my", op_desc[op->op_type]);
- yyerror(tokenbuf);
+ yyerror(form("Can't declare %s in my", op_desc[op->op_type]));
return op;
}
op->op_flags |= OPf_MOD;
@@ -1190,6 +1353,20 @@ OP *right;
{
OP *op;
+ if (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) {
@@ -1224,7 +1401,7 @@ scope(o)
OP *o;
{
if (o) {
- if (o->op_flags & OPf_PARENS || perldb || tainting) {
+ if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || tainting) {
o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
o->op_type = OP_LEAVE;
o->op_ppaddr = ppaddr[OP_LEAVE];
@@ -1248,37 +1425,42 @@ OP *o;
}
int
-block_start()
+block_start(full)
+int full;
{
int retval = savestack_ix;
- comppad_name_fill = AvFILL(comppad_name);
- SAVEINT(min_intro_pending);
- SAVEINT(max_intro_pending);
+ SAVEI32(comppad_name_floor);
+ if (full) {
+ if ((comppad_name_fill = AvFILL(comppad_name)) > 0)
+ comppad_name_floor = comppad_name_fill;
+ else
+ comppad_name_floor = 0;
+ }
+ SAVEI32(min_intro_pending);
+ SAVEI32(max_intro_pending);
min_intro_pending = 0;
- SAVEINT(comppad_name_fill);
- SAVEINT(padix_floor);
+ SAVEI32(comppad_name_fill);
+ SAVEI32(padix_floor);
padix_floor = padix;
pad_reset_pending = FALSE;
- SAVEINT(hints);
+ SAVEI32(hints);
hints &= ~HINT_BLOCK_SCOPE;
return retval;
}
OP*
-block_end(line, floor, seq)
-int line;
-int floor;
+block_end(floor, seq)
+I32 floor;
OP* seq;
{
int needblockscope = hints & HINT_BLOCK_SCOPE;
OP* retval = scalarseq(seq);
- if (copline > (line_t)line)
- copline = line;
LEAVE_SCOPE(floor);
pad_reset_pending = FALSE;
if (needblockscope)
hints |= HINT_BLOCK_SCOPE; /* propagate out */
pad_leavemy(comppad_name_fill);
+ cop_seqmax++;
return retval;
}
@@ -1287,23 +1469,32 @@ newPROG(op)
OP *op;
{
if (in_eval) {
- eval_root = newUNOP(OP_LEAVEEVAL, 0, op);
+ eval_root = newUNOP(OP_LEAVEEVAL, ((in_eval & 4) ? OPf_SPECIAL : 0), op);
eval_start = linklist(eval_root);
eval_root->op_next = 0;
peep(eval_start);
}
else {
- if (!op) {
- main_start = 0;
+ if (!op)
return;
- }
main_root = scope(sawparens(scalarvoid(op)));
curcop = &compiling;
main_start = LINKLIST(main_root);
main_root->op_next = 0;
peep(main_start);
- main_cv = compcv;
compcv = 0;
+
+ /* Register with debugger */
+ if (PERLDB_INTER) {
+ CV *cv = perl_get_cv("DB::postponed", FALSE);
+ if (cv) {
+ dSP;
+ PUSHMARK(sp);
+ XPUSHs((SV*)compiling.cop_filegv);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
+ }
}
}
@@ -1362,6 +1553,16 @@ register OP *o;
if (!(opargs[type] & OA_FOLDCONST))
goto nope;
+ switch (type) {
+ case OP_SPRINTF:
+ case OP_UCFIRST:
+ case OP_LCFIRST:
+ case OP_UC:
+ case OP_LC:
+ if (o->op_private & OPpLOCALE)
+ goto nope;
+ }
+
if (error_count)
goto nope; /* Don't try to run w/ errors */
@@ -1388,7 +1589,7 @@ register OP *o;
}
op_free(o);
if (type == OP_RV2GV)
- return newGVOP(OP_GV, 0, sv);
+ return newGVOP(OP_GV, 0, (GV*)sv);
else {
if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) {
IV iv = SvIV(sv);
@@ -1396,6 +1597,8 @@ register OP *o;
SvREFCNT_dec(sv);
sv = newSViv(iv);
}
+ else
+ SvIOK_off(sv); /* undo SvIV() damage */
}
return newSVOP(OP_CONST, 0, sv);
}
@@ -1405,34 +1608,17 @@ register OP *o;
return o;
if (!(hints & HINT_INTEGER)) {
- int vars = 0;
-
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)) {
- if (SvIVX(((SVOP*)curop)->op_sv) <= 0 && vars++)
- return o; /* negatives truncate wrong way, alas */
+ if (SvIOK(((SVOP*)curop)->op_sv))
continue;
- }
return o;
}
if (opargs[curop->op_type] & OA_RETINTEGER)
continue;
- if (curop->op_type == OP_PADSV || curop->op_type == OP_RV2SV) {
- if (vars++)
- return o;
- if (((o->op_type == OP_LT || o->op_type == OP_GE) &&
- curop == ((BINOP*)o)->op_first ) ||
- ((o->op_type == OP_GT || o->op_type == OP_LE) &&
- curop == ((BINOP*)o)->op_last ))
- {
- /* Allow "$i < 100" and variants to integerize */
- continue;
- }
- }
return o;
}
o->op_ppaddr = ppaddr[++(o->op_type)];
@@ -1481,7 +1667,7 @@ OP* op;
if (!op || op->op_type != OP_LIST)
op = newLISTOP(OP_LIST, 0, op, Nullop);
else
- op->op_flags &= ~(OPf_KNOW|OPf_LIST);
+ op->op_flags &= ~OPf_WANT;
if (!(opargs[type] & OA_MARK))
null(cLISTOP->op_first);
@@ -1811,6 +1997,9 @@ I32 flags;
pmop->op_flags = flags;
pmop->op_private = 0 | (flags >> 8);
+ if (hints & HINT_LOCALE)
+ pmop->op_pmpermflags = (pmop->op_pmflags |= PMf_LOCALE);
+
/* link into pm list */
if (type != OP_TRANS && curstash) {
pmop->op_pmnext = HvPMROOT(curstash);
@@ -1832,6 +2021,7 @@ OP *repl;
if (op->op_type == OP_TRANS)
return pmtrans(op, expr, repl);
+ hints |= HINT_BLOCK_SCOPE;
pm = (PMOP*)op;
if (expr->op_type == OP_CONST) {
@@ -2011,7 +2201,7 @@ OP *op;
char *name;
sv = cSVOP->op_sv;
name = SvPV(sv, len);
- curstash = gv_stashpv(name,TRUE);
+ curstash = gv_stashpvn(name,len,TRUE);
sv_setpvn(curstname, name, len);
op_free(op);
}
@@ -2024,9 +2214,10 @@ OP *op;
}
void
-utilize(aver, floor, id, arg)
+utilize(aver, floor, version, id, arg)
int aver;
I32 floor;
+OP *version;
OP *id;
OP *arg;
{
@@ -2034,17 +2225,47 @@ OP *arg;
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)
@@ -2064,7 +2285,9 @@ OP *arg;
newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)),
Nullop,
append_elem(OP_LINESEQ,
- newSTATEOP(0, Nullch, rqop),
+ append_elem(OP_LINESEQ,
+ newSTATEOP(0, Nullch, rqop),
+ newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
copline = NOLINE;
@@ -2212,7 +2435,7 @@ OP *right;
tmpop->op_sibling = Nullop; /* don't free split */
right->op_next = tmpop->op_next; /* fix starting loc */
op_free(op); /* blow off assign */
- right->op_flags &= ~(OPf_KNOW|OPf_LIST);
+ right->op_flags &= ~OPf_WANT;
/* "I don't know and I don't care." */
return right;
}
@@ -2256,25 +2479,11 @@ I32 flags;
char *label;
OP *op;
{
+ U32 seq = intro_my();
register COP *cop;
- /* Introduce my variables. */
- if (min_intro_pending) {
- SV **svp = AvARRAY(comppad_name);
- I32 i;
- SV *sv;
- for (i = min_intro_pending; i <= max_intro_pending; i++) {
- if ((sv = svp[i]) && sv != &sv_undef && !SvIVX(sv)) {
- SvIVX(sv) = 999999999; /* Don't know scope end yet. */
- SvNVX(sv) = (double)cop_seqmax;
- }
- }
- min_intro_pending = 0;
- comppad_name_fill = max_intro_pending; /* Needn't search higher */
- }
-
Newz(1101, cop, 1, COP);
- if (perldb && curcop->cop_line && curstash != debstash) {
+ if (PERLDB_LINE && curcop->cop_line && curstash != debstash) {
cop->op_type = OP_DBSTATE;
cop->op_ppaddr = ppaddr[ OP_DBSTATE ];
}
@@ -2284,13 +2493,16 @@ OP *op;
}
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;
hints |= HINT_BLOCK_SCOPE;
}
- cop->cop_seq = cop_seqmax++;
+ cop->cop_seq = seq;
cop->cop_arybase = curcop->cop_arybase;
if (copline == NOLINE)
@@ -2299,10 +2511,10 @@ OP *op;
cop->cop_line = copline;
copline = NOLINE;
}
- cop->cop_filegv = SvREFCNT_inc(curcop->cop_filegv);
+ cop->cop_filegv = (GV*)SvREFCNT_inc(curcop->cop_filegv);
cop->cop_stash = curstash;
- if (perldb && curstash != debstash) {
+ if (PERLDB_LINE && curstash != debstash) {
SV **svp = av_fetch(GvAV(curcop->cop_filegv),(I32)cop->cop_line, FALSE);
if (svp && *svp != &sv_undef && !SvIOK(*svp)) {
(void)SvIOK_on(*svp);
@@ -2314,6 +2526,29 @@ OP *op;
return prepend_elem(OP_LINESEQ, (OP*)cop, op);
}
+/* "Introduce" my variables to visible status. */
+U32
+intro_my()
+{
+ SV **svp;
+ SV *sv;
+ I32 i;
+
+ if (! min_intro_pending)
+ return cop_seqmax;
+
+ svp = AvARRAY(comppad_name);
+ for (i = min_intro_pending; i <= max_intro_pending; i++) {
+ if ((sv = svp[i]) && sv != &sv_undef && !SvIVX(sv)) {
+ SvIVX(sv) = 999999999; /* Don't know scope end yet. */
+ SvNVX(sv) = (double)cop_seqmax;
+ }
+ }
+ min_intro_pending = 0;
+ comppad_name_fill = max_intro_pending; /* Needn't search higher */
+ return cop_seqmax++;
+}
+
OP *
newLOGOP(type, flags, first, other)
I32 type;
@@ -2361,6 +2596,36 @@ OP* other;
else
scalar(other);
}
+ else if (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_type == OP_RV2SV || k1->op_type == OP_PADSV))
+ 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 = curcop->cop_line;
+ curcop->cop_line = copline;
+ warn("Value of %s%s can be \"0\"; test with defined()",
+ op_desc[warnop],
+ ((warnop == OP_READLINE || warnop == OP_GLOB)
+ ? " construct" : "() operator"));
+ curcop->cop_line = oldline;
+ }
+ }
if (!other)
return first;
@@ -2389,36 +2654,36 @@ OP* other;
}
OP *
-newCONDOP(flags, first, true, false)
+newCONDOP(flags, first, trueop, falseop)
I32 flags;
OP* first;
-OP* true;
-OP* false;
+OP* trueop;
+OP* falseop;
{
CONDOP *condop;
OP *op;
- if (!false)
- return newLOGOP(OP_AND, 0, first, true);
- if (!true)
- return newLOGOP(OP_OR, 0, first, false);
+ 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(false);
- return true;
+ op_free(falseop);
+ return trueop;
}
else {
op_free(first);
- op_free(true);
- return false;
+ op_free(trueop);
+ return falseop;
}
}
else if (first->op_type == OP_WANTARRAY) {
- list(true);
- scalar(false);
+ list(trueop);
+ scalar(falseop);
}
Newz(1101, condop, 1, CONDOP);
@@ -2426,20 +2691,20 @@ OP* false;
condop->op_ppaddr = ppaddr[OP_COND_EXPR];
condop->op_first = first;
condop->op_flags = flags | OPf_KIDS;
- condop->op_true = LINKLIST(true);
- condop->op_false = LINKLIST(false);
+ 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 = true;
- true->op_sibling = false;
+ first->op_sibling = trueop;
+ trueop->op_sibling = falseop;
op = newUNOP(OP_NULL, 0, (OP*)condop);
- true->op_next = op;
- false->op_next = op;
+ trueop->op_next = op;
+ falseop->op_next = op;
return op;
}
@@ -2506,8 +2771,11 @@ OP *block;
if (expr) {
if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
return block; /* do {} while 0 does once */
- else if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)
- expr = newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr);
+ 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, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) );
+ }
}
listop = append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
@@ -2528,10 +2796,11 @@ OP *block;
}
OP *
-newWHILEOP(flags, debuggable, loop, expr, block, cont)
+newWHILEOP(flags, debuggable, loop, whileline, expr, block, cont)
I32 flags;
I32 debuggable;
LOOP *loop;
+I32 whileline;
OP *expr;
OP *block;
OP *cont;
@@ -2542,7 +2811,8 @@ OP *cont;
OP *op;
OP *condop;
- if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) {
+ 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, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) );
}
@@ -2552,8 +2822,14 @@ OP *cont;
if (cont)
next = LINKLIST(cont);
- if (expr)
+ if (expr) {
cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0));
+ if ((line_t)whileline != NOLINE) {
+ copline = whileline;
+ cont = append_elem(OP_LINESEQ, cont,
+ newSTATEOP(0, Nullch, Nullop));
+ }
+ }
listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
redo = LINKLIST(listop);
@@ -2611,10 +2887,10 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont
#endif /* CAN_PROTOTYPE */
{
LOOP *loop;
+ OP *wop;
int padoff = 0;
I32 iterflags = 0;
- copline = forline;
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
sv->op_type = OP_RV2GV;
@@ -2631,7 +2907,7 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont
else {
sv = newGVOP(OP_GV, 0, defgv);
}
- if (expr->op_type == OP_RV2AV) {
+ if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
expr = scalar(ref(expr, OP_ITER));
iterflags |= OPf_STACKED;
}
@@ -2641,8 +2917,9 @@ newFOROP(I32 flags,char *label,line_t forline,OP *sv,OP *expr,OP *block,OP *cont
assert(!loop->op_next);
Renew(loop, 1, LOOP);
loop->op_targ = padoff;
- return newSTATEOP(0, label, newWHILEOP(flags, 1, loop,
- newOP(OP_ITER, 0), block, cont));
+ wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
+ copline = forline;
+ return newSTATEOP(0, label, wop);
}
OP*
@@ -2684,60 +2961,135 @@ CV *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)) {
- I32 i = AvFILL(CvPADLIST(cv));
- while (i >= 0) {
- SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
- if (svp)
- SvREFCNT_dec(*svp);
+ /* may be during global destruction */
+ if (SvREFCNT(CvPADLIST(cv))) {
+ I32 i = AvFILL(CvPADLIST(cv));
+ while (i >= 0) {
+ SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
+ SV* sv = svp ? *svp : Nullsv;
+ if (!sv)
+ continue;
+ if (sv == (SV*)comppad_name)
+ comppad_name = Nullav;
+ else if (sv == (SV*)comppad) {
+ comppad = Nullav;
+ curpad = Null(SV**);
+ }
+ SvREFCNT_dec(sv);
+ }
+ SvREFCNT_dec((SV*)CvPADLIST(cv));
}
- SvREFCNT_dec((SV*)CvPADLIST(cv));
CvPADLIST(cv) = Nullav;
}
}
-CV *
-cv_clone(proto)
+#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 == main_cv) ? "MAIN"
+ : CvUNIQUE(outside) ? "UNIQUE"
+ : CvGV(cv) ? GvNAME(CvGV(cv)) : "UNDEFINED"),
+ outside,
+ (!outside ? "null"
+ : CvANON(outside) ? "ANON"
+ : (outside == 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 <= AvFILL(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(proto, outside)
CV* proto;
+CV* outside;
{
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** svp = AvARRAY(protopad);
+ SV** pname = AvARRAY(protopad_name);
+ SV** ppad = AvARRAY(protopad);
+ I32 fname = AvFILL(protopad_name);
+ I32 fpad = AvFILL(protopad);
AV* comppadlist;
CV* cv;
+ assert(!CvUNIQUE(proto));
+
ENTER;
SAVESPTR(curpad);
SAVESPTR(comppad);
+ SAVESPTR(comppad_name);
SAVESPTR(compcv);
cv = compcv = (CV*)NEWSV(1104,0);
- sv_upgrade((SV *)cv, SVt_PVCV);
+ sv_upgrade((SV *)cv, SvTYPE(proto));
CvCLONED_on(cv);
+ if (CvANON(proto))
+ CvANON_on(cv);
CvFILEGV(cv) = CvFILEGV(proto);
- CvGV(cv) = SvREFCNT_inc(CvGV(proto));
+ CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
CvSTASH(cv) = CvSTASH(proto);
CvROOT(cv) = CvROOT(proto);
CvSTART(cv) = CvSTART(proto);
- if (CvOUTSIDE(proto))
- CvOUTSIDE(cv) = (CV*)SvREFCNT_inc((SV*)CvOUTSIDE(proto));
+ if (outside)
+ CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
+
+ if (SvPOK(proto))
+ sv_setpvn((SV*)cv, SvPVX(proto), SvCUR(proto));
+
+ comppad_name = newAV();
+ for (ix = fname; ix >= 0; ix--)
+ av_store(comppad_name, ix, SvREFCNT_inc(pname[ix]));
comppad = newAV();
comppadlist = newAV();
AvREAL_off(comppadlist);
- av_store(comppadlist, 0, SvREFCNT_inc((SV*)protopad_name));
+ av_store(comppadlist, 0, (SV*)comppad_name);
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(cv) = comppadlist;
- av_extend(comppad, AvFILL(protopad));
+ av_fill(comppad, AvFILL(protopad));
curpad = AvARRAY(comppad);
av = newAV(); /* will be @_ */
@@ -2745,70 +3097,190 @@ CV* proto;
av_store(comppad, 0, (SV*)av);
AvFLAGS(av) = AVf_REIFY;
- svp = AvARRAY(protopad_name);
- for ( ix = AvFILL(protopad); ix > 0; ix--) {
- SV *sv;
- if (svp[ix] != &sv_undef) {
- char *name = SvPVX(svp[ix]); /* XXX */
- if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* lexical from outside? */
- I32 off = pad_findlex(name,ix,curcop->cop_seq, CvOUTSIDE(proto),
- cxstack_ix);
- if (off != ix)
+ for (ix = fpad; ix > 0; ix--) {
+ SV* namesv = (ix <= fname) ? pname[ix] : Nullsv;
+ if (namesv && namesv != &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)
+ curpad[ix] = SvREFCNT_inc(ppad[ix]);
+ else if (off != ix)
croak("panic: cv_clone: %s", name);
}
else { /* our own lexical */
- if (*name == '@')
- av_store(comppad, ix, sv = (SV*)newAV());
+ 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 == '%')
- av_store(comppad, ix, sv = (SV*)newHV());
+ sv = (SV*)newHV();
else
- av_store(comppad, ix, sv = NEWSV(0,0));
- SvPADMY_on(sv);
+ sv = NEWSV(0,0);
+ if (!SvPADBUSY(sv))
+ SvPADMY_on(sv);
+ curpad[ix] = sv;
}
}
else {
- av_store(comppad, ix, sv = NEWSV(0,0));
+ SV* sv = NEWSV(0,0);
SvPADTMP_on(sv);
+ 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 != &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);
+ 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(proto)
+CV* proto;
+{
+ return cv_clone2(proto, CvOUTSIDE(proto));
+}
+
+void
+cv_ckproto(cv, gv, p)
+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* cv;
+{
+ OP *o;
+ SV *sv;
+
+ if (!cv || !SvPOK(cv) || SvCUR(cv))
+ return Nullsv;
+
+ sv = Nullsv;
+ for (o = CvSTART(cv); o; o = o->op_next) {
+ OPCODE type = o->op_type;
+
+ 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 = ((SVOP*)o)->op_sv;
+ else if (type == OP_PADSV) {
+ AV* pad = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
+ sv = pad ? AvARRAY(pad)[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(floor,op,proto,block)
I32 floor;
OP *op;
OP *proto;
OP *block;
{
+ char *name = op ? SvPVx(cSVOP->op_sv, na) : Nullch;
+ GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
+ char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch;
register CV *cv;
- char *name = op ? SvPVx(cSVOP->op_sv, na) : "__ANON__";
- GV* gv = gv_fetchpv(name, GV_ADDMULTI, SVt_PVCV);
- AV* av;
- char *s;
I32 ix;
if (op)
- sub_generation++;
- if (cv = GvCV(gv)) {
- if (GvCVGEN(gv))
- cv = 0; /* just a cached method */
- else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
- if (dowarn) { /* already defined (or promised)? */
+ SAVEFREEOP(op);
+ if (proto)
+ SAVEFREEOP(proto);
+
+ 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;
+ if (!block) {
+ /* just a "sub foo;" when &foo is already defined */
+ SAVEFREESV(compcv);
+ goto done;
+ }
+ /* ahem, death to those who redefine active sort subs */
+ if (curstack == sortstack && sortcop == CvSTART(cv))
+ croak("Can't redefine active sort subroutine %s", name);
+ const_sv = cv_const_sv(cv);
+ if (const_sv || dowarn) {
line_t oldline = curcop->cop_line;
-
curcop->cop_line = copline;
- warn("Subroutine %s redefined",name);
+ warn(const_sv ? "Constant subroutine %s redefined"
+ : "Subroutine %s redefined", name);
curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
- cv = 0;
+ cv = Nullcv;
}
}
if (cv) { /* must reuse cv if autoloaded */
cv_undef(cv);
+ CvFLAGS(cv) = CvFLAGS(compcv);
CvOUTSIDE(cv) = CvOUTSIDE(compcv);
CvOUTSIDE(compcv) = 0;
CvPADLIST(cv) = CvPADLIST(compcv);
@@ -2819,99 +3291,152 @@ OP *block;
}
else {
cv = compcv;
+ if (name) {
+ GvCV(gv) = cv;
+ GvCVGEN(gv) = 0;
+ sub_generation++;
+ }
}
- GvCV(gv) = cv;
- GvCVGEN(gv) = 0;
+ CvGV(cv) = (GV*)SvREFCNT_inc(gv);
CvFILEGV(cv) = curcop->cop_filegv;
- CvGV(cv) = SvREFCNT_inc(gv);
CvSTASH(cv) = curstash;
- if (proto) {
- char *p = SvPVx(((SVOP*)proto)->op_sv, na);
- if (SvPOK(cv) && strNE(SvPV((SV*)cv,na), p))
- warn("Prototype mismatch: (%s) vs (%s)", SvPV((SV*)cv, na), p);
- sv_setpv((SV*)cv, p);
- op_free(proto);
- }
+ if (ps)
+ sv_setpv((SV*)cv, ps);
if (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 (in_eval & 4)
+ croak(not_safe);
+ else {
+ /* force display of errors found but not reported */
+ sv_catpv(GvSV(errgv), not_safe);
+ croak("%s", SvPVx(GvSV(errgv), na));
+ }
+ }
+ }
}
if (!block) {
- CvROOT(cv) = 0;
- op_free(op);
copline = NOLINE;
LEAVE_SCOPE(floor);
return cv;
}
- av = newAV(); /* Will be @_ */
- av_extend(av, 0);
- av_store(comppad, 0, (SV*)av);
- AvFLAGS(av) = AVf_REIFY;
+ if (AvFILL(comppad_name) < AvFILL(comppad))
+ av_store(comppad_name, AvFILL(comppad), Nullsv);
- for (ix = AvFILL(comppad); ix > 0; ix--) {
- if (!SvPADMY(curpad[ix]))
- SvPADTMP_on(curpad[ix]);
+ if (CvCLONE(cv)) {
+ SV **namep = AvARRAY(comppad_name);
+ for (ix = AvFILL(comppad); ix > 0; ix--) {
+ SV *namesv;
+
+ if (SvIMMORTAL(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 != &sv_undef &&
+ (SvFAKE(namesv) ||
+ *SvPVX(namesv) == '&')))
+ {
+ SvREFCNT_dec(curpad[ix]);
+ curpad[ix] = Nullsv;
+ }
+ }
}
+ else {
+ AV *av = newAV(); /* Will be @_ */
+ av_extend(av, 0);
+ av_store(comppad, 0, (SV*)av);
+ AvFLAGS(av) = AVf_REIFY;
- if (AvFILL(comppad_name) < AvFILL(comppad))
- av_store(comppad_name, AvFILL(comppad), Nullsv);
+ for (ix = AvFILL(comppad); ix > 0; ix--) {
+ if (SvIMMORTAL(curpad[ix]))
+ continue;
+ if (!SvPADMY(curpad[ix]))
+ SvPADTMP_on(curpad[ix]);
+ }
+ }
CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
peep(CvSTART(cv));
- if (s = strrchr(name,':'))
- s++;
- else
- s = name;
- if (strEQ(s, "BEGIN") && !error_count) {
- line_t oldline = compiling.cop_line;
- SV *oldrs = rs;
- ENTER;
- SAVESPTR(compiling.cop_filegv);
- SAVEI32(perldb);
- if (!beginav)
- beginav = newAV();
- av_push(beginav, (SV *)cv);
- DEBUG_x( dump_sub(gv) );
- rs = SvREFCNT_inc(nrs);
- GvCV(gv) = 0;
- calllist(beginav);
- SvREFCNT_dec(rs);
- rs = oldrs;
- curcop = &compiling;
- curcop->cop_line = oldline; /* might have recursed to yylex */
- LEAVE;
- }
- else if (strEQ(s, "END") && !error_count) {
- if (!endav)
- endav = newAV();
- av_unshift(endav, 1);
- av_store(endav, 0, SvREFCNT_inc(cv));
- }
- if (perldb && curstash != debstash) {
- SV *sv;
- SV *tmpstr = sv_newmortal();
+ if (name) {
+ char *s;
+
+ if (PERLDB_SUBLINE && curstash != debstash) {
+ SV *sv = NEWSV(0,0);
+ SV *tmpstr = sv_newmortal();
+ static GV *db_postponed;
+ CV *cv;
+ HV *hv;
+
+ sv_setpvf(sv, "%_:%ld-%ld",
+ GvSV(curcop->cop_filegv),
+ (long)subline, (long)curcop->cop_line);
+ gv_efullname3(tmpstr, gv, Nullch);
+ hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
+ if (!db_postponed) {
+ db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
+ }
+ 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);
+ }
+ }
- sprintf(buf,"%s:%ld",SvPVX(GvSV(curcop->cop_filegv)), (long)subline);
- sv = newSVpv(buf,0);
- sv_catpv(sv,"-");
- sprintf(buf,"%ld",(long)curcop->cop_line);
- sv_catpv(sv,buf);
- gv_efullname(tmpstr,gv);
- hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
+ if ((s = strrchr(name,':')))
+ s++;
+ else
+ s = name;
+ if (strEQ(s, "BEGIN")) {
+ I32 oldscope = scopestack_ix;
+ ENTER;
+ SAVESPTR(compiling.cop_filegv);
+ SAVEI16(compiling.cop_line);
+ SAVEI32(perldb);
+ save_svref(&rs);
+ sv_setsv(rs, nrs);
+
+ if (!beginav)
+ beginav = newAV();
+ DEBUG_x( dump_sub(gv) );
+ av_push(beginav, (SV *)cv);
+ GvCV(gv) = 0;
+ call_list(oldscope, beginav);
+
+ curcop = &compiling;
+ LEAVE;
+ }
+ else if (strEQ(s, "END") && !error_count) {
+ if (!endav)
+ endav = newAV();
+ av_unshift(endav, 1);
+ av_store(endav, 0, (SV *)cv);
+ GvCV(gv) = 0;
+ }
}
- op_free(op);
+
+ done:
copline = NOLINE;
LEAVE_SCOPE(floor);
- if (!op) {
- GvCV(gv) = 0; /* Will remember in SVOP instead. */
- CvANON_on(cv);
- }
return cv;
}
@@ -2936,19 +3461,19 @@ char *name;
void (*subaddr) _((CV*));
char *filename;
{
+ GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
register CV *cv;
- GV *gv = gv_fetchpv((name ? name : "__ANON__"), GV_ADDMULTI, SVt_PVCV);
- char *s;
-
- if (name)
- sub_generation++;
- if (cv = GvCV(gv)) {
- if (GvCVGEN(gv))
- cv = 0; /* just a cached method */
- else if (CvROOT(cv) || CvXSUB(cv)) { /* already defined? */
+
+ 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 (dowarn) {
line_t oldline = curcop->cop_line;
-
curcop->cop_line = copline;
warn("Subroutine %s redefined",name);
curcop->cop_line = oldline;
@@ -2957,40 +3482,45 @@ char *filename;
cv = 0;
}
}
- if (cv) { /* must reuse cv if autoloaded */
- assert(SvREFCNT(CvGV(cv)) > 1);
- SvREFCNT_dec(CvGV(cv));
- }
+
+ 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;
+ sub_generation++;
+ }
}
- GvCV(gv) = cv;
- CvGV(cv) = SvREFCNT_inc(gv);
- GvCVGEN(gv) = 0;
+ CvGV(cv) = (GV*)SvREFCNT_inc(gv);
CvFILEGV(cv) = gv_fetchfile(filename);
CvXSUB(cv) = subaddr;
- if (!name)
- s = "__ANON__";
- else if (s = strrchr(name,':'))
- s++;
+
+ if (name) {
+ char *s = strrchr(name,':');
+ if (s)
+ s++;
+ else
+ s = name;
+ if (strEQ(s, "BEGIN")) {
+ if (!beginav)
+ beginav = newAV();
+ av_push(beginav, (SV *)cv);
+ GvCV(gv) = 0;
+ }
+ else if (strEQ(s, "END")) {
+ if (!endav)
+ endav = newAV();
+ av_unshift(endav, 1);
+ av_store(endav, 0, (SV *)cv);
+ GvCV(gv) = 0;
+ }
+ }
else
- s = name;
- if (strEQ(s, "BEGIN")) {
- if (!beginav)
- beginav = newAV();
- av_push(beginav, SvREFCNT_inc(gv));
- }
- else if (strEQ(s, "END")) {
- if (!endav)
- endav = newAV();
- av_unshift(endav, 1);
- av_store(endav, 0, SvREFCNT_inc(gv));
- }
- if (!name) {
- GvCV(gv) = 0; /* Will remember elsewhere instead. */
CvANON_on(cv);
- }
+
return cv;
}
@@ -3023,11 +3553,11 @@ OP *block;
}
cv = compcv;
GvFORM(gv) = cv;
- CvGV(cv) = SvREFCNT_inc(gv);
+ CvGV(cv) = (GV*)SvREFCNT_inc(gv);
CvFILEGV(cv) = curcop->cop_filegv;
for (ix = AvFILL(comppad); ix > 0; ix--) {
- if (!SvPADMY(curpad[ix]))
+ if (!SvPADMY(curpad[ix]) && !SvIMMORTAL(curpad[ix]))
SvPADTMP_on(curpad[ix]);
}
@@ -3035,7 +3565,6 @@ OP *block;
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
peep(CvSTART(cv));
- FmLINES(cv) = 0;
op_free(op);
copline = NOLINE;
LEAVE_SCOPE(floor);
@@ -3181,6 +3710,35 @@ OP *o;
/* Check routines. */
OP *
+ck_anoncode(op)
+OP *op;
+{
+ 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(op->op_type, SVs_PADMY);
+ av_store(comppad_name, ix, name);
+ av_store(comppad, ix, cSVOP->op_sv);
+ SvPADMY_on(cSVOP->op_sv);
+ cSVOP->op_sv = Nullsv;
+ cSVOP->op_targ = ix;
+ return op;
+}
+
+OP *
+ck_bitop(op)
+OP *op;
+{
+ op->op_private = hints;
+ return op;
+}
+
+OP *
ck_concat(op)
OP *op;
{
@@ -3196,7 +3754,8 @@ OP *op;
if (op->op_flags & OPf_KIDS) {
OP* newop;
OP* kid;
- op = modkids(ck_fun(op), op->op_type);
+ OPCODE type = op->op_type;
+ op = modkids(ck_fun(op), type);
kid = cUNOP->op_first;
newop = kUNOP->op_first->op_sibling;
if (newop &&
@@ -3219,10 +3778,14 @@ ck_delete(op)
OP *op;
{
op = ck_fun(op);
+ op->op_private = 0;
if (op->op_flags & OPf_KIDS) {
OP *kid = cUNOP->op_first;
- if (kid->op_type != OP_HELEM)
- croak("%s argument is not a HASH element", op_desc[op->op_type]);
+ if (kid->op_type == OP_HSLICE)
+ op->op_private |= OPpSLICE;
+ else if (kid->op_type != OP_HELEM)
+ croak("%s argument is not a HASH element or slice",
+ op_desc[op->op_type]);
null(kid);
}
return op;
@@ -3238,7 +3801,7 @@ OP *op;
if (cLISTOP->op_first->op_type == OP_STUB) {
op_free(op);
op = newUNOP(type, OPf_SPECIAL,
- newGVOP(OP_GV, 0, gv_fetchpv("main'ARGV", TRUE, SVt_PVAV)));
+ newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
}
return ck_fun(op);
}
@@ -3304,6 +3867,20 @@ OP *op;
}
OP *
+ck_exists(op)
+OP *op;
+{
+ op = ck_fun(op);
+ if (op->op_flags & OPf_KIDS) {
+ OP *kid = cUNOP->op_first;
+ if (kid->op_type != OP_HELEM)
+ croak("%s argument is not a HASH element", op_desc[op->op_type]);
+ null(kid);
+ }
+ return op;
+}
+
+OP *
ck_gvconst(o)
register OP *o;
{
@@ -3321,9 +3898,31 @@ register OP *op;
op->op_private |= (hints & HINT_STRICT_REFS);
if (kid->op_type == OP_CONST) {
- int iscv = (op->op_type==OP_RV2CV)*2;
- GV *gv = 0;
+ char *name;
+ int iscv;
+ GV *gv;
+
+ name = SvPV(kid->op_sv, na);
+ if ((hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
+ char *badthing = Nullch;
+ switch (op->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);
+ }
kid->op_type = OP_GV;
+ iscv = (op->op_type == OP_RV2CV) * 2;
for (gv = 0; !gv; iscv++) {
/*
* This is a little tricky. We only want to add the symbol if we
@@ -3333,7 +3932,7 @@ register OP *op;
* or we get possible typo warnings. OPpCONST_ENTERED says
* whether the lexer already added THIS instance of this symbol.
*/
- gv = gv_fetchpv(SvPVx(kid->op_sv, na),
+ gv = gv_fetchpv(name,
iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
? SVt_PVCV
@@ -3352,13 +3951,6 @@ register OP *op;
}
OP *
-ck_formline(op)
-OP *op;
-{
- return ck_fun(op);
-}
-
-OP *
ck_ftst(op)
OP *op;
{
@@ -3380,7 +3972,7 @@ OP *op;
else {
op_free(op);
if (type == OP_FTTTY)
- return newGVOP(type, OPf_REF, gv_fetchpv("main'STDIN", TRUE,
+ return newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
SVt_PVIO));
else
return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv)));
@@ -3440,8 +4032,8 @@ OP *op;
OP *newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVAV) ));
if (dowarn)
- warn("Array @%s missing the @ in argument %d of %s()",
- name, numargs, op_desc[type]);
+ 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;
@@ -3458,8 +4050,8 @@ OP *op;
OP *newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVHV) ));
if (dowarn)
- warn("Hash %%%s missing the %% in argument %d of %s()",
- name, numargs, op_desc[type]);
+ 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;
@@ -3530,7 +4122,32 @@ OP *
ck_glob(op)
OP *op;
{
- GV *gv = newGVgen("main");
+ GV *gv;
+
+ if ((op->op_flags & OPf_KIDS) && !cLISTOP->op_first->op_sibling)
+ append_elem(OP_GLOB, op, newSVREF(newGVOP(OP_GV, 0, defgv)));
+
+ 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, op,
+ newSVOP(OP_CONST, 0, newSViv(glob_index++)));
+ op->op_type = OP_LIST;
+ op->op_ppaddr = ppaddr[OP_LIST];
+ ((LISTOP*)op)->op_first->op_type = OP_PUSHMARK;
+ ((LISTOP*)op)->op_first->op_ppaddr = ppaddr[OP_PUSHMARK];
+ op = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, op,
+ scalar(newUNOP(OP_RV2CV, 0,
+ newGVOP(OP_GV, 0, gv)))));
+ op = newUNOP(OP_NULL, 0, ck_subr(op));
+ op->op_targ = OP_GLOB; /* hint at what it used to be */
+ return op;
+ }
+ gv = newGVgen("main");
gv_IOadd(gv);
append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv));
scalarkids(op);
@@ -3596,7 +4213,7 @@ OP *op;
if (op->op_flags & OPf_KIDS) {
OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */
if (kid && kid->op_type == OP_CONST)
- fbm_compile(((SVOP*)kid)->op_sv, 0);
+ fbm_compile(((SVOP*)kid)->op_sv);
}
return ck_fun(op);
}
@@ -3613,14 +4230,16 @@ OP *
ck_lfun(op)
OP *op;
{
- return modkids(ck_fun(op), op->op_type);
+ OPCODE type = op->op_type;
+ return modkids(ck_fun(op), type);
}
OP *
ck_rfun(op)
OP *op;
{
- return refkids(ck_fun(op), op->op_type);
+ OPCODE type = op->op_type;
+ return refkids(ck_fun(op), type);
}
OP *
@@ -3651,15 +4270,50 @@ OP *op;
if (!kid)
append_elem(op->op_type, op, newSVREF(newGVOP(OP_GV, 0, defgv)) );
- return listkids(op);
+ op = listkids(op);
+
+ op->op_private = 0;
+#ifdef USE_LOCALE
+ if (hints & HINT_LOCALE)
+ op->op_private |= OPpLOCALE;
+#endif
+
+ return op;
+}
+
+OP *
+ck_fun_locale(op)
+OP *op;
+{
+ op = ck_fun(op);
+
+ op->op_private = 0;
+#ifdef USE_LOCALE
+ if (hints & HINT_LOCALE)
+ op->op_private |= OPpLOCALE;
+#endif
+
+ return op;
+}
+
+OP *
+ck_scmp(op)
+OP *op;
+{
+ op->op_private = 0;
+#ifdef USE_LOCALE
+ if (hints & HINT_LOCALE)
+ op->op_private |= OPpLOCALE;
+#endif
+
+ return op;
}
OP *
ck_match(op)
OP *op;
{
- cPMOP->op_pmflags |= PMf_RUNTIME;
- cPMOP->op_pmpermflags |= PMf_RUNTIME;
+ op->op_private |= OPpRUNTIME;
return op;
}
@@ -3745,8 +4399,9 @@ OP *op;
op_free(op);
return newUNOP(type, 0,
scalar(newUNOP(OP_RV2AV, 0,
- scalar(newGVOP(OP_GV, 0,
- gv_fetchpv((subline ? "_" : "ARGV"), TRUE, SVt_PVAV) )))));
+ scalar(newGVOP(OP_GV, 0, subline
+ ? defgv
+ : gv_fetchpv("ARGV", TRUE, SVt_PVAV) )))));
}
return scalar(modkids(ck_fun(op), type));
}
@@ -3755,6 +4410,12 @@ OP *
ck_sort(op)
OP *op;
{
+ op->op_private = 0;
+#ifdef USE_LOCALE
+ if (hints & HINT_LOCALE)
+ op->op_private |= OPpLOCALE;
+#endif
+
if (op->op_flags & OPf_STACKED) {
OP *kid = cLISTOP->op_first->op_sibling; /* get past pushmark */
OP *k;
@@ -3791,6 +4452,7 @@ OP *op;
op->op_flags |= OPf_SPECIAL;
}
}
+
return op;
}
@@ -3862,6 +4524,7 @@ OP *op;
OP *cvop;
char *proto = 0;
CV *cv = 0;
+ GV *namegv = 0;
int optional = 0;
I32 arg = 0;
@@ -3872,19 +4535,21 @@ OP *op;
null(cvop); /* disable rv2cv */
tmpop = (SVOP*)((UNOP*)cvop)->op_first;
if (tmpop->op_type == OP_GV) {
- cv = GvCV(tmpop->op_sv);
- if (cv && SvPOK(cv) && !(op->op_private & OPpENTERSUB_AMPER))
- proto = SvPV((SV*)cv,na);
+ cv = GvCVu(tmpop->op_sv);
+ if (cv && SvPOK(cv) && !(op->op_private & OPpENTERSUB_AMPER)) {
+ namegv = CvANON(cv) ? (GV*)tmpop->op_sv : CvGV(cv);
+ proto = SvPV((SV*)cv, na);
+ }
}
}
op->op_private |= (hints & HINT_STRICT_REFS);
- if (perldb && curstash != debstash)
+ if (PERLDB_SUB && curstash != debstash)
op->op_private |= OPpENTERSUB_DB;
while (o != cvop) {
if (proto) {
switch (*proto) {
case '\0':
- return too_many_arguments(op, CvNAME(cv));
+ return too_many_arguments(op, gv_ename(namegv));
case ';':
optional = 1;
proto++;
@@ -3903,7 +4568,7 @@ OP *op;
proto++;
arg++;
if (o->op_type != OP_REFGEN && o->op_type != OP_UNDEF)
- bad_type(arg, "block", CvNAME(cv), o);
+ bad_type(arg, "block", gv_ename(namegv), o);
break;
case '*':
proto++;
@@ -3924,23 +4589,23 @@ OP *op;
switch (*proto++) {
case '*':
if (o->op_type != OP_RV2GV)
- bad_type(arg, "symbol", CvNAME(cv), o);
+ bad_type(arg, "symbol", gv_ename(namegv), o);
goto wrapref;
case '&':
if (o->op_type != OP_RV2CV)
- bad_type(arg, "sub", CvNAME(cv), o);
+ bad_type(arg, "sub", gv_ename(namegv), o);
goto wrapref;
case '$':
if (o->op_type != OP_RV2SV && o->op_type != OP_PADSV)
- bad_type(arg, "scalar", CvNAME(cv), o);
+ bad_type(arg, "scalar", gv_ename(namegv), o);
goto wrapref;
case '@':
if (o->op_type != OP_RV2AV && o->op_type != OP_PADAV)
- bad_type(arg, "array", CvNAME(cv), o);
+ bad_type(arg, "array", gv_ename(namegv), o);
goto wrapref;
case '%':
if (o->op_type != OP_RV2HV && o->op_type != OP_PADHV)
- bad_type(arg, "hash", CvNAME(cv), o);
+ bad_type(arg, "hash", gv_ename(namegv), o);
wrapref:
{
OP* kid = o;
@@ -3953,10 +4618,13 @@ OP *op;
default: goto oops;
}
break;
+ case ' ':
+ proto++;
+ continue;
default:
oops:
croak("Malformed prototype for %s: %s",
- CvNAME(cv),SvPV((SV*)cv,na));
+ gv_ename(namegv), SvPV((SV*)cv, na));
}
}
else
@@ -3965,8 +4633,9 @@ OP *op;
prev = o;
o = o->op_sibling;
}
- if (proto && !optional && *proto == '$')
- return too_few_arguments(op, CvNAME(cv));
+ if (proto && !optional &&
+ (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
+ return too_few_arguments(op, gv_ename(namegv));
return op;
}
@@ -4032,9 +4701,9 @@ register OP* o;
o->op_seq = op_seqmax++;
break;
case OP_STUB:
- if ((o->op_flags & (OPf_KNOW|OPf_LIST)) != (OPf_KNOW|OPf_LIST)) {
+ if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
o->op_seq = op_seqmax++;
- break; /* Scalar stub must produce undef. List stub is noop */
+ break; /* Scalar stub must produce undef. List stub is noop */
}
goto nothin;
case OP_NULL:
@@ -4054,7 +4723,7 @@ register OP* o;
case OP_GV:
if (o->op_next->op_type == OP_RV2SV) {
- if (!(o->op_next->op_private & (OPpDEREF_HV|OPpDEREF_AV))) {
+ 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;
@@ -4069,7 +4738,7 @@ register OP* o;
(op = pop->op_next) &&
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
- (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO)) &&
+ (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
(i = SvIV(((SVOP*)pop)->op_sv) - compiling.cop_arybase)
<= 255 &&
i >= 0)
@@ -4083,7 +4752,7 @@ register OP* o;
o->op_type = OP_AELEMFAST;
o->op_ppaddr = ppaddr[OP_AELEMFAST];
o->op_private = (U8)i;
- GvAVn((GV*)(((SVOP*)o)->op_sv));
+ GvAVn(((GVOP*)o)->op_gv);
}
}
o->op_seq = op_seqmax++;
diff --git a/gnu/usr.bin/perl/op.h b/gnu/usr.bin/perl/op.h
index 304099bd8ff..d58f825beea 100644
--- a/gnu/usr.bin/perl/op.h
+++ b/gnu/usr.bin/perl/op.h
@@ -1,6 +1,6 @@
/* op.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -41,11 +41,20 @@ typedef U32 PADOFFSET;
U8 op_flags; \
U8 op_private;
-#define GIMME (op->op_flags & OPf_KNOW ? op->op_flags & OPf_LIST : dowantarray())
+#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(op, block_gimme())
/* Public flags */
-#define OPf_LIST 1 /* Do operator in list context. */
-#define OPf_KNOW 2 /* Context is known. */
+
+#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.) */
@@ -63,6 +72,13 @@ typedef U32 PADOFFSET;
/* 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 $@ */
+
+/* old names; don't use in new code, but don't break them, either */
+#define OPf_LIST 1
+#define OPf_KNOW 2
+#define GIMME \
+ (op->op_flags & OPf_KNOW ? op->op_flags & OPf_LIST : dowantarray())
/* Private for lvalues */
#define OPpLVAL_INTRO 128 /* Lvalue must be localized */
@@ -73,6 +89,9 @@ typedef U32 PADOFFSET;
/* 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_SQUASH 16
#define OPpTRANS_DELETE 32
@@ -82,11 +101,16 @@ typedef U32 PADOFFSET;
#define OPpREPEAT_DOLIST 64 /* List replication. */
/* Private for OP_ENTERSUB, OP_RV2?V, OP_?ELEM */
- /* (lower bits carry hints) */
-#define OPpENTERSUB_AMPER 8 /* Used & form to call. */
+#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 OPpDEREF_AV 32 /* Want ref to AV. */
-#define OPpDEREF_HV 64 /* Want ref to HV. */
+#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. */
@@ -99,8 +123,11 @@ typedef U32 PADOFFSET;
/* Private for OP_LIST */
#define OPpLIST_GUESSED 64 /* Guessed that pushmark was needed. */
-/* Private for OP_LEAVE and friends */
-#define OPpLEAVE_VOID 64 /* No need to copy out values. */
+/* 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 */
struct op {
BASEOP
@@ -161,12 +188,12 @@ struct pmop {
#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_RUNTIME 0x0200 /* pattern coming in on the stack */
+#define PMf_CONTINUE 0x0200 /* don't reset pos() if //g fails */
#define PMf_EVAL 0x0400 /* evaluating replacement as expr */
#define PMf_WHITE 0x0800 /* pattern is \s+ */
#define PMf_MULTILINE 0x1000 /* assume multiple lines */
#define PMf_SINGLELINE 0x2000 /* assume single line */
-#define PMf_UNUSED 0x4000 /* (unused) */
+#define PMf_LOCALE 0x4000 /* use locale for character types */
#define PMf_EXTENDED 0x8000 /* chuck embedded whitespace */
struct svop {
diff --git a/gnu/usr.bin/perl/opcode.h b/gnu/usr.bin/perl/opcode.h
index b13849d8aa3..d962c1dae7f 100644
--- a/gnu/usr.bin/perl/opcode.h
+++ b/gnu/usr.bin/perl/opcode.h
@@ -212,145 +212,146 @@ typedef enum {
OP_PRTF, /* 205 */
OP_PRINT, /* 206 */
OP_SYSOPEN, /* 207 */
- OP_SYSREAD, /* 208 */
- OP_SYSWRITE, /* 209 */
- OP_SEND, /* 210 */
- OP_RECV, /* 211 */
- OP_EOF, /* 212 */
- OP_TELL, /* 213 */
- OP_SEEK, /* 214 */
- OP_TRUNCATE, /* 215 */
- OP_FCNTL, /* 216 */
- OP_IOCTL, /* 217 */
- OP_FLOCK, /* 218 */
- OP_SOCKET, /* 219 */
- OP_SOCKPAIR, /* 220 */
- OP_BIND, /* 221 */
- OP_CONNECT, /* 222 */
- OP_LISTEN, /* 223 */
- OP_ACCEPT, /* 224 */
- OP_SHUTDOWN, /* 225 */
- OP_GSOCKOPT, /* 226 */
- OP_SSOCKOPT, /* 227 */
- OP_GETSOCKNAME, /* 228 */
- OP_GETPEERNAME, /* 229 */
- OP_LSTAT, /* 230 */
- OP_STAT, /* 231 */
- OP_FTRREAD, /* 232 */
- OP_FTRWRITE, /* 233 */
- OP_FTREXEC, /* 234 */
- OP_FTEREAD, /* 235 */
- OP_FTEWRITE, /* 236 */
- OP_FTEEXEC, /* 237 */
- OP_FTIS, /* 238 */
- OP_FTEOWNED, /* 239 */
- OP_FTROWNED, /* 240 */
- OP_FTZERO, /* 241 */
- OP_FTSIZE, /* 242 */
- OP_FTMTIME, /* 243 */
- OP_FTATIME, /* 244 */
- OP_FTCTIME, /* 245 */
- OP_FTSOCK, /* 246 */
- OP_FTCHR, /* 247 */
- OP_FTBLK, /* 248 */
- OP_FTFILE, /* 249 */
- OP_FTDIR, /* 250 */
- OP_FTPIPE, /* 251 */
- OP_FTLINK, /* 252 */
- OP_FTSUID, /* 253 */
- OP_FTSGID, /* 254 */
- OP_FTSVTX, /* 255 */
- OP_FTTTY, /* 256 */
- OP_FTTEXT, /* 257 */
- OP_FTBINARY, /* 258 */
- OP_CHDIR, /* 259 */
- OP_CHOWN, /* 260 */
- OP_CHROOT, /* 261 */
- OP_UNLINK, /* 262 */
- OP_CHMOD, /* 263 */
- OP_UTIME, /* 264 */
- OP_RENAME, /* 265 */
- OP_LINK, /* 266 */
- OP_SYMLINK, /* 267 */
- OP_READLINK, /* 268 */
- OP_MKDIR, /* 269 */
- OP_RMDIR, /* 270 */
- OP_OPEN_DIR, /* 271 */
- OP_READDIR, /* 272 */
- OP_TELLDIR, /* 273 */
- OP_SEEKDIR, /* 274 */
- OP_REWINDDIR, /* 275 */
- OP_CLOSEDIR, /* 276 */
- OP_FORK, /* 277 */
- OP_WAIT, /* 278 */
- OP_WAITPID, /* 279 */
- OP_SYSTEM, /* 280 */
- OP_EXEC, /* 281 */
- OP_KILL, /* 282 */
- OP_GETPPID, /* 283 */
- OP_GETPGRP, /* 284 */
- OP_SETPGRP, /* 285 */
- OP_GETPRIORITY, /* 286 */
- OP_SETPRIORITY, /* 287 */
- OP_TIME, /* 288 */
- OP_TMS, /* 289 */
- OP_LOCALTIME, /* 290 */
- OP_GMTIME, /* 291 */
- OP_ALARM, /* 292 */
- OP_SLEEP, /* 293 */
- OP_SHMGET, /* 294 */
- OP_SHMCTL, /* 295 */
- OP_SHMREAD, /* 296 */
- OP_SHMWRITE, /* 297 */
- OP_MSGGET, /* 298 */
- OP_MSGCTL, /* 299 */
- OP_MSGSND, /* 300 */
- OP_MSGRCV, /* 301 */
- OP_SEMGET, /* 302 */
- OP_SEMCTL, /* 303 */
- OP_SEMOP, /* 304 */
- OP_REQUIRE, /* 305 */
- OP_DOFILE, /* 306 */
- OP_ENTEREVAL, /* 307 */
- OP_LEAVEEVAL, /* 308 */
- OP_ENTERTRY, /* 309 */
- OP_LEAVETRY, /* 310 */
- OP_GHBYNAME, /* 311 */
- OP_GHBYADDR, /* 312 */
- OP_GHOSTENT, /* 313 */
- OP_GNBYNAME, /* 314 */
- OP_GNBYADDR, /* 315 */
- OP_GNETENT, /* 316 */
- OP_GPBYNAME, /* 317 */
- OP_GPBYNUMBER, /* 318 */
- OP_GPROTOENT, /* 319 */
- OP_GSBYNAME, /* 320 */
- OP_GSBYPORT, /* 321 */
- OP_GSERVENT, /* 322 */
- OP_SHOSTENT, /* 323 */
- OP_SNETENT, /* 324 */
- OP_SPROTOENT, /* 325 */
- OP_SSERVENT, /* 326 */
- OP_EHOSTENT, /* 327 */
- OP_ENETENT, /* 328 */
- OP_EPROTOENT, /* 329 */
- OP_ESERVENT, /* 330 */
- OP_GPWNAM, /* 331 */
- OP_GPWUID, /* 332 */
- OP_GPWENT, /* 333 */
- OP_SPWENT, /* 334 */
- OP_EPWENT, /* 335 */
- OP_GGRNAM, /* 336 */
- OP_GGRGID, /* 337 */
- OP_GGRENT, /* 338 */
- OP_SGRENT, /* 339 */
- OP_EGRENT, /* 340 */
- OP_GETLOGIN, /* 341 */
- OP_SYSCALL, /* 342 */
+ OP_SYSSEEK, /* 208 */
+ OP_SYSREAD, /* 209 */
+ OP_SYSWRITE, /* 210 */
+ OP_SEND, /* 211 */
+ OP_RECV, /* 212 */
+ OP_EOF, /* 213 */
+ OP_TELL, /* 214 */
+ OP_SEEK, /* 215 */
+ OP_TRUNCATE, /* 216 */
+ OP_FCNTL, /* 217 */
+ OP_IOCTL, /* 218 */
+ OP_FLOCK, /* 219 */
+ OP_SOCKET, /* 220 */
+ OP_SOCKPAIR, /* 221 */
+ OP_BIND, /* 222 */
+ OP_CONNECT, /* 223 */
+ OP_LISTEN, /* 224 */
+ OP_ACCEPT, /* 225 */
+ OP_SHUTDOWN, /* 226 */
+ OP_GSOCKOPT, /* 227 */
+ OP_SSOCKOPT, /* 228 */
+ OP_GETSOCKNAME, /* 229 */
+ OP_GETPEERNAME, /* 230 */
+ OP_LSTAT, /* 231 */
+ OP_STAT, /* 232 */
+ OP_FTRREAD, /* 233 */
+ OP_FTRWRITE, /* 234 */
+ OP_FTREXEC, /* 235 */
+ OP_FTEREAD, /* 236 */
+ OP_FTEWRITE, /* 237 */
+ OP_FTEEXEC, /* 238 */
+ OP_FTIS, /* 239 */
+ OP_FTEOWNED, /* 240 */
+ OP_FTROWNED, /* 241 */
+ OP_FTZERO, /* 242 */
+ OP_FTSIZE, /* 243 */
+ OP_FTMTIME, /* 244 */
+ OP_FTATIME, /* 245 */
+ OP_FTCTIME, /* 246 */
+ OP_FTSOCK, /* 247 */
+ OP_FTCHR, /* 248 */
+ OP_FTBLK, /* 249 */
+ OP_FTFILE, /* 250 */
+ OP_FTDIR, /* 251 */
+ OP_FTPIPE, /* 252 */
+ OP_FTLINK, /* 253 */
+ OP_FTSUID, /* 254 */
+ OP_FTSGID, /* 255 */
+ OP_FTSVTX, /* 256 */
+ OP_FTTTY, /* 257 */
+ OP_FTTEXT, /* 258 */
+ OP_FTBINARY, /* 259 */
+ OP_CHDIR, /* 260 */
+ OP_CHOWN, /* 261 */
+ OP_CHROOT, /* 262 */
+ OP_UNLINK, /* 263 */
+ OP_CHMOD, /* 264 */
+ OP_UTIME, /* 265 */
+ OP_RENAME, /* 266 */
+ OP_LINK, /* 267 */
+ OP_SYMLINK, /* 268 */
+ OP_READLINK, /* 269 */
+ OP_MKDIR, /* 270 */
+ OP_RMDIR, /* 271 */
+ OP_OPEN_DIR, /* 272 */
+ OP_READDIR, /* 273 */
+ OP_TELLDIR, /* 274 */
+ OP_SEEKDIR, /* 275 */
+ OP_REWINDDIR, /* 276 */
+ OP_CLOSEDIR, /* 277 */
+ OP_FORK, /* 278 */
+ OP_WAIT, /* 279 */
+ OP_WAITPID, /* 280 */
+ OP_SYSTEM, /* 281 */
+ OP_EXEC, /* 282 */
+ OP_KILL, /* 283 */
+ OP_GETPPID, /* 284 */
+ OP_GETPGRP, /* 285 */
+ OP_SETPGRP, /* 286 */
+ OP_GETPRIORITY, /* 287 */
+ OP_SETPRIORITY, /* 288 */
+ OP_TIME, /* 289 */
+ OP_TMS, /* 290 */
+ OP_LOCALTIME, /* 291 */
+ OP_GMTIME, /* 292 */
+ OP_ALARM, /* 293 */
+ OP_SLEEP, /* 294 */
+ OP_SHMGET, /* 295 */
+ OP_SHMCTL, /* 296 */
+ OP_SHMREAD, /* 297 */
+ OP_SHMWRITE, /* 298 */
+ OP_MSGGET, /* 299 */
+ OP_MSGCTL, /* 300 */
+ OP_MSGSND, /* 301 */
+ OP_MSGRCV, /* 302 */
+ OP_SEMGET, /* 303 */
+ OP_SEMCTL, /* 304 */
+ OP_SEMOP, /* 305 */
+ OP_REQUIRE, /* 306 */
+ OP_DOFILE, /* 307 */
+ OP_ENTEREVAL, /* 308 */
+ OP_LEAVEEVAL, /* 309 */
+ OP_ENTERTRY, /* 310 */
+ OP_LEAVETRY, /* 311 */
+ OP_GHBYNAME, /* 312 */
+ OP_GHBYADDR, /* 313 */
+ OP_GHOSTENT, /* 314 */
+ OP_GNBYNAME, /* 315 */
+ OP_GNBYADDR, /* 316 */
+ OP_GNETENT, /* 317 */
+ OP_GPBYNAME, /* 318 */
+ OP_GPBYNUMBER, /* 319 */
+ OP_GPROTOENT, /* 320 */
+ OP_GSBYNAME, /* 321 */
+ OP_GSBYPORT, /* 322 */
+ OP_GSERVENT, /* 323 */
+ OP_SHOSTENT, /* 324 */
+ OP_SNETENT, /* 325 */
+ OP_SPROTOENT, /* 326 */
+ OP_SSERVENT, /* 327 */
+ OP_EHOSTENT, /* 328 */
+ OP_ENETENT, /* 329 */
+ OP_EPROTOENT, /* 330 */
+ OP_ESERVENT, /* 331 */
+ OP_GPWNAM, /* 332 */
+ OP_GPWUID, /* 333 */
+ OP_GPWENT, /* 334 */
+ OP_SPWENT, /* 335 */
+ OP_EPWENT, /* 336 */
+ OP_GGRNAM, /* 337 */
+ OP_GGRGID, /* 338 */
+ OP_GGRENT, /* 339 */
+ OP_SGRENT, /* 340 */
+ OP_EGRENT, /* 341 */
+ OP_GETLOGIN, /* 342 */
+ OP_SYSCALL, /* 343 */
OP_max
} opcode;
-#define MAXO 343
+#define MAXO 344
#ifndef DOINIT
EXT char *op_name[];
@@ -564,6 +565,7 @@ EXT char *op_name[] = {
"prtf",
"print",
"sysopen",
+ "sysseek",
"sysread",
"syswrite",
"send",
@@ -838,9 +840,9 @@ EXT char *op_desc[] = {
"keys",
"delete",
"exists operator",
- "associative array deref",
- "associative array elem",
- "associative array slice",
+ "hash deref",
+ "hash elem",
+ "hash slice",
"unpack",
"pack",
"split",
@@ -914,6 +916,7 @@ EXT char *op_desc[] = {
"printf",
"print",
"sysopen",
+ "sysseek",
"sysread",
"syswrite",
"send",
@@ -1052,14 +1055,17 @@ EXT char *op_desc[] = {
};
#endif
+OP * ck_anoncode _((OP* op));
+OP * ck_bitop _((OP* op));
OP * ck_concat _((OP* op));
OP * ck_delete _((OP* op));
OP * ck_eof _((OP* op));
OP * ck_eval _((OP* op));
OP * ck_exec _((OP* op));
-OP * ck_formline _((OP* op));
+OP * ck_exists _((OP* op));
OP * ck_ftst _((OP* op));
OP * ck_fun _((OP* op));
+OP * ck_fun_locale _((OP* op));
OP * ck_glob _((OP* op));
OP * ck_grep _((OP* op));
OP * ck_index _((OP* op));
@@ -1072,6 +1078,7 @@ OP * ck_repeat _((OP* op));
OP * ck_require _((OP* op));
OP * ck_rfun _((OP* op));
OP * ck_rvconst _((OP* op));
+OP * ck_scmp _((OP* op));
OP * ck_select _((OP* op));
OP * ck_shift _((OP* op));
OP * ck_sort _((OP* op));
@@ -1289,6 +1296,7 @@ OP * pp_leavewrite _((void));
OP * pp_prtf _((void));
OP * pp_print _((void));
OP * pp_sysopen _((void));
+OP * pp_sysseek _((void));
OP * pp_sysread _((void));
OP * pp_syswrite _((void));
OP * pp_send _((void));
@@ -1637,6 +1645,7 @@ EXT OP * (*ppaddr[])() = {
pp_prtf,
pp_print,
pp_sysopen,
+ pp_sysseek,
pp_sysread,
pp_syswrite,
pp_send,
@@ -1776,9 +1785,9 @@ EXT OP * (*ppaddr[])() = {
#endif
#ifndef DOINIT
-EXT OP * (*check[])();
+EXT OP * (*check[]) _((OP *op));
#else
-EXT OP * (*check[])() = {
+EXT OP * (*check[]) _((OP *op)) = {
ck_null, /* null */
ck_null, /* stub */
ck_fun, /* scalar */
@@ -1797,7 +1806,7 @@ EXT OP * (*check[])() = {
ck_rvconst, /* rv2sv */
ck_null, /* av2arylen */
ck_rvconst, /* rv2cv */
- ck_null, /* anoncode */
+ ck_anoncode, /* anoncode */
ck_null, /* prototype */
ck_spair, /* refgen */
ck_null, /* srefgen */
@@ -1845,8 +1854,8 @@ EXT OP * (*check[])() = {
ck_null, /* i_subtract */
ck_concat, /* concat */
ck_fun, /* stringify */
- ck_null, /* left_shift */
- ck_null, /* right_shift */
+ ck_bitop, /* left_shift */
+ ck_bitop, /* right_shift */
ck_null, /* lt */
ck_null, /* i_lt */
ck_null, /* gt */
@@ -1861,20 +1870,20 @@ EXT OP * (*check[])() = {
ck_null, /* i_ne */
ck_null, /* ncmp */
ck_null, /* i_ncmp */
- ck_null, /* slt */
- ck_null, /* sgt */
- ck_null, /* sle */
- ck_null, /* sge */
+ ck_scmp, /* slt */
+ ck_scmp, /* sgt */
+ ck_scmp, /* sle */
+ ck_scmp, /* sge */
ck_null, /* seq */
ck_null, /* sne */
- ck_null, /* scmp */
- ck_null, /* bit_and */
- ck_null, /* bit_xor */
- ck_null, /* bit_or */
+ 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_null, /* complement */
+ ck_bitop, /* complement */
ck_fun, /* atan2 */
ck_fun, /* sin */
ck_fun, /* cos */
@@ -1892,15 +1901,15 @@ EXT OP * (*check[])() = {
ck_fun, /* vec */
ck_index, /* index */
ck_index, /* rindex */
- ck_fun, /* sprintf */
- ck_formline, /* formline */
+ ck_fun_locale, /* sprintf */
+ ck_fun, /* formline */
ck_fun, /* ord */
ck_fun, /* chr */
ck_fun, /* crypt */
- ck_fun, /* ucfirst */
- ck_fun, /* lcfirst */
- ck_fun, /* uc */
- ck_fun, /* lc */
+ 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 */
@@ -1910,7 +1919,7 @@ EXT OP * (*check[])() = {
ck_fun, /* values */
ck_fun, /* keys */
ck_delete, /* delete */
- ck_delete, /* exists */
+ ck_exists, /* exists */
ck_rvconst, /* rv2hv */
ck_null, /* helem */
ck_null, /* hslice */
@@ -1987,6 +1996,7 @@ EXT OP * (*check[])() = {
ck_listiob, /* prtf */
ck_listiob, /* print */
ck_fun, /* sysopen */
+ ck_fun, /* sysseek */
ck_fun, /* sysread */
ck_fun, /* syswrite */
ck_fun, /* send */
@@ -2154,7 +2164,7 @@ EXT U32 opargs[] = {
0x0000098c, /* ref */
0x00009104, /* bless */
0x00000008, /* backtick */
- 0x00001108, /* glob */
+ 0x00009908, /* glob */
0x00000008, /* readline */
0x00000008, /* rcatline */
0x00000104, /* regcmaybe */
@@ -2195,8 +2205,8 @@ EXT U32 opargs[] = {
0x0000111e, /* i_subtract */
0x0000110e, /* concat */
0x0000010e, /* stringify */
- 0x0000111e, /* left_shift */
- 0x0000111e, /* right_shift */
+ 0x0000110e, /* left_shift */
+ 0x0000110e, /* right_shift */
0x00001136, /* lt */
0x00001116, /* i_lt */
0x00001136, /* gt */
@@ -2234,24 +2244,24 @@ EXT U32 opargs[] = {
0x0000098e, /* log */
0x0000098e, /* sqrt */
0x0000098e, /* int */
- 0x0000099c, /* hex */
- 0x0000099c, /* oct */
+ 0x0000098e, /* hex */
+ 0x0000098e, /* oct */
0x0000098e, /* abs */
0x0000099c, /* length */
0x0009110c, /* substr */
0x0001111c, /* vec */
0x0009111c, /* index */
0x0009111c, /* rindex */
- 0x0000210d, /* sprintf */
+ 0x0000210f, /* sprintf */
0x00002105, /* formline */
0x0000099e, /* ord */
0x0000098e, /* chr */
0x0000110e, /* crypt */
- 0x0000010e, /* ucfirst */
- 0x0000010e, /* lcfirst */
- 0x0000010e, /* uc */
- 0x0000010e, /* lc */
- 0x0000010e, /* quotemeta */
+ 0x0000098e, /* ucfirst */
+ 0x0000098e, /* lcfirst */
+ 0x0000098e, /* uc */
+ 0x0000098e, /* lc */
+ 0x0000098e, /* quotemeta */
0x00000048, /* rv2av */
0x00001304, /* aelemfast */
0x00001304, /* aelem */
@@ -2259,7 +2269,7 @@ EXT U32 opargs[] = {
0x00000408, /* each */
0x00000408, /* values */
0x00000408, /* keys */
- 0x00000104, /* delete */
+ 0x00000100, /* delete */
0x00000114, /* exists */
0x00000048, /* rv2hv */
0x00001404, /* helem */
@@ -2337,6 +2347,7 @@ EXT U32 opargs[] = {
0x00002e15, /* prtf */
0x00002e15, /* print */
0x00911604, /* sysopen */
+ 0x00011604, /* sysseek */
0x0091761d, /* sysread */
0x0091161d, /* syswrite */
0x0091161d, /* send */
diff --git a/gnu/usr.bin/perl/opcode.pl b/gnu/usr.bin/perl/opcode.pl
index fddf6462a94..a5659333726 100644
--- a/gnu/usr.bin/perl/opcode.pl
+++ b/gnu/usr.bin/perl/opcode.pl
@@ -1,5 +1,6 @@
#!/usr/bin/perl
+unlink "opcode.h";
open(OC, ">opcode.h") || die "Can't create opcode.h: $!\n";
select OC;
@@ -114,9 +115,9 @@ END
print <<END;
#ifndef DOINIT
-EXT OP * (*check[])();
+EXT OP * (*check[]) _((OP *op));
#else
-EXT OP * (*check[])() = {
+EXT OP * (*check[]) _((OP *op)) = {
END
for (@ops) {
@@ -213,7 +214,7 @@ rv2gv ref-to-glob cast ck_rvconst ds
rv2sv scalar deref ck_rvconst ds
av2arylen array length ck_null is
rv2cv subroutine deref ck_rvconst d
-anoncode anonymous subroutine ck_null 0
+anoncode anonymous subroutine ck_anoncode 0
prototype subroutine prototype ck_null s S
refgen reference constructor ck_spair m L
srefgen scalar ref constructor ck_null fs S
@@ -223,7 +224,8 @@ bless bless ck_fun s S S?
# Pushy I/O.
backtick backticks ck_null t
-glob glob ck_glob t S S
+# 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
@@ -278,8 +280,8 @@ i_subtract integer subtraction ck_null ifst S S
concat concatenation ck_concat fst S S
stringify string ck_fun fst S
-left_shift left bitshift ck_null ifst S S
-right_shift right bitshift ck_null ifst S S
+left_shift left bitshift ck_bitop fst S S
+right_shift right bitshift ck_bitop fst S S
lt numeric lt ck_null Iifs S S
i_lt integer lt ck_null ifs S S
@@ -296,22 +298,22 @@ i_ne integer ne ck_null ifs S S
ncmp spaceship operator ck_null Iifst S S
i_ncmp integer spaceship ck_null ifst S S
-slt string lt ck_null ifs S S
-sgt string gt ck_null ifs S S
-sle string le ck_null ifs S S
-sge string ge ck_null ifs S S
+slt string lt ck_scmp ifs S S
+sgt string gt ck_scmp ifs S S
+sle string le ck_scmp ifs S S
+sge string ge ck_scmp ifs S S
seq string eq ck_null ifs S S
sne string ne ck_null ifs S S
-scmp string comparison ck_null ifst S S
+scmp string comparison ck_scmp ifst S S
-bit_and bitwise and ck_null fst S S
-bit_xor bitwise xor ck_null fst S S
-bit_or bitwise or ck_null fst S S
+bit_and bitwise and ck_bitop fst S S
+bit_xor bitwise xor ck_bitop fst S S
+bit_or bitwise or ck_bitop fst S S
negate negate ck_null Ifst S
i_negate integer negate ck_null ifst S
not not ck_null ifs S
-complement 1's complement ck_null fst S
+complement 1's complement ck_bitop fst S
# High falutin' math.
@@ -324,9 +326,11 @@ 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 istu S?
-oct oct ck_fun istu S?
+hex hex ck_fun fstu S?
+oct oct ck_fun fstu S?
abs abs ck_fun fstu S?
# String stuff.
@@ -338,16 +342,16 @@ 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 mst S L
-formline formline ck_formline ms S L
+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 fst S
-lcfirst lower case first ck_fun fst S
-uc upper case ck_fun fst S
-lc lower case ck_fun fst S
-quotemeta quote metachars ck_fun fst 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.
@@ -356,16 +360,16 @@ aelemfast known array element ck_null s A S
aelem array element ck_null s A S
aslice array slice ck_null m A L
-# Associative arrays.
+# Hashes.
each each ck_fun t H
values values ck_fun t H
keys keys ck_fun t H
-delete delete ck_delete s S
-exists exists operator ck_delete is S
-rv2hv associative array deref ck_rvconst dt
-helem associative array elem ck_null s H S
-hslice associative array slice ck_null m H L
+delete delete ck_delete 0 S
+exists exists operator ck_exists is S
+rv2hv hash deref ck_rvconst dt
+helem hash elem ck_null s H S
+hslice hash slice ck_null m H L
# Explosives and implosives.
@@ -468,6 +472,7 @@ 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?
@@ -477,6 +482,7 @@ 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
diff --git a/gnu/usr.bin/perl/os2/Changes b/gnu/usr.bin/perl/os2/Changes
new file mode 100644
index 00000000000..4e0c4d49b53
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/Changes
@@ -0,0 +1,165 @@
+after 5.003_05:
+ PERLLIB_PREFIX was not active if it matches an element of @INC
+ as a whole.
+ Do not need PERL_SBRK if crtdll-revision is >= 50.
+ Use -Zsmall-conv if crtdll-revision is >= 50 (in static perl!).
+:7: warning: #warning <dirent.h> requires <sys/types.h>
+ We compile miniperl static. It cannot fork, thus there may be
+ problems with pipes (since HAS_FORK is in
+ place). Pipes are required by makemaker.
+ We compile perl___.exe A.OUT and dynamic. It should be able to
+ fork.
+ If we can fork, we my_popen by popen unless "-|". Thus we
+ write a cooky "-1" into the pid array to indicate
+ this.
+ Apparently we can fork, and we can load dynamic extensions
+ now, though probably not simultaneously.
+ *DB tests corrected for OS/2 one-user stat[2].
+ /bin/sh is intercepted and replaced by SH_PATH.
+ Note that having '\\' in the command line of one-arg `system'
+ would trigger call via shell.
+ Segfault with system {'ls'} 'blah'; corrected.
+ Documentation of OS/2-different features added to main PODs.
+ New buitins in Cwd::
+
+ Cwd::current_drive
+ Cwd::sys_chdir - leaves drive as it is.
+ Cwd::change_drive
+ Cwd::sys_is_absolute - has drive letter and is_rooted
+ Cwd::sys_is_rooted - has leading [/\\] (maybe
+ after a drive)
+ Cwd::sys_is_relative - changes with current dir
+ Cwd::sys_cwd - Interface to cwd from EMX.
+ Cwd::sys_abspath(name, dir)
+ - Really really odious
+ function. Returns absolute
+ name of file which would
+ have 'name' if CWD were 'dir'.
+ Dir defaults to the current dir.
+ Cwd::extLibpath [type] - Get/set current value of extended
+ Cwd::extLibpath_set - library search path.
+ path [type]
+ The optional last argument redirects
+ to END-path if true,
+ default is to search BEGIN-path.
+ (Note that some of these may be moved to different
+ libraries - eventually).
+ Executables:
+ perl - can fork, can dynalink (but not simultaneously)
+ perl_ - can fork, cannot dynalink
+ perl__ - same as perl___, but PM.
+ perl___ - cannot fork, can dynalink.
+ The build of the first one - perl - is rather convoluted, and
+ requires a build of miniperl_.
+after 5.003_05:
+ PERLLIB_PREFIX was not active if it matches an element of @INC
+ as a whole.
+ Do not need PERL_SBRK if crtdll-revision is >= 50.
+ Use -Zsmall-conv if crtdll-revision is >= 50 (in static perl!).
+:7: warning: #warning <dirent.h> requires <sys/types.h>
+ We compile miniperl static. It cannot fork, thus there may be
+ problems with pipes (since HAS_FORK is in
+ place). Pipes are required by makemaker.
+ We compile perl___.exe A.OUT and dynamic. It should be able to
+ fork.
+ If we can fork, we my_popen by popen unless "-|". Thus we
+ write a cooky "-1" into the pid array to indicate
+ this.
+ Apparently we can fork, and we can load dynamic extensions
+ now, though probably not simultaneously.
+ *DB tests corrected for OS/2 one-user stat[2].
+ /bin/sh is intercepted and replaced by SH_PATH.
+ Note that having '\\' in the command line of one-arg `system'
+ would trigger call via shell.
+ Segfault with system {'ls'} 'blah'; corrected.
+ Documentation of OS/2-different features added to main PODs.
+ New buitins in Cwd::
+
+ Cwd::current_drive
+ Cwd::sys_chdir - leaves drive as it is.
+ Cwd::change_drive
+ Cwd::sys_is_absolute - has drive letter and is_rooted
+ Cwd::sys_is_rooted - has leading [/\\] (maybe
+ after a drive)
+ Cwd::sys_is_relative - changes with current dir
+ Cwd::sys_cwd - Interface to cwd from EMX.
+ Cwd::sys_abspath(name, dir)
+ - Really really odious
+ function. Returns absolute
+ name of file which would
+ have 'name' if CWD were 'dir'.
+ Dir defaults to the current dir.
+ Cwd::extLibpath [type] - Get/set current value of extended
+ Cwd::extLibpath_set - library search path.
+ path [type]
+ The optional last argument redirects
+ to END-path if true,
+ default is to search BEGIN-path.
+ (Note that some of these may be moved to different
+ libraries - eventually).
+ Executables:
+ perl - can fork, can dynalink (but not simultaneously)
+ perl_ - can fork, cannot dynalink
+ perl__ - same as perl___, but PM.
+ perl___ - cannot fork, can dynalink.
+ The build of the first one - perl - is rather convoluted, and
+ requires a build of miniperl_.
+
+after 5.003_07:
+ custom tmpfile and tmpname which may use $TMP, $TEMP.
+ all the calls to OS/2 API wrapped so that it is safe to use
+ them under DOS (may die(), though).
+ Tested that popen works under DOS with modified PDKSH and RSX.
+ File::Copy works under DOS.
+ MakeMaker modified to work under DOS (perlmain.c.tmp and sh -c true).
+
+after 5.003_08:
+ OS2::PrfDB exports symbols as documented;
+ should work on OS/2 2.1 again.
+ uses reliable signals when spawing.
+ do not use popen() any more - no intermediate shell unless needed.
+
+after 5.003_11:
+ Functions emx_{malloc,realloc,calloc,free} are exported from DLL.
+ get_sysinfo() bugs corrected (flags were not used and wrongly defined).
+
+after 5.003_20:
+ _isterm is substituted instead of isatty, s?random instead of srand.
+ `register' disabled if -DDEBUGGING and not AOUT build: stupid SD386.
+ 3-argument select() was stomping over memory.
+
+after 5.003_21:
+ Can start scripts by executing 'dir/script' and
+ 'script.sh'. Form without extension will call shell only if
+ the specified file exists (will not look on path) (to prohibit
+ trying to run shell commands directly). - Needed by magic.t.
+
+after 5.003_27:
+ ALTERNATE_SHEBANG="extproc " supported, thus options on this
+ line are processed (possibly twice). -S is made legal on such
+ a line. This -S -x is not needed any more.
+ perl.dll may be used from non-EMX programs (via PERL_SYS_INIT
+ - the caller should have valid variable "env" with
+ environment). Known problems: $$ does not work - is 0, waitpid
+ returns immediately, thus Perl cannot wait for completion of
+ started programs.
+
+after 5.004_01:
+ flock emulation added (disable by setting env PERL_USE_FLOCK=0),
+ thanks to Rocco Caputo;
+ RSX bug with missing waitpid circomvented;
+ -S bug with full path with \ corrected.
+
+before 5.004_02:
+ -S switch to perl enables a search with additional extensions
+ .cmd, .btm, .bat, .pl as well. This means that if you have
+ mycmd.pl or mycmd.bat on PATH,
+ perl -S mycmd
+ will work. Perl will also look in the current directory first.
+ Moreover, a bug with \; in PATH being non-separator is fixed.
+
+after 5.004_03:
+ $^E tracks calls to CRT now. (May break if Perl masks some
+ changes to errno?)
+ $0 may be edited to longer lengths (at least under OS/2).
+ OS2::REXX->loads looks in the OS/2-ish fashion too.
diff --git a/gnu/usr.bin/perl/os2/Makefile.SHs b/gnu/usr.bin/perl/os2/Makefile.SHs
index bc99fd113b2..493aeab8c59 100644
--- a/gnu/usr.bin/perl/os2/Makefile.SHs
+++ b/gnu/usr.bin/perl/os2/Makefile.SHs
@@ -1,15 +1,44 @@
-# This file is read by Makefile.SH to produce rules for $(perllib)
-# We insert perl5.def since I do not know how to generate it yet.
+# This file is read by Makefile.SH to produce rules for $(LIBPERL) (and
+# some additional rules as well).
+
+# Rerun `sh Makefile.SH; make depend' after making any change.
+
+# Additional rules supported: perl_, aout_test, aout_install, use them
+# for a.out style perl (which may fork).
+
+$spitshell >>Makefile <<!GROK!THIS!
+
+AOUT_CCCMD = \$(CC) $aout_ccflags $optimize
+AOUT_AR = $aout_ar
+AOUT_OBJ_EXT = $aout_obj_ext
+AOUT_LIB_EXT = $aout_lib_ext
+AOUT_LIBPERL = libperl$aout_lib_ext
+AOUT_CLDFLAGS = $aout_ldflags
+
+AOUT_LIBPERL_DLL = libperl_dll$aout_lib_ext
+AOUT_CCCMD_DLL = \$(CC) -DDOSISH -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK
+AOUT_CLDFLAGS_DLL = -Zexe -Zmt -Zcrtdll
+
+LD_OPT = $optimize
+
+!GROK!THIS!
$spitshell >>Makefile <<'!NO!SUBS!'
-$(perllib): perl.imp perl.dll perl5.def
- emximp -o $(perllib) perl.imp
+$(LIBPERL): perl.imp perl.dll perl5.def
+ emximp -o $(LIBPERL) perl.imp
+
+$(AOUT_LIBPERL_DLL): perl.imp perl.dll perl5.def
+ emximp -o $(AOUT_LIBPERL_DLL) perl.imp
perl.imp: perl5.def
emximp -o perl.imp perl5.def
+ echo 'emx_calloc emxlibcm 400 ?' >> $@
+ echo 'emx_free emxlibcm 401 ?' >> $@
+ echo 'emx_malloc emxlibcm 402 ?' >> $@
+ echo 'emx_realloc emxlibcm 403 ?' >> $@
perl.dll: $(obj) perl5.def perl$(OBJ_EXT)
- $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) -lsocket perl5.def
+ $(LD) $(LD_OPT) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def
perl5.def: perl.linkexp
echo "LIBRARY 'Perl' INITINSTANCE TERMINSTANCE" > $@
@@ -19,8 +48,15 @@ perl5.def: perl.linkexp
echo DATA LOADONCALL NONSHARED MULTIPLE >>$@
echo EXPORTS >>$@
echo ' "ctermid"' >>$@
+ echo ' "get_sysinfo"' >>$@
echo ' "Perl_OS2_init"' >>$@
echo ' "OS2_Perl_data"' >>$@
+ echo ' "dlopen"' >>$@
+ echo ' "dlsym"' >>$@
+ echo ' "dlerror"' >>$@
+ echo ' "my_tmpfile"' >>$@
+ echo ' "my_tmpnam"' >>$@
+ echo ' "my_flock"' >>$@
!NO!SUBS!
if [ ! -z "$myttyname" ] ; then
@@ -35,25 +71,24 @@ $spitshell >>Makefile <<'!NO!SUBS!'
# grep -v '"\(malloc\|realloc\|free\)"' perl.linkexp >>$@
-# We assume here that perl is available somewhere ...
-
perl.exports: perl.exp EXTERN.h perl.h
- (echo '#include "EXTERN.h"'; echo '#include "perl.h"' ; \
- echo '#include "perl.exp"') | \
+ (echo "#include \"EXTERN.h\" \n#include \"perl.h\" \n#include \"perl.exp\""; \
+ echo "malloc\nrealloc\ncalloc\nfree") | \
$(CC) -DEMBED -E - | \
awk '{if ($$2 == "") print $$1}' | sort | uniq > $@
-# perl -ne 'print if (/^#!/ .. /^#\s/) && s/^(\w+) *$$/$$1/' > $@
-
perl.linkexp: perl.exports perl.map
cat perl.exports perl.map | sort | uniq -d | sed -e 's/\w\+/ "\0"/' > perl.linkexp
-perl.map: $(obj) perl$(OBJ_EXT) miniperlmain$(OBJ_EXT)
- $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o dummy.exe miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj) -lsocket -lm -Zmap -Zlinker /map
- awk '{if ($$3 == "") print $$2}' <dummy.map | sort | uniq > perl.map
- rm dummy.exe dummy.map
+# We link miniperl statically, since .DLL depends on $(DYNALOADER)
+
+perl.map miniperl: $(obj) perl$(OBJ_EXT) miniperlmain$(OBJ_EXT)
+ $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj) $(libs) -Zmap -Zlinker /map
+ awk '{if ($$3 == "") print $$2}' <miniperl.map | sort | uniq > perl.map
+ rm miniperl.map
+ @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest
-depend: os2ish.h
+depend: os2ish.h dlfcn.h
# Stupid make? Needed...
os2$(OBJ_EXT) : os2.c
@@ -61,11 +96,99 @@ os2$(OBJ_EXT) : os2.c
os2.c: os2/os2.c os2ish.h
cp $< $@
+dl_os2.c: os2/dl_os2.c os2ish.h
+ cp $< $@
+
os2ish.h: os2/os2ish.h
cp $< $@
+dlfcn.h: os2/dlfcn.h
+ cp $< $@
+
+# This one is compiled OMF, so cannot fork():
+
+perl___: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+ $(SHRPENV) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl___ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs)
+
installcmd :
perl -e 'die qq{Give the option INSTALLCMDDIR=... to make!} if $$ARGV[0] eq ""' $(INSTALLCMDDIR)
perl os2/perl2cmd.pl $(INSTALLCMDDIR)
+# Aout section:
+
+aout_obj = $(addsuffix $(AOUT_OBJ_EXT),$(basename $(obj)))
+AOUT_DYNALOADER = $(addsuffix $(AOUT_LIB_EXT),$(basename $(DYNALOADER)))
+aout_static_ext = $(addsuffix $(AOUT_LIB_EXT),$(basename $(dynamic_ext)))
+aout_static_lib = $(addsuffix $(LIB_EXT),$(basename $(dynamic_ext)))
+
+aout_static_ext_dll = $(addsuffix $(AOUT_LIB_EXT),$(basename $(static_ext)))
+DYNALOADER_OBJ = ext/DynaLoader/DynaLoader$(OBJ_EXT)
+aout_static_ext_dll = $(addsuffix $(AOUT_LIB_EXT),$(basename $(static_ext)))
+AOUT_DYNALOADER_OBJ = $(addsuffix $(AOUT_OBJ_EXT),$(basename $(DYNALOADER_OBJ)))
+
+$(AOUT_DYNALOADER_OBJ) : $(DYNALOADER_OBJ)
+ emxaout -o $@ $<
+
+$(DYNALOADER_OBJ) : $(DYNALOADER)
+ @sh -c true
+
+$(AOUT_LIBPERL) : $(aout_obj) perl$(AOUT_OBJ_EXT)
+ rm -f $@
+ $(AOUT_AR) rcu $@ perl$(AOUT_OBJ_EXT) $(aout_obj)
+
+.c$(AOUT_OBJ_EXT):
+ $(AOUT_CCCMD) $(PLDLFLAGS) -c $*.c
+
+perlmain(AOUT_OBJ_EXT): perlmain.c
+ $(AOUT_CCCMD_DLL) $(PLDLFLAGS) -c perlmain.c
+
+aout_perlmain.c: miniperlmain.c config.sh makefile $(static_ext_autoinit)
+ sh writemain $(DYNALOADER) $(aout_static_lib) > tmp
+ sh mv-if-diff tmp aout_perlmain.c
+
+miniperl_: $& miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) ext.libs
+ $(CC) $(LARGE) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o miniperl_ miniperlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) `cat ext.libs` $(libs)
+
+perl_: $& aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_LIBPERL) $(AOUT_DYNALOADER) $(aout_static_ext) ext.libs
+ $(CC) $(LARGE) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o perl_ aout_perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER) $(aout_static_ext) $(AOUT_LIBPERL) `cat ext.libs` $(libs)
+
+perl : perl__ perl___
+
+perl__: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+ $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl__ perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs) -Zlinker /PM:PM
+
+# Forking dynamically loaded perl:
+
+perl: $& perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) ext.libs
+ $(CC) $(LARGE) $(AOUT_CLDFLAGS_DLL) $(CCDLFLAGS) -o perl perlmain$(AOUT_OBJ_EXT) $(AOUT_DYNALOADER_OBJ) $(aout_static_ext_dll) $(AOUT_LIBPERL_DLL) `cat ext.libs` $(libs)
+
+clean: aout_clean
+
+aout_clean:
+ -rm *perl_.* *.o *.a lib/auto/*/*.a ext/*/Makefile.aout
+
+aout_install: perl_ aout_install.perl
+
+aout_install.perl: perl_ installperl
+ ./perl_ installperl
+
+aout_test: perl_
+ - cd t && (rm -f perl_$(EXE_EXT); $(LNS) ../perl_$(EXE_EXT) perl$(EXE_EXT)) && ./perl TEST </dev/tty
+
+lib/auto/OS2/*/%.a : ext/OS2/%/Makefile.aout
+ cd ext/OS2/$(basename $(notdir $@)) ; make -f Makefile.aout config || echo "$make config failed, continuing anyway..."
+ cd ext/OS2/$(basename $(notdir $@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS=
+
+lib/auto/*/%.a : ext/%/Makefile.aout
+ cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout config || echo "$make config failed, continuing anyway..."
+ cd ext/$(basename $(notdir $@)) ; make -f Makefile.aout LINKTYPE=static CCCDLFLAGS=
+
+.PRECIOUS : ext/%/Makefile.aout ext/OS2/%/Makefile.aout
+
+ext/OS2/%/Makefile.aout : miniperl_
+ cd $(dir $@) ; ../../../miniperl_ -I ../../../lib Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl
+
+ext/%/Makefile.aout : miniperl_
+ cd $(dir $@) ; ../../miniperl_ -I ../../lib Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl
+
!NO!SUBS!
diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/Changes b/gnu/usr.bin/perl/os2/OS2/ExtAttr/Changes
new file mode 100644
index 00000000000..55fdc5f6d5c
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/Changes
@@ -0,0 +1,5 @@
+Revision history for Perl extension OS2::ExtAttr.
+
+0.01 Sun Apr 21 11:07:04 1996
+ - original version; created by h2xs 1.16
+
diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.pm b/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.pm
new file mode 100644
index 00000000000..bebbcc963e8
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.pm
@@ -0,0 +1,186 @@
+package OS2::ExtAttr;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT);
+
+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 OS2::ExtAttr $VERSION;
+
+# Preloaded methods go here.
+
+# Format of the array:
+# 0 ead, 1 file name, 2 file handle. 3 length, 4 position, 5 need to write.
+
+sub TIEHASH {
+ my $class = shift;
+ my $ea = _create() || die "Cannot create EA: $!";
+ my $file = shift;
+ my ($name, $handle);
+ if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') {
+ die "File handle is not opened" unless $handle = fileno $file;
+ _read($ea, undef, $handle, 0);
+ } else {
+ $name = $file;
+ _read($ea, $name, 0, 0);
+ }
+ bless [$ea, $name, $handle, 0, 0, 0], $class;
+}
+
+sub DESTROY {
+ my $eas = shift;
+ # 0 means: discard eas which are not in $eas->[0].
+ _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!"
+ if $eas->[5];
+ _destroy( $eas->[0] );
+}
+
+sub FIRSTKEY {
+ my $eas = shift;
+ $eas->[3] = _count($eas->[0]);
+ $eas->[4] = 1;
+ return undef if $eas->[4] > $eas->[3];
+ return _get_name($eas->[0], $eas->[4]);
+}
+
+sub NEXTKEY {
+ my $eas = shift;
+ $eas->[4]++;
+ return undef if $eas->[4] > $eas->[3];
+ return _get_name($eas->[0], $eas->[4]);
+}
+
+sub FETCH {
+ my $eas = shift;
+ my $index = _find($eas->[0], shift);
+ return undef if $index <= 0;
+ return value($eas->[0], $index);
+}
+
+sub EXISTS {
+ my $eas = shift;
+ return _find($eas->[0], shift) > 0;
+}
+
+sub STORE {
+ my $eas = shift;
+ $eas->[5] = 1;
+ add($eas->[0], shift, shift) > 0 or die "Error setting EA: $!";
+}
+
+sub DELETE {
+ my $eas = shift;
+ my $index = _find($eas->[0], shift);
+ return undef if $index <= 0;
+ my $value = value($eas->[0], $index);
+ _delete($eas->[0], $index) and die "Error deleting EA: $!";
+ $eas->[5] = 1;
+ return $value;
+}
+
+sub CLEAR {
+ my $eas = shift;
+ _clear($eas->[0]);
+ $eas->[5] = 1;
+}
+
+# Here are additional methods:
+
+*new = \&TIEHASH;
+
+sub copy {
+ my $eas = shift;
+ my $file = shift;
+ my ($name, $handle);
+ if (ref $file eq 'GLOB' or ref \$file eq 'GLOB') {
+ die "File handle is not opened" unless $handle = fileno $file;
+ _write($eas->[0], undef, $handle, 0) or die "Cannot write EA: $!";
+ } else {
+ $name = $file;
+ _write($eas->[0], $name, 0, 0) or die "Cannot write EA: $!";
+ }
+}
+
+sub update {
+ my $eas = shift;
+ # 0 means: discard eas which are not in $eas->[0].
+ _write( $eas->[0], $eas->[1], $eas->[2], 0) and die "Cannot write EA: $!";
+}
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+# Below is the stub of documentation for your module. You better edit it!
+
+=head1 NAME
+
+OS2::ExtAttr - Perl access to extended attributes.
+
+=head1 SYNOPSIS
+
+ use OS2::ExtAttr;
+ tie %ea, 'OS2::ExtAttr', 'my.file';
+ print $ea{eaname};
+ $ea{myfield} = 'value';
+
+ untie %ea;
+
+=head1 DESCRIPTION
+
+The package provides low-level and high-level interface to Extended
+Attributes under OS/2.
+
+=head2 High-level interface: C<tie>
+
+The only argument of tie() is a file name, or an open file handle.
+
+Note that all the changes of the tied hash happen in core, to
+propagate it to disk the tied hash should be untie()ed or should go
+out of scope. Alternatively, one may use the low-level C<update>
+method on the corresponding object. Example:
+
+ tied(%hash)->update;
+
+Note also that setting/getting EA flag is not supported by the
+high-level interface, one should use the low-level interface
+instead. To use it on a tied hash one needs undocumented way to find
+C<eas> give the tied hash.
+
+=head2 Low-level interface
+
+Two low-level methods are supported by the objects: copy() and
+update(). The copy() takes one argument: the name of a file to copy
+the attributes to, or an opened file handle. update() takes no
+arguments, and is discussed above.
+
+Three convenience functions are provided:
+
+ value($eas, $key)
+ add($eas, $key, $value [, $flag])
+ replace($eas, $key, $value [, $flag])
+
+The default value for C<flag> is 0.
+
+In addition, all the C<_ea_*> and C<_ead_*> functions defined in EMX
+library are supported, with leading C<_ea/_ead> stripped.
+
+=head1 AUTHOR
+
+Ilya Zakharevich, ilya@math.ohio-state.edu
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.xs b/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.xs
new file mode 100644
index 00000000000..566b6595c8e
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/ExtAttr.xs
@@ -0,0 +1,193 @@
+#ifdef __cplusplus
+extern "C" {
+#endif
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#ifdef __cplusplus
+}
+#endif
+
+#include "myea.h"
+
+SV *
+my_eadvalue(_ead ead, int index)
+{
+ SV *sv;
+ int size = _ead_value_size(ead, index);
+ void *p;
+
+ if (size == -1) {
+ die("Error getting size of EA: %s", strerror(errno));
+ }
+ p = _ead_get_value(ead, index);
+ return newSVpv((char*)p, size);
+}
+
+#define my_eadreplace(ead, index, sv, flag) \
+ _ead_replace((ead), (index), flag, SvPVX(sv), SvCUR(sv))
+
+#define my_eadadd(ead, name, sv, flag) \
+ _ead_add((ead), (name), flag, SvPVX(sv), SvCUR(sv))
+
+
+MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = my_ead
+
+SV *
+my_eadvalue(ead, index)
+ _ead ead
+ int index
+
+int
+my_eadreplace(ead, index, sv, flag = 0)
+ _ead ead
+ int index
+ SV * sv
+ int flag
+
+int
+my_eadadd(ead, name, sv, flag = 0)
+ _ead ead
+ char * name
+ SV * sv
+ int flag
+
+MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = _ea
+
+
+void
+_ea_free(ptr)
+ struct _ea * ptr
+
+int
+_ea_get(dst, path, handle, name)
+ struct _ea * dst
+ char * path
+ int handle
+ char * name
+
+int
+_ea_put(src, path, handle, name)
+ struct _ea * src
+ char * path
+ int handle
+ char * name
+
+int
+_ea_remove(path, handle, name)
+ char * path
+ int handle
+ char * name
+
+MODULE = OS2::ExtAttr PACKAGE = OS2::ExtAttr PREFIX = _ead
+
+int
+_ead_add(ead, name, flags, value, size)
+ _ead ead
+ char * name
+ int flags
+ void * value
+ int size
+
+void
+_ead_clear(ead)
+ _ead ead
+
+int
+_ead_copy(dst_ead, src_ead, src_index)
+ _ead dst_ead
+ _ead src_ead
+ int src_index
+
+int
+_ead_count(ead)
+ _ead ead
+
+_ead
+_ead_create()
+
+int
+_ead_delete(ead, index)
+ _ead ead
+ int index
+
+void
+_ead_destroy(ead)
+ _ead ead
+
+int
+_ead_fea2list_size(ead)
+ _ead ead
+
+void *
+_ead_fea2list_to_fealist(src)
+ void * src
+
+void *
+_ead_fealist_to_fea2list(src)
+ void * src
+
+int
+_ead_find(ead, name)
+ _ead ead
+ char * name
+
+void *
+_ead_get_fea2list(ead)
+ _ead ead
+
+int
+_ead_get_flags(ead, index)
+ _ead ead
+ int index
+
+char *
+_ead_get_name(ead, index)
+ _ead ead
+ int index
+
+void *
+_ead_get_value(ead, index)
+ _ead ead
+ int index
+
+int
+_ead_name_len(ead, index)
+ _ead ead
+ int index
+
+int
+_ead_read(ead, path, handle, flags)
+ _ead ead
+ char * path
+ int handle
+ int flags
+
+int
+_ead_replace(ead, index, flags, value, size)
+ _ead ead
+ int index
+ int flags
+ void * value
+ int size
+
+void
+_ead_sort(ead)
+ _ead ead
+
+int
+_ead_use_fea2list(ead, src)
+ _ead ead
+ void * src
+
+int
+_ead_value_size(ead, index)
+ _ead ead
+ int index
+
+int
+_ead_write(ead, path, handle, flags)
+ _ead ead
+ char * path
+ int handle
+ int flags
diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/MANIFEST b/gnu/usr.bin/perl/os2/OS2/ExtAttr/MANIFEST
new file mode 100644
index 00000000000..b1a8e80e772
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/MANIFEST
@@ -0,0 +1,8 @@
+Changes
+ExtAttr.pm
+ExtAttr.xs
+MANIFEST
+Makefile.PL
+myea.h
+t/os2_ea.t
+typemap
diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/Makefile.PL b/gnu/usr.bin/perl/os2/OS2/ExtAttr/Makefile.PL
new file mode 100644
index 00000000000..35680288b8c
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/Makefile.PL
@@ -0,0 +1,11 @@
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'OS2::ExtAttr',
+ 'VERSION_FROM' => 'ExtAttr.pm', # finds $VERSION
+ MAN3PODS => ' ', # Pods will be built by installman.
+ 'LIBS' => [''], # e.g., '-lm'
+ 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING'
+ 'INC' => '', # e.g., '-I/usr/include/other'
+);
diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/myea.h b/gnu/usr.bin/perl/os2/OS2/ExtAttr/myea.h
new file mode 100644
index 00000000000..ec4dc81f993
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/myea.h
@@ -0,0 +1,2 @@
+#include <sys/ea.h>
+#include <sys/ead.h>
diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/t/os2_ea.t b/gnu/usr.bin/perl/os2/OS2/ExtAttr/t/os2_ea.t
new file mode 100644
index 00000000000..a1da398d458
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/t/os2_ea.t
@@ -0,0 +1,79 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib' if -d 'lib';
+ require Config; import Config;
+ if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+# 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..21\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use OS2::ExtAttr;
+$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):
+
+unlink 't.out' if -f 't.out';
+system 'cmd', '/c', 'echo OK > t.out';
+
+{
+ my %a;
+ tie %a, 'OS2::ExtAttr', 't.out';
+ print "ok 2\n";
+
+ keys %a == 0 ? print "ok 3\n" : print "not ok 3\n";
+ $a{'++'} = '---';
+ print "ok 4\n";
+ $a{'AAA'} = 'xyz';
+ print "ok 5\n";
+}
+
+{
+ my %a;
+ tie %a, 'OS2::ExtAttr', 't.out';
+ print "ok 6\n";
+
+ my $c = keys %a;
+ $c == 2 ? print "ok 7\n" : print "not ok 7\n# c=$c\n";
+ my @b = sort keys %a;
+ "@b" eq '++ AAA' ? print "ok 8\n" : print "not ok 8\n# keys=`@b'\n";
+ $a{'++'} eq '---' ? print "ok 9\n" : print "not ok 9\n";;
+ $a{'AAA'} eq 'xyz' ? print "ok 10\n" : print "not ok 10\n# aaa->`$a{AAA}'\n";
+ $c = delete $a{'++'};
+ $c eq '---' ? print "ok 11\n" : print "not ok 11\n# deleted->`$c'\n";;
+}
+
+print "ok 12\n";
+
+{
+ my %a;
+ tie %a, 'OS2::ExtAttr', 't.out';
+ print "ok 13\n";
+
+ keys %a == 1 ? print "ok 14\n" : print "not ok 14\n";
+ my @b = sort keys %a;
+ "@b" eq 'AAA' ? print "ok 15\n" : print "not ok 15\n";
+ $a{'AAA'} eq 'xyz' ? print "ok 16\n" : print "not ok 16\n";;
+ ! exists $a{'+'} ? print "ok 17\n" : print "not ok 17\n";;
+ ! defined $a{'+'} ? print "ok 18\n" : print "not ok 18\n# ->`$a{'++'}'\n";;
+ ! exists $a{'++'} ? print "ok 19\n" : print "not ok 19\n";;
+ ! defined $a{'++'} ? print "ok 20\n" : print "not ok 20\n# ->`$a{'++'}'\n";;
+}
+
+print "ok 21\n";
+unlink 't.out';
diff --git a/gnu/usr.bin/perl/os2/OS2/ExtAttr/typemap b/gnu/usr.bin/perl/os2/OS2/ExtAttr/typemap
new file mode 100644
index 00000000000..a5ff8d63ac3
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/ExtAttr/typemap
@@ -0,0 +1,2 @@
+struct _ea * T_PTR
+_ead T_PTR
diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/Changes b/gnu/usr.bin/perl/os2/OS2/PrfDB/Changes
new file mode 100644
index 00000000000..3e8bf3f5805
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/Changes
@@ -0,0 +1,5 @@
+Revision history for Perl extension OS2::PrfDB.
+
+0.01 Tue Mar 26 19:35:27 1996
+ - original version; created by h2xs 1.16
+0.02: Field do-not-close added to OS2::Prf::Hini.
diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/MANIFEST b/gnu/usr.bin/perl/os2/OS2/PrfDB/MANIFEST
new file mode 100644
index 00000000000..fb96b03c5d5
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/MANIFEST
@@ -0,0 +1,7 @@
+Changes
+MANIFEST
+Makefile.PL
+PrfDB.pm
+PrfDB.xs
+t/os2_prfdb.t
+typemap
diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/Makefile.PL b/gnu/usr.bin/perl/os2/OS2/PrfDB/Makefile.PL
new file mode 100644
index 00000000000..39521685dfc
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/Makefile.PL
@@ -0,0 +1,11 @@
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'OS2::PrfDB',
+ 'VERSION_FROM' => 'PrfDB.pm', # finds $VERSION
+ MAN3PODS => ' ', # Pods will be built by installman.
+ 'LIBS' => [''], # e.g., '-lm'
+ 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING'
+ 'INC' => '', # e.g., '-I/usr/include/other'
+);
diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.pm b/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.pm
new file mode 100644
index 00000000000..41d7dba2f1c
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.pm
@@ -0,0 +1,314 @@
+package OS2::PrfDB;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT);
+
+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(
+ AnyIni UserIni SystemIni
+ );
+$VERSION = '0.02';
+
+bootstrap OS2::PrfDB $VERSION;
+
+# Preloaded methods go here.
+
+sub AnyIni {
+ new_from_int OS2::PrfDB::Hini OS2::Prf::System(0),
+ 'Anyone of two "systemish" databases', 1;
+}
+
+sub UserIni {
+ new_from_int OS2::PrfDB::Hini OS2::Prf::System(1), 'User settings database', 1;
+}
+
+sub SystemIni {
+ new_from_int OS2::PrfDB::Hini OS2::Prf::System(2),'System settings database',1;
+}
+
+use vars qw{$debug @ISA};
+use Tie::Hash;
+push @ISA, qw{Tie::Hash};
+
+# Internal structure 0 => HINI, 1 => array of entries, 2 => iterator.
+
+sub TIEHASH {
+ die "Usage: tie %arr, OS2::PrfDB, filename\n" unless @_ == 2;
+ my ($obj, $file) = @_;
+ my $hini = ref $file eq 'OS2::PrfDB::Hini' ? $file
+ : new OS2::PrfDB::Hini $file;
+ die "Error opening profile database `$file': $!" unless $hini;
+ # print "tiehash `@_', hini $hini\n" if $debug;
+ bless [$hini, undef, undef];
+}
+
+sub STORE {
+ my ($self, $key, $val) = @_;
+ die unless @_ == 3;
+ die unless ref $val eq 'HASH';
+ my %sub;
+ tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key;
+ %sub = %$val;
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+ die unless @_ == 2;
+ my %sub;
+ tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key;
+ \%sub;
+}
+
+sub DELETE {
+ my ($self, $key) = @_;
+ die unless @_ == 2;
+ my %sub;
+ tie %sub, 'OS2::PrfDB::Sub', $self->[0], $key;
+ %sub = ();
+}
+
+# CLEAR ???? - deletion of the whole
+
+sub EXISTS {
+ my ($self, $key) = @_;
+ die unless @_ == 2;
+ return OS2::Prf::GetLength($self->[0]->[0], $key, undef) >= 0;
+}
+
+sub FIRSTKEY {
+ my $self = shift;
+ my $keys = OS2::Prf::Get($self->[0]->[0], undef, undef);
+ return undef unless defined $keys;
+ chop($keys);
+ $self->[1] = [split /\0/, $keys];
+ # print "firstkey1 $self, `$self->[3]->[0], $self->[3]->[1]'\n" if $debug;
+ $self->[2] = 0;
+ return $self->[1]->[0];
+ # OS2::Prf::Get($self->[0]->[0], $self->[2], $self->[3]->[0]));
+}
+
+sub NEXTKEY {
+ # print "nextkey `@_'\n" if $debug;
+ my $self = shift;
+ return undef unless $self->[2]++ < $#{$self->[1]};
+ my $key = $self->[1]->[$self->[2]];
+ return $key; #, OS2::Prf::Get($self->[0]->[0], $self->[2], $key));
+}
+
+package OS2::PrfDB::Hini;
+
+sub new {
+ die "Usage: new OS2::PrfDB::Hini filename\n" unless @_ == 2;
+ shift;
+ my $file = shift;
+ my $hini = OS2::Prf::Open($file);
+ die "Error opening profile database `$file': $!" unless $hini;
+ bless [$hini, $file];
+}
+
+# Takes HINI and file name:
+
+sub new_from_int { shift; bless [@_] }
+
+# Internal structure 0 => HINI, 1 => filename, 2 => do-not-close.
+
+sub DESTROY {
+ my $self = shift;
+ my $hini = $self->[0];
+ unless ($self->[2]) {
+ OS2::Prf::Close($hini) or die "Error closing profile `$self->[1]': $!";
+ }
+}
+
+package OS2::PrfDB::Sub;
+use vars qw{$debug @ISA};
+use Tie::Hash;
+@ISA = qw{Tie::Hash};
+
+# Internal structure 0 => HINI, 1 => array of entries, 2 => iterator,
+# 3 => appname.
+
+sub TIEHASH {
+ die "Usage: tie %arr, OS2::PrfDB::Sub, filename, appname\n" unless @_ == 3;
+ my ($obj, $file, $app) = @_;
+ my $hini = ref $file eq 'OS2::PrfDB::Hini' ? $file
+ : new OS2::PrfDB::Hini $file;
+ die "Error opening profile database `$file': $!" unless $hini;
+ # print "tiehash `@_', hini $hini\n" if $debug;
+ bless [$hini, undef, undef, $app];
+}
+
+sub STORE {
+ my ($self, $key, $val) = @_;
+ die unless @_ == 3;
+ OS2::Prf::Set($self->[0]->[0], $self->[3], $key, $val);
+}
+
+sub FETCH {
+ my ($self, $key) = @_;
+ die unless @_ == 2;
+ OS2::Prf::Get($self->[0]->[0], $self->[3], $key);
+}
+
+sub DELETE {
+ my ($self, $key) = @_;
+ die unless @_ == 2;
+ OS2::Prf::Set($self->[0]->[0], $self->[3], $key, undef);
+}
+
+# CLEAR ???? - deletion of the whole
+
+sub EXISTS {
+ my ($self, $key) = @_;
+ die unless @_ == 2;
+ return OS2::Prf::GetLength($self->[0]->[0], $self->[3], $key) >= 0;
+}
+
+sub FIRSTKEY {
+ my $self = shift;
+ my $keys = OS2::Prf::Get($self->[0]->[0], $self->[3], undef);
+ return undef unless defined $keys;
+ chop($keys);
+ $self->[1] = [split /\0/, $keys];
+ # print "firstkey1 $self, `$self->[3]->[0], $self->[3]->[1]'\n" if $debug;
+ $self->[2] = 0;
+ return $self->[1]->[0];
+ # OS2::Prf::Get($self->[0]->[0], $self->[2], $self->[3]->[0]));
+}
+
+sub NEXTKEY {
+ # print "nextkey `@_'\n" if $debug;
+ my $self = shift;
+ return undef unless $self->[2]++ < $#{$self->[1]};
+ my $key = $self->[1]->[$self->[2]];
+ return $key; #, OS2::Prf::Get($self->[0]->[0], $self->[2], $key));
+}
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+# Below is the stub of documentation for your module. You better edit it!
+
+=head1 NAME
+
+OS2::PrfDB - Perl extension for access to OS/2 setting database.
+
+=head1 SYNOPSIS
+
+ use OS2::PrfDB;
+ tie %settings, OS2::PrfDB, 'my.ini';
+ tie %subsettings, OS2::PrfDB::Sub, 'my.ini', 'mykey';
+
+ print "$settings{firstkey}{subkey}\n";
+ print "$subsettings{subkey}\n";
+
+ tie %system, OS2::PrfDB, SystemIni;
+ $system{myapp}{mykey} = "myvalue";
+
+
+=head1 DESCRIPTION
+
+The extention provides both high-level and low-level access to .ini
+files.
+
+=head2 High level access
+
+High-level access is the tie-hash access via two packages:
+C<OS2::PrfDB> and C<OS2::PrfDB::Sub>. First one supports one argument,
+the name of the file to open, the second one the name of the file to
+open and so called I<Application name>, or the primary key of the
+database.
+
+ tie %settings, OS2::PrfDB, 'my.ini';
+ tie %subsettings, OS2::PrfDB::Sub, 'my.ini', 'mykey';
+
+One may substitute a handle for already opened ini-file instead of the
+file name (obtained via low-level access functions). In particular, 3
+functions SystemIni(), UserIni(), and AnyIni() provide handles to the
+"systemish" databases. AniIni will read from both, and write into User
+database.
+
+=head2 Low-level access
+
+Low-level access functions reside in the package C<OS2::Prf>. They are
+
+=over 14
+
+=item C<Open(file)>
+
+Opens the database, returns an I<integer handle>.
+
+=item C<Close(hndl)>
+
+Closes the database given an I<integer handle>.
+
+=item C<Get(hndl, appname, key)>
+
+Retrieves data from the database given 2-part-key C<appname> C<key>.
+If C<key> is C<undef>, return the "\0" delimited list of C<key>s,
+terminated by \0. If C<appname> is C<undef>, returns the list of
+possible C<appname>s in the same form.
+
+=item C<GetLength(hndl, appname, key)>
+
+Same as above, but returns the length of the value.
+
+=item C<Set(hndl, appname, key, value [ , length ])>
+
+Sets the value. If the C<value> is not defined, removes the C<key>. If
+the C<key> is not defined, removes the C<appname>.
+
+=item C<System(val)>
+
+Return an I<integer handle> associated with the system database. If
+C<val> is 1, it is I<User> database, if 2, I<System> database, if
+0, handle for "both" of them: the handle works for read from any one,
+and for write into I<User> one.
+
+=item C<Profiles()>
+
+returns a reference to a list of two strings, giving names of the
+I<User> and I<System> databases.
+
+=item C<SetUser(file)>
+
+B<(Not tested.)> Sets the profile name of the I<User> database. The
+application should have a message queue to use this function!
+
+=back
+
+=head2 Integer handles
+
+To convert a name or an integer handle into an object acceptable as
+argument to tie() interface, one may use the following functions from
+the package C<OS2::Prf::Hini>:
+
+=over 14
+
+=item C<new(package, file)>
+
+=item C<new_from_int(package, int_hndl [ , filename ])>
+
+=back
+
+=head2 Exports
+
+SystemIni(), UserIni(), and AnyIni().
+
+=head1 AUTHOR
+
+Ilya Zakharevich, ilya@math.ohio-state.edu
+
+=head1 SEE ALSO
+
+perl(1).
+
+=cut
+
diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.xs b/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.xs
new file mode 100644
index 00000000000..a5b2c89ca6f
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/PrfDB.xs
@@ -0,0 +1,131 @@
+#define INCL_WINSHELLDATA /* Or use INCL_WIN, INCL_PM, */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include <os2.h>
+#ifdef __cplusplus
+}
+#endif
+
+#define Prf_Open(pszFileName) SaveWinError(PrfOpenProfile(Perl_hab, (pszFileName)))
+#define Prf_Close(hini) (!CheckWinError(PrfCloseProfile(hini)))
+
+SV *
+Prf_Get(HINI hini, PSZ app, PSZ key) {
+ ULONG len;
+ BOOL rc;
+ SV *sv;
+
+ if (CheckWinError(PrfQueryProfileSize(hini, app, key, &len))) return &sv_undef;
+ sv = newSVpv("", 0);
+ SvGROW(sv, len);
+ if (CheckWinError(PrfQueryProfileData(hini, app, key, SvPVX(sv), &len))
+ || (len == 0 && (app == NULL || key == NULL))) { /* Somewhy needed. */
+ SvREFCNT_dec(sv);
+ return &sv_undef;
+ }
+ SvCUR_set(sv, len);
+ *SvEND(sv) = 0;
+ return sv;
+}
+
+U32
+Prf_GetLength(HINI hini, PSZ app, PSZ key) {
+ U32 len;
+
+ if (CheckWinError(PrfQueryProfileSize(hini, app, key, &len))) return -1;
+ return len;
+}
+
+#define Prf_Set(hini, app, key, s, l) \
+ (!(CheckWinError(PrfWriteProfileData(hini, app, key, s, l))))
+
+#define Prf_System(key) \
+ ( (key) ? ( (key) == 1 ? HINI_USERPROFILE \
+ : ( (key) == 2 ? HINI_SYSTEMPROFILE \
+ : (die("Wrong profile id %i", key), 0) )) \
+ : HINI_PROFILE)
+
+SV*
+Prf_Profiles()
+{
+ AV *av = newAV();
+ SV *rv;
+ char user[257];
+ char system[257];
+ PRFPROFILE info = { 257, user, 257, system};
+
+ if (CheckWinError(PrfQueryProfile(Perl_hab, &info))) return &sv_undef;
+ if (info.cchUserName > 257 || info.cchSysName > 257)
+ die("Panic: Profile names too long");
+ av_push(av, newSVpv(user, info.cchUserName - 1));
+ av_push(av, newSVpv(system, info.cchSysName - 1));
+ rv = newRV((SV*)av);
+ SvREFCNT_dec(av);
+ return rv;
+}
+
+BOOL
+Prf_SetUser(SV *sv)
+{
+ char user[257];
+ char system[257];
+ PRFPROFILE info = { 257, user, 257, system};
+
+ if (!SvPOK(sv)) die("User profile name not defined");
+ if (SvCUR(sv) > 256) die("User profile name too long");
+ if (CheckWinError(PrfQueryProfile(Perl_hab, &info))) return 0;
+ if (info.cchSysName > 257)
+ die("Panic: System profile name too long");
+ info.cchUserName = SvCUR(sv) + 1;
+ info.pszUserName = SvPVX(sv);
+ return !CheckWinError(PrfReset(Perl_hab, &info));
+}
+
+MODULE = OS2::PrfDB PACKAGE = OS2::Prf PREFIX = Prf_
+
+HINI
+Prf_Open(pszFileName)
+ PSZ pszFileName;
+
+BOOL
+Prf_Close(hini)
+ HINI hini;
+
+SV *
+Prf_Get(hini, app, key)
+ HINI hini;
+ PSZ app;
+ PSZ key;
+
+int
+Prf_Set(hini, app, key, s, l = (SvPOK(ST(3)) ? SvCUR(ST(3)): -1))
+ HINI hini;
+ PSZ app;
+ PSZ key;
+ PSZ s;
+ ULONG l;
+
+U32
+Prf_GetLength(hini, app, key)
+ HINI hini;
+ PSZ app;
+ PSZ key;
+
+HINI
+Prf_System(key)
+ int key;
+
+SV*
+Prf_Profiles()
+
+BOOL
+Prf_SetUser(sv)
+ SV *sv
+
+BOOT:
+ Acquire_hab();
diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/t/os2_prfdb.t b/gnu/usr.bin/perl/os2/OS2/PrfDB/t/os2_prfdb.t
new file mode 100644
index 00000000000..b9f7d90ae22
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/t/os2_prfdb.t
@@ -0,0 +1,190 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib' if -d 'lib';
+ require Config; import Config;
+ if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)PrfDB\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+# 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..48\n"; }
+END {print "not ok 1\n" unless $loaded;}
+use OS2::PrfDB;
+$loaded = 1;
+use strict;
+
+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):
+
+my $inifile = "my.ini";
+
+unlink $inifile if -w $inifile;
+
+my $ini = OS2::Prf::Open($inifile);
+print( ($ini ? "": "not "), "ok 2\n# HINI=`$ini'\n");
+
+print( (OS2::Prf::GetLength($ini,'aaa', 'bbb') != -1) ?
+ "not ok 3\n# err: `$^E'\n" : "ok 3\n");
+
+
+print( OS2::Prf::Set($ini,'aaa', 'bbb','xyz') ? "ok 4\n" :
+ "not ok 4\n# err: `$^E'\n");
+
+my $len = OS2::Prf::GetLength($ini,'aaa', 'bbb');
+print( $len == 3 ? "ok 5\n" : "not ok 5# len: `$len' err: `$^E'\n");
+
+my $val = OS2::Prf::Get($ini,'aaa', 'bbb');
+print( $val eq 'xyz' ? "ok 6\n" : "not ok 6# val: `$val' err: `$^E'\n");
+
+$val = OS2::Prf::Get($ini,'aaa', undef);
+print( $val eq "bbb\0" ? "ok 7\n" : "not ok 7# val: `$val' err: `$^E'\n");
+
+$val = OS2::Prf::Get($ini, undef, undef);
+print( $val eq "aaa\0" ? "ok 8\n" : "not ok 8# val: `$val' err: `$^E'\n");
+
+my $res = OS2::Prf::Set($ini,'aaa', 'bbb',undef);
+print( $res ? "ok 9\n" : "not ok 9# err: `$^E'\n");
+
+$val = OS2::Prf::Get($ini, undef, undef);
+print( (! defined $val) ? "ok 10\n" : "not ok 10# val: `$val' err: `$^E'\n");
+
+$val = OS2::Prf::Get($ini,'aaa', undef);
+print( (! defined $val) ? "ok 11\n" : "not ok 11# val: `$val' err: `$^E'\n");
+
+print((OS2::Prf::Close($ini) ? "" : "not ") . "ok 12\n");
+
+my $files = OS2::Prf::Profiles();
+print( (defined $files) ? "ok 13\n" : "not ok 13# err: `$^E'\n");
+print( (@$files == 2) ? "ok 14\n" : "not ok 14# `@$files' err: `$^E'\n");
+print "# `@$files'\n";
+
+$ini = OS2::Prf::Open($inifile);
+print( ($ini ? "": "not "), "ok 15\n# HINI=`$ini'\n");
+
+
+print( OS2::Prf::Set($ini,'aaa', 'ccc','xyz') ? "ok 16\n" :
+ "not ok 16\n# err: `$^E'\n");
+
+print( OS2::Prf::Set($ini,'aaa', 'ddd','123') ? "ok 17\n" :
+ "not ok 17\n# err: `$^E'\n");
+
+print( OS2::Prf::Set($ini,'bbb', 'xxx','abc') ? "ok 18\n" :
+ "not ok 18\n# err: `$^E'\n");
+
+print( OS2::Prf::Set($ini,'bbb', 'yyy','456') ? "ok 19\n" :
+ "not ok 19\n# err: `$^E'\n");
+
+OS2::Prf::Close($ini);
+
+my %hash1;
+
+tie %hash1, 'OS2::PrfDB::Sub', $inifile, 'aaa';
+$OS2::PrfDB::Sub::debug = 1;
+print "ok 20\n";
+
+my @a1 = keys %hash1;
+print (@a1 == 2 ? "ok 21\n" : "not ok 21\n# `@a1'\n");
+
+my @a2 = sort @a1;
+print ("@a2" eq "ccc ddd" ? "ok 22\n" : "not ok 22\n# `@a2'\n");
+
+$val = $hash1{ccc};
+print ($val eq "xyz" ? "ok 23\n" : "not ok 23\n# `$val'\n");
+
+$val = $hash1{ddd};
+print ($val eq "123" ? "ok 24\n" : "not ok 24\n# `$val'\n");
+
+print (exists $hash1{ccc} ? "ok 25\n" : "not ok 25\n# `$val'\n");
+
+print (!exists $hash1{hhh} ? "ok 26\n" : "not ok 26\n# `$val'\n");
+
+$hash1{hhh} = 12;
+print (exists $hash1{hhh} ? "ok 27\n" : "not ok 27\n# `$val'\n");
+
+$val = $hash1{hhh};
+print ($val eq "12" ? "ok 28\n" : "not ok 28\n# `$val'\n");
+
+delete $hash1{ccc};
+
+untie %hash1;
+print "ok 29\n";
+
+tie %hash1, 'OS2::PrfDB::Sub', $inifile, 'aaa';
+print "ok 30\n";
+
+@a1 = keys %hash1;
+print (@a1 == 2 ? "ok 31\n" : "not ok 31\n# `@a1'\n");
+
+@a2 = sort @a1;
+print ("@a2" eq "ddd hhh" ? "ok 32\n" : "not ok 32\n# `@a2'\n");
+
+print (exists $hash1{hhh} ? "ok 33\n" : "not ok 33\n# `$val'\n");
+
+$val = $hash1{hhh};
+print ($val eq "12" ? "ok 34\n" : "not ok 34\n# `$val'\n");
+
+%hash1 = ();
+print "ok 35\n";
+
+%hash1 = ( hhh => 12, ddd => 5);
+
+untie %hash1;
+
+my %hash;
+
+tie %hash, 'OS2::PrfDB', $inifile;
+print "ok 36\n";
+
+@a1 = keys %hash;
+print (@a1 == 2 ? "ok 37\n" : "not ok 37\n# `@a1'\n");
+
+@a2 = sort @a1;
+print ("@a2" eq "aaa bbb" ? "ok 38\n" : "not ok 38\n# `@a2'\n");
+
+print (exists $hash{aaa} ? "ok 39\n" : "not ok 39\n# `$val'\n");
+
+$val = $hash{aaa};
+print (ref $val eq "HASH" ? "ok 40\n" : "not ok 40\n# `$val'\n");
+
+%hash1 = %$val;
+print "ok 41\n";
+
+@a1 = keys %hash1;
+print (@a1 == 2 ? "ok 42\n" : "not ok 31\n# `@a1'\n");
+
+@a2 = sort @a1;
+print ("@a2" eq "ddd hhh" ? "ok 43\n" : "not ok 43\n# `@a2'\n");
+
+print (exists $hash1{hhh} ? "ok 44\n" : "not ok 44\n# `$val'\n");
+
+$val = $hash1{hhh};
+print ($val eq "12" ? "ok 45\n" : "not ok 45\n# `$val'\n");
+
+$hash{nnn}{mmm} = 67;
+print "ok 46\n";
+
+untie %hash;
+
+my %hash2;
+
+tie %hash2, 'OS2::PrfDB', $inifile;
+print "ok 47\n";
+
+print ($hash2{nnn}->{mmm} eq "67" ? "ok 48\n" : "not ok 48\n# `$val'\n");
+
+untie %hash2;
+unlink $inifile;
diff --git a/gnu/usr.bin/perl/os2/OS2/PrfDB/typemap b/gnu/usr.bin/perl/os2/OS2/PrfDB/typemap
new file mode 100644
index 00000000000..0b91f3750a6
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/PrfDB/typemap
@@ -0,0 +1,14 @@
+BOOL T_IV
+ULONG T_IV
+HINI T_IV
+HAB T_IV
+PSZ T_PVNULL
+
+#############################################################################
+INPUT
+T_PVNULL
+ $var = ( SvOK($arg) ? ($type)SvPV($arg,na) : NULL )
+#############################################################################
+OUTPUT
+T_PVNULL
+ sv_setpv((SV*)$arg, $var);
diff --git a/gnu/usr.bin/perl/os2/OS2/Process/MANIFEST b/gnu/usr.bin/perl/os2/OS2/Process/MANIFEST
new file mode 100644
index 00000000000..0d90d15fca6
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/Process/MANIFEST
@@ -0,0 +1,4 @@
+MANIFEST
+Makefile.PL
+Process.pm
+Process.xs
diff --git a/gnu/usr.bin/perl/os2/OS2/Process/Makefile.PL b/gnu/usr.bin/perl/os2/OS2/Process/Makefile.PL
new file mode 100644
index 00000000000..b7a295f8575
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/Process/Makefile.PL
@@ -0,0 +1,11 @@
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ 'NAME' => 'OS2::Process',
+ 'VERSION' => '0.1',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ 'LIBS' => [''], # e.g., '-lm'
+ 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING'
+ 'INC' => '', # e.g., '-I/usr/include/other'
+);
diff --git a/gnu/usr.bin/perl/os2/OS2/Process/Process.pm b/gnu/usr.bin/perl/os2/OS2/Process/Process.pm
new file mode 100644
index 00000000000..9216bb1e055
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/Process/Process.pm
@@ -0,0 +1,112 @@
+package OS2::Process;
+
+require Exporter;
+require DynaLoader;
+require AutoLoader;
+
+@ISA = qw(Exporter DynaLoader);
+# Items to export into callers namespace by default. Note: do not export
+# names by default without a very good reason. Use EXPORT_OK instead.
+# Do not simply export all your public functions/methods/constants.
+@EXPORT = qw(
+ P_BACKGROUND
+ P_DEBUG
+ P_DEFAULT
+ P_DETACH
+ P_FOREGROUND
+ P_FULLSCREEN
+ P_MAXIMIZE
+ P_MINIMIZE
+ P_NOCLOSE
+ P_NOSESSION
+ P_NOWAIT
+ P_OVERLAY
+ P_PM
+ P_QUOTE
+ P_SESSION
+ P_TILDE
+ P_UNRELATED
+ P_WAIT
+ P_WINDOWED
+);
+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.
+
+ local($constname);
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ $val = constant($constname, @_ ? $_[0] : 0);
+ if ($! != 0) {
+ if ($! =~ /Invalid/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD;
+ }
+ else {
+ ($pack,$file,$line) = caller;
+ die "Your vendor has not defined OS2::Process macro $constname, used at $file line $line.
+";
+ }
+ }
+ eval "sub $AUTOLOAD { $val }";
+ goto &$AUTOLOAD;
+}
+
+bootstrap OS2::Process;
+
+# Preloaded methods go here.
+
+# Autoload methods go after __END__, and are processed by the autosplit program.
+
+1;
+__END__
+
+=head1 NAME
+
+OS2::Process - exports constants for system() call on OS2.
+
+=head1 SYNOPSIS
+
+ use OS2::Process;
+ $pid = system(P_PM+P_BACKGROUND, "epm.exe");
+
+=head1 DESCRIPTION
+
+the builtin function system() under OS/2 allows an optional first
+argument which denotes the mode of the process. Note that this argument is
+recognized only if it is strictly numerical.
+
+You can use either one of the process modes:
+
+ P_WAIT (0) = wait until child terminates (default)
+ P_NOWAIT = do not wait until child terminates
+ P_SESSION = new session
+ P_DETACH = detached
+ P_PM = PM program
+
+and optionally add PM and session option bits:
+
+ P_DEFAULT (0) = default
+ P_MINIMIZE = minimized
+ P_MAXIMIZE = maximized
+ P_FULLSCREEN = fullscreen (session only)
+ P_WINDOWED = windowed (session only)
+
+ P_FOREGROUND = foreground (if running in foreground)
+ P_BACKGROUND = background
+
+ P_NOCLOSE = don't close window on exit (session only)
+
+ P_QUOTE = quote all arguments
+ P_TILDE = MKS argument passing convention
+ P_UNRELATED = do not kill child when father terminates
+
+=head1 AUTHOR
+
+Andreas Kaiser <ak@ananke.s.bawue.de>.
+
+=head1 SEE ALSO
+
+C<spawn*>() system calls.
+
+=cut
diff --git a/gnu/usr.bin/perl/os2/OS2/Process/Process.xs b/gnu/usr.bin/perl/os2/OS2/Process/Process.xs
new file mode 100644
index 00000000000..bdb2ece7a08
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/Process/Process.xs
@@ -0,0 +1,154 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <process.h>
+
+static int
+not_here(s)
+char *s;
+{
+ croak("%s not implemented on this architecture", s);
+ return -1;
+}
+
+static unsigned long
+constant(name, arg)
+char *name;
+int arg;
+{
+ errno = 0;
+ if (name[0] == 'P' && name[1] == '_') {
+ if (strEQ(name, "P_BACKGROUND"))
+#ifdef P_BACKGROUND
+ return P_BACKGROUND;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_DEBUG"))
+#ifdef P_DEBUG
+ return P_DEBUG;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_DEFAULT"))
+#ifdef P_DEFAULT
+ return P_DEFAULT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_DETACH"))
+#ifdef P_DETACH
+ return P_DETACH;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_FOREGROUND"))
+#ifdef P_FOREGROUND
+ return P_FOREGROUND;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_FULLSCREEN"))
+#ifdef P_FULLSCREEN
+ return P_FULLSCREEN;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_MAXIMIZE"))
+#ifdef P_MAXIMIZE
+ return P_MAXIMIZE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_MINIMIZE"))
+#ifdef P_MINIMIZE
+ return P_MINIMIZE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_NOCLOSE"))
+#ifdef P_NOCLOSE
+ return P_NOCLOSE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_NOSESSION"))
+#ifdef P_NOSESSION
+ return P_NOSESSION;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_NOWAIT"))
+#ifdef P_NOWAIT
+ return P_NOWAIT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_OVERLAY"))
+#ifdef P_OVERLAY
+ return P_OVERLAY;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_PM"))
+#ifdef P_PM
+ return P_PM;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_QUOTE"))
+#ifdef P_QUOTE
+ return P_QUOTE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_SESSION"))
+#ifdef P_SESSION
+ return P_SESSION;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_TILDE"))
+#ifdef P_TILDE
+ return P_TILDE;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_UNRELATED"))
+#ifdef P_UNRELATED
+ return P_UNRELATED;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_WAIT"))
+#ifdef P_WAIT
+ return P_WAIT;
+#else
+ goto not_there;
+#endif
+ if (strEQ(name, "P_WINDOWED"))
+#ifdef P_WINDOWED
+ return P_WINDOWED;
+#else
+ goto not_there;
+#endif
+ }
+
+ errno = EINVAL;
+ return 0;
+
+not_there:
+ errno = ENOENT;
+ return 0;
+}
+
+
+MODULE = OS2::Process PACKAGE = OS2::Process
+
+
+unsigned long
+constant(name,arg)
+ char * name
+ int arg
+
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/Changes b/gnu/usr.bin/perl/os2/OS2/REXX/Changes
new file mode 100644
index 00000000000..46b38ef46ce
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/Changes
@@ -0,0 +1,4 @@
+0.2:
+ After fixpak17 a lot of other places have mismatched lengths
+returned in the REXXPool interface.
+ Also drop does not work on stems any more.
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/MANIFEST b/gnu/usr.bin/perl/os2/OS2/REXX/MANIFEST
new file mode 100644
index 00000000000..4ac81492e4a
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/MANIFEST
@@ -0,0 +1,14 @@
+Changes
+MANIFEST
+Makefile.PL
+REXX.pm
+REXX.xs
+t/rx_cmprt.t
+t/rx_dllld.t
+t/rx_objcall.t
+t/rx_sql.test
+t/rx_tiesql.test
+t/rx_tievar.t
+t/rx_tieydb.t
+t/rx_varset.t
+t/rx_vrexx.t
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/Makefile.PL b/gnu/usr.bin/perl/os2/OS2/REXX/Makefile.PL
new file mode 100644
index 00000000000..0b43a36612e
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/Makefile.PL
@@ -0,0 +1,8 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'OS2::REXX',
+ VERSION => '0.21',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes',
+);
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/REXX.pm b/gnu/usr.bin/perl/os2/OS2/REXX/REXX.pm
new file mode 100644
index 00000000000..4580ede2947
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/REXX.pm
@@ -0,0 +1,389 @@
+package OS2::REXX;
+
+use Carp;
+require Exporter;
+require DynaLoader;
+@ISA = qw(Exporter DynaLoader);
+# Items to export into callers namespace by default
+# (move infrequently used names to @EXPORT_OK below)
+@EXPORT = qw(REXX_call REXX_eval REXX_eval_with);
+# Other items we are prepared to export if requested
+@EXPORT_OK = qw(drop);
+
+sub AUTOLOAD {
+ $AUTOLOAD =~ /^OS2::REXX::.+::(.+)$/
+ or confess("Undefined subroutine &$AUTOLOAD called");
+ return undef if $1 eq "DESTROY";
+ $_[0]->find($1)
+ or confess("Can't find entry '$1' to DLL '$_[0]->{File}'");
+ goto &$AUTOLOAD;
+}
+
+@libs = split(/;/, $ENV{'PERL5REXX'} || $ENV{'PERLREXX'} || $ENV{'LIBPATH'} || $ENV{'PATH'});
+%dlls = ();
+
+bootstrap OS2::REXX;
+
+# Preloaded methods go here. Autoload methods go after __END__, and are
+# processed by the autosplit program.
+
+# Cannot autoload, the autoloader is used for the REXX functions.
+
+sub load
+{
+ confess 'Usage: load OS2::REXX <file> [<dirs>]' unless $#_ >= 1;
+ my ($class, $file, @where) = (@_, @libs);
+ return $dlls{$file} if $dlls{$file};
+ my $handle;
+ foreach (@where) {
+ $handle = DynaLoader::dl_load_file("$_/$file.dll");
+ last if $handle;
+ }
+ $handle = DynaLoader::dl_load_file($file) unless $handle;
+ return undef unless $handle;
+ eval "package OS2::REXX::$file; \@ISA = ('OS2::REXX');"
+ . "sub AUTOLOAD {"
+ . " \$OS2::REXX::AUTOLOAD = \$AUTOLOAD;"
+ . " goto &OS2::REXX::AUTOLOAD;"
+ . "} 1;" or die "eval package $@";
+ return $dlls{$file} = bless {Handle => $handle, File => $file, Queue => 'SESSION' }, "OS2::REXX::$file";
+}
+
+sub find
+{
+ my $self = shift;
+ my $file = $self->{File};
+ my $handle = $self->{Handle};
+ my $prefix = exists($self->{Prefix}) ? $self->{Prefix} : "";
+ my $queue = $self->{Queue};
+ foreach (@_) {
+ my $name = "OS2::REXX::${file}::$_";
+ next if defined(&$name);
+ my $addr = DynaLoader::dl_find_symbol($handle, uc $prefix.$_)
+ || DynaLoader::dl_find_symbol($handle, $prefix.$_)
+ or return 0;
+ eval "package OS2::REXX::$file; sub $_".
+ "{ shift; OS2::REXX::_call('$_', $addr, '$queue', \@_); }".
+ "1;"
+ or die "eval sub";
+ }
+ return 1;
+}
+
+sub prefix
+{
+ my $self = shift;
+ $self->{Prefix} = shift;
+}
+
+sub queue
+{
+ my $self = shift;
+ $self->{Queue} = shift;
+}
+
+sub drop
+{ # Supposedly should drop anything with
+ # the given prefix. Unfortunately a
+ # loop is needed after fixpack17.
+&OS2::REXX::_drop(@_);
+}
+
+sub dropall
+{ # Supposedly should drop anything with
+ # the given prefix. Unfortunately a
+ # loop is needed after fixpack17.
+ &OS2::REXX::_drop(@_); # Try to drop them all.
+ my $name;
+ for (@_) {
+ if (/\.$/) {
+ OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator
+ while (($name) = OS2::REXX::_next($_)) {
+ OS2::REXX::_drop($_ . $name);
+ }
+ }
+ }
+}
+
+sub TIESCALAR
+{
+ my ($obj, $name) = @_;
+ $name =~ s/^([\w!?]+)/\U$1\E/;
+ return bless \$name, OS2::REXX::_SCALAR;
+}
+
+sub TIEARRAY
+{
+ my ($obj, $name) = @_;
+ $name =~ s/^([\w!?]+)/\U$1\E/;
+ return bless [$name, 0], OS2::REXX::_ARRAY;
+}
+
+sub TIEHASH
+{
+ my ($obj, $name) = @_;
+ $name =~ s/^([\w!?]+)/\U$1\E/;
+ return bless {Stem => $name}, OS2::REXX::_HASH;
+}
+
+#############################################################################
+package OS2::REXX::_SCALAR;
+
+sub FETCH
+{
+ return OS2::REXX::_fetch(${$_[0]});
+}
+
+sub STORE
+{
+ return OS2::REXX::_set(${$_[0]}, $_[1]);
+}
+
+sub DESTROY
+{
+ return OS2::REXX::_drop(${$_[0]});
+}
+
+#############################################################################
+package OS2::REXX::_ARRAY;
+
+sub FETCH
+{
+ $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1];
+ return OS2::REXX::_fetch($_[0]->[0].'.'.(0+$_[1]));
+}
+
+sub STORE
+{
+ $_[0]->[1] = $_[1] if $_[1] > $_[0]->[1];
+ return OS2::REXX::_set($_[0]->[0].'.'.(0+$_[1]), $_[2]);
+}
+
+#############################################################################
+package OS2::REXX::_HASH;
+
+require Tie::Hash;
+@ISA = ('Tie::Hash');
+
+sub FIRSTKEY
+{
+ my ($self) = @_;
+ my $stem = $self->{Stem};
+
+ delete $self->{List} if exists $self->{List};
+
+ my @list = ();
+ my ($name, $value);
+ OS2::REXX::_fetch('DUMMY'); # reset REXX's first/next iterator
+ while (($name) = OS2::REXX::_next($stem)) {
+ push @list, $name;
+ }
+ my $key = pop @list;
+
+ $self->{List} = \@list;
+ return $key;
+}
+
+sub NEXTKEY
+{
+ return pop @{$_[0]->{List}};
+}
+
+sub EXISTS
+{
+ return defined OS2::REXX::_fetch($_[0]->{Stem}.$_[1]);
+}
+
+sub FETCH
+{
+ return OS2::REXX::_fetch($_[0]->{Stem}.$_[1]);
+}
+
+sub STORE
+{
+ return OS2::REXX::_set($_[0]->{Stem}.$_[1], $_[2]);
+}
+
+sub DELETE
+{
+ OS2::REXX::_drop($_[0]->{Stem}.$_[1]);
+}
+
+#############################################################################
+package OS2::REXX;
+
+1;
+__END__
+
+=head1 NAME
+
+OS2::REXX - access to DLLs with REXX calling convention and REXX runtime.
+
+=head2 NOTE
+
+By default, the REXX variable pool is not available, neither
+to Perl, nor to external REXX functions. To enable it, you need to put
+your code inside C<REXX_call> function. REXX functions which do not use
+variables may be usable even without C<REXX_call> though.
+
+=head1 SYNOPSIS
+
+ use OS2::REXX;
+ $ydb = load OS2::REXX "ydbautil" or die "Cannot load: $!";
+ @pid = $ydb->RxProcId();
+ REXX_call {
+ tie $s, OS2::REXX, "TEST";
+ $s = 1;
+ };
+
+=head1 DESCRIPTION
+
+=head2 Load REXX DLL
+
+ $dll = load OS2::REXX NAME [, WHERE];
+
+NAME is DLL name, without path and extension.
+
+Directories are searched WHERE first (list of dirs), then environment
+paths PERL5REXX, PERLREXX, PATH or, as last resort, OS/2-ish search
+is performed in default DLL path (without adding paths and extensions).
+
+The DLL is not unloaded when the variable dies.
+
+Returns DLL object reference, or undef on failure.
+
+=head2 Define function prefix:
+
+ $dll->prefix(NAME);
+
+Define the prefix of external functions, prepended to the function
+names used within your program, when looking for the entries in the
+DLL.
+
+=head2 Example
+
+ $dll = load OS2::REXX "RexxBase";
+ $dll->prefix("RexxBase_");
+ $dll->Init();
+
+is the same as
+
+ $dll = load OS2::REXX "RexxBase";
+ $dll->RexxBase_Init();
+
+=head2 Define queue:
+
+ $dll->queue(NAME);
+
+Define the name of the REXX queue passed to all external
+functions of this module. Defaults to "SESSION".
+
+Check for functions (optional):
+
+ BOOL = $dll->find(NAME [, NAME [, ...]]);
+
+Returns true if all functions are available.
+
+=head2 Call external REXX function:
+
+ $dll->function(arguments);
+
+Returns the return string if the return code is 0, else undef.
+Dies with error message if the function is not available.
+
+=head1 Accessing REXX-runtime
+
+While calling functions with REXX signature does not require the presence
+of the system REXX DLL, there are some actions which require REXX-runtime
+present. Among them is the access to REXX variables by name.
+
+One enables REXX runtime by bracketing your code by
+
+ REXX_call BLOCK;
+
+(trailing semicolon required!) or
+
+ REXX_call \&subroutine_name;
+
+Inside such a call one has access to REXX variables (see below), and to
+
+ REXX_eval EXPR;
+ REXX_eval_with EXPR,
+ subroutine_name_in_REXX => \&Perl_subroutine
+
+=head2 Bind scalar variable to REXX variable:
+
+ tie $var, OS2::REXX, "NAME";
+
+=head2 Bind array variable to REXX stem variable:
+
+ tie @var, OS2::REXX, "NAME.";
+
+Only scalar operations work so far. No array assignments, no array
+operations, ... FORGET IT.
+
+=head2 Bind hash array variable to REXX stem variable:
+
+ tie %var, OS2::REXX, "NAME.";
+
+To access all visible REXX variables via hash array, bind to "";
+
+No array assignments. No array operations, other than hash array
+operations. Just like the *dbm based implementations.
+
+For the usual REXX stem variables, append a "." to the name,
+as shown above. If the hash key is part of the stem name, for
+example if you bind to "", you cannot use lower case in the stem
+part of the key and it is subject to character set restrictions.
+
+=head2 Erase individual REXX variables (bound or not):
+
+ OS2::REXX::drop("NAME" [, "NAME" [, ...]]);
+
+=head2 Erase REXX variables with given stem (bound or not):
+
+ OS2::REXX::dropall("STEM" [, "STEM" [, ...]]);
+
+=head1 NOTES
+
+Note that while function and variable names are case insensitive in the
+REXX language, function names exported by a DLL and the REXX variables
+(as seen by Perl through the chosen API) are all case sensitive!
+
+Most REXX DLLs export function names all upper case, but there are a
+few which export mixed case names (such as RxExtras). When trying to
+find the entry point, both exact case and all upper case are searched.
+If the DLL exports "RxNap", you have to specify the exact case, if it
+exports "RXOPEN", you can use any case.
+
+To avoid interfering with subroutine names defined by Perl (DESTROY)
+or used within the REXX module (prefix, find), it is best to use mixed
+case and to avoid lowercase only or uppercase only names when calling
+REXX functions. Be consistent. The same function written in different
+ways results in different Perl stubs.
+
+There is no REXX interpolation on variable names, so the REXX variable
+name TEST.ONE is not affected by some other REXX variable ONE. And it
+is not the same variable as TEST.one!
+
+You cannot call REXX functions which are not exported by the DLL.
+While most DLLs export all their functions, some, like RxFTP, export
+only "...LoadFuncs", which registers the functions within REXX only.
+
+You cannot call 16-bit DLLs. The few interesting ones I found
+(FTP,NETB,APPC) do not export their functions.
+
+I do not know whether the REXX API is reentrant with respect to
+exceptions (signals) when the REXX top-level exception handler is
+overridden. So unless you know better than I do, do not access REXX
+variables (probably tied to Perl variables) or call REXX functions
+which access REXX queues or REXX variables in signal handlers.
+
+See C<t/rx*.t> for examples.
+
+=head1 AUTHOR
+
+Andreas Kaiser ak@ananke.s.bawue.de, with additions by Ilya Zakharevich
+ilya@math.ohio-state.edu.
+
+=cut
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/REXX.xs b/gnu/usr.bin/perl/os2/OS2/REXX/REXX.xs
new file mode 100644
index 00000000000..df7646c42e7
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/REXX.xs
@@ -0,0 +1,484 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define INCL_BASE
+#define INCL_REXXSAA
+#include <os2emx.h>
+
+#if 0
+#define INCL_REXXSAA
+#pragma pack(1)
+#define _Packed
+#include <rexxsaa.h>
+#pragma pack()
+#endif
+
+extern ULONG _emx_exception ( EXCEPTIONREPORTRECORD *,
+ EXCEPTIONREGISTRATIONRECORD *,
+ CONTEXTRECORD *,
+ void *);
+
+static RXSTRING * strs;
+static int nstrs;
+static SHVBLOCK * vars;
+static int nvars;
+static char * trace;
+
+static RXSTRING rxcommand = { 9, "RXCOMMAND" };
+static RXSTRING rxsubroutine = { 12, "RXSUBROUTINE" };
+static RXSTRING rxfunction = { 11, "RXFUNCTION" };
+
+static ULONG PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret);
+
+#if 1
+ #define Set RXSHV_SET
+ #define Fetch RXSHV_FETCH
+ #define Drop RXSHV_DROPV
+#else
+ #define Set RXSHV_SYSET
+ #define Fetch RXSHV_SYFET
+ #define Drop RXSHV_SYDRO
+#endif
+
+static long incompartment;
+
+static SV*
+exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler)
+{
+ HMODULE hRexx, hRexxAPI;
+ BYTE buf[200];
+ LONG APIENTRY (*pRexxStart) (LONG, PRXSTRING, PSZ, PRXSTRING,
+ PSZ, LONG, PRXSYSEXIT, PSHORT, PRXSTRING);
+ APIRET APIENTRY (*pRexxRegisterFunctionExe) (PSZ,
+ RexxFunctionHandler *);
+ APIRET APIENTRY (*pRexxDeregisterFunction) (PSZ);
+ RXSTRING args[1];
+ RXSTRING inst[2];
+ RXSTRING result;
+ USHORT retcode;
+ LONG rc;
+ SV *res;
+
+ if (incompartment) die ("Attempt to reenter into REXX compartment");
+ incompartment = 1;
+
+ if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx)
+ || DosLoadModule(buf, sizeof buf, "REXXAPI", &hRexxAPI)
+ || DosQueryProcAddr(hRexx, 0, "RexxStart", (PFN *)&pRexxStart)
+ || DosQueryProcAddr(hRexxAPI, 0, "RexxRegisterFunctionExe",
+ (PFN *)&pRexxRegisterFunctionExe)
+ || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction",
+ (PFN *)&pRexxDeregisterFunction)) {
+ die("REXX not available\n");
+ }
+
+ if (handlerName)
+ pRexxRegisterFunctionExe(handlerName, handler);
+
+ MAKERXSTRING(args[0], NULL, 0);
+ MAKERXSTRING(inst[0], cmd, strlen(cmd));
+ MAKERXSTRING(inst[1], NULL, 0);
+ MAKERXSTRING(result, NULL, 0);
+ rc = pRexxStart(0, args, "StartPerl", inst, "Perl", RXSUBROUTINE, NULL,
+ &retcode, &result);
+
+ incompartment = 0;
+ pRexxDeregisterFunction("StartPerl");
+ DosFreeModule(hRexxAPI);
+ DosFreeModule(hRexx);
+ if (!RXNULLSTRING(result)) {
+ res = newSVpv(RXSTRPTR(result), RXSTRLEN(result));
+ DosFreeMem(RXSTRPTR(result));
+ } else {
+ res = NEWSV(729,0);
+ }
+ if (rc || SvTRUE(GvSV(errgv))) {
+ if (SvTRUE(GvSV(errgv))) {
+ die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(errgv), na)) ;
+ }
+ die ("REXX compartment returned non-zero status %li", rc);
+ }
+
+ return res;
+}
+
+static SV* exec_cv;
+
+static ULONG
+PERLSTART(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
+{
+ return PERLCALL(NULL, argc, argv, queue, ret);
+}
+
+#define in_rexx_compartment() exec_in_REXX("return StartPerl()\r\n", \
+ "StartPerl", PERLSTART)
+#define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment())
+#define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv), \
+ exec_in_REXX(cmd,name,PERLSTART))
+#define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL)
+
+static ULONG
+PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret)
+{
+ EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception };
+ int i, rc;
+ unsigned long len;
+ char *str;
+ char **arr;
+ dSP;
+
+ DosSetExceptionHandler(&xreg);
+
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(sp);
+
+#if 0
+ if (!my_perl) {
+ DosUnsetExceptionHandler(&xreg);
+ return 1;
+ }
+#endif
+
+ if (name) {
+ int ac = 0;
+ char **arr = alloca((argc + 1) * sizeof(char *));
+
+ for (i = 0; i < argc; ++i)
+ arr[ac++] = argv[i].strptr;
+ arr[ac] = NULL;
+
+ rc = perl_call_argv(name, G_SCALAR | G_EVAL, arr);
+ } else if (exec_cv) {
+ SV *cv = exec_cv;
+
+ exec_cv = NULL;
+ rc = perl_call_sv(cv, G_SCALAR | G_EVAL);
+ } else rc = -1;
+
+ SPAGAIN;
+
+ if (rc == 1 && SvOK(TOPs)) {
+ str = SvPVx(POPs, len);
+ if (len > 256)
+ if (DosAllocMem((PPVOID)&ret->strptr, len, PAG_READ|PAG_WRITE|PAG_COMMIT)) {
+ DosUnsetExceptionHandler(&xreg);
+ return 1;
+ }
+ memcpy(ret->strptr, str, len);
+ ret->strlength = len;
+ }
+
+ PUTBACK ;
+ FREETMPS ;
+ LEAVE ;
+
+ if (rc != 1) {
+ DosUnsetExceptionHandler(&xreg);
+ return 1;
+ }
+
+
+ DosUnsetExceptionHandler(&xreg);
+ return 0;
+}
+
+static void
+needstrs(int n)
+{
+ if (n > nstrs) {
+ if (strs)
+ free(strs);
+ nstrs = 2 * n;
+ strs = malloc(nstrs * sizeof(RXSTRING));
+ }
+}
+
+static void
+needvars(int n)
+{
+ if (n > nvars) {
+ if (vars)
+ free(vars);
+ nvars = 2 * n;
+ vars = malloc(nvars * sizeof(SHVBLOCK));
+ }
+}
+
+static void
+initialize(void)
+{
+ needstrs(8);
+ needvars(8);
+ trace = getenv("PERL_REXX_DEBUG");
+}
+
+static int
+not_here(s)
+char *s;
+{
+ croak("%s not implemented on this architecture", s);
+ return -1;
+}
+
+static int
+constant(name, arg)
+char *name;
+int arg;
+{
+ errno = EINVAL;
+ return 0;
+}
+
+
+MODULE = OS2::REXX PACKAGE = OS2::REXX
+
+BOOT:
+ initialize();
+
+int
+constant(name,arg)
+ char * name
+ int arg
+
+SV *
+_call(name, address, queue="SESSION", ...)
+ char * name
+ void * address
+ char * queue
+ CODE:
+ {
+ ULONG rc;
+ int argc, i;
+ RXSTRING result;
+ UCHAR resbuf[256];
+ RexxFunctionHandler *fcn = address;
+ argc = items-3;
+ needstrs(argc);
+ if (trace)
+ fprintf(stderr, "REXXCALL::_call name: '%s' args:", name);
+ for (i = 0; i < argc; ++i) {
+ STRLEN len;
+ char *ptr = SvPV(ST(3+i), len);
+ MAKERXSTRING(strs[i], ptr, len);
+ if (trace)
+ fprintf(stderr, " '%.*s'", len, ptr);
+ }
+ if (!*queue)
+ queue = "SESSION";
+ if (trace)
+ fprintf(stderr, "\n");
+ MAKERXSTRING(result, resbuf, sizeof resbuf);
+ rc = fcn(name, argc, strs, queue, &result);
+ if (trace)
+ fprintf(stderr, " rc=%X, result='%.*s'\n", rc,
+ result.strlength, result.strptr);
+ ST(0) = sv_newmortal();
+ if (rc == 0) {
+ if (result.strptr)
+ sv_setpvn(ST(0), result.strptr, result.strlength);
+ else
+ sv_setpvn(ST(0), "", 0);
+ }
+ if (result.strptr && result.strptr != resbuf)
+ DosFreeMem(result.strptr);
+ }
+
+int
+_set(name,value,...)
+ char * name
+ char * value
+ CODE:
+ {
+ int i;
+ int n = (items + 1) / 2;
+ ULONG rc;
+ needvars(n);
+ if (trace)
+ fprintf(stderr, "REXXCALL::_set");
+ for (i = 0; i < n; ++i) {
+ SHVBLOCK * var = &vars[i];
+ STRLEN namelen;
+ STRLEN valuelen;
+ name = SvPV(ST(2*i+0),namelen);
+ if (2*i+1 < items) {
+ value = SvPV(ST(2*i+1),valuelen);
+ }
+ else {
+ value = "";
+ valuelen = 0;
+ }
+ var->shvcode = RXSHV_SET;
+ var->shvnext = &vars[i+1];
+ var->shvnamelen = namelen;
+ var->shvvaluelen = valuelen;
+ MAKERXSTRING(var->shvname, name, namelen);
+ MAKERXSTRING(var->shvvalue, value, valuelen);
+ if (trace)
+ fprintf(stderr, " %.*s='%.*s'",
+ var->shvname.strlength, var->shvname.strptr,
+ var->shvvalue.strlength, var->shvvalue.strptr);
+ }
+ if (trace)
+ fprintf(stderr, "\n");
+ vars[n-1].shvnext = NULL;
+ rc = RexxVariablePool(vars);
+ if (trace)
+ fprintf(stderr, " rc=%X\n", rc);
+ RETVAL = (rc & ~RXSHV_NEWV) ? FALSE : TRUE;
+ }
+ OUTPUT:
+ RETVAL
+
+void
+_fetch(name, ...)
+ char * name
+ PPCODE:
+ {
+ int i;
+ ULONG rc;
+ EXTEND(sp, items);
+ needvars(items);
+ if (trace)
+ fprintf(stderr, "REXXCALL::_fetch");
+ for (i = 0; i < items; ++i) {
+ SHVBLOCK * var = &vars[i];
+ STRLEN namelen;
+ name = SvPV(ST(i),namelen);
+ var->shvcode = RXSHV_FETCH;
+ var->shvnext = &vars[i+1];
+ var->shvnamelen = namelen;
+ var->shvvaluelen = 0;
+ MAKERXSTRING(var->shvname, name, namelen);
+ MAKERXSTRING(var->shvvalue, NULL, 0);
+ if (trace)
+ fprintf(stderr, " '%s'", name);
+ }
+ if (trace)
+ fprintf(stderr, "\n");
+ vars[items-1].shvnext = NULL;
+ rc = RexxVariablePool(vars);
+ if (!(rc & ~RXSHV_NEWV)) {
+ for (i = 0; i < items; ++i) {
+ int namelen;
+ SHVBLOCK * var = &vars[i];
+ /* returned lengths appear to be swapped */
+ /* but beware of "future bug fixes" */
+ namelen = var->shvvalue.strlength; /* should be */
+ if (var->shvvaluelen < var->shvvalue.strlength)
+ namelen = var->shvvaluelen; /* is */
+ if (trace)
+ fprintf(stderr, " %.*s='%.*s'\n",
+ var->shvname.strlength, var->shvname.strptr,
+ namelen, var->shvvalue.strptr);
+ if (var->shvret & RXSHV_NEWV || !var->shvvalue.strptr)
+ PUSHs(&sv_undef);
+ else
+ PUSHs(sv_2mortal(newSVpv(var->shvvalue.strptr,
+ namelen)));
+ }
+ } else {
+ if (trace)
+ fprintf(stderr, " rc=%X\n", rc);
+ }
+ }
+
+void
+_next(stem)
+ char * stem
+ PPCODE:
+ {
+ SHVBLOCK sv;
+ BYTE name[4096];
+ ULONG rc;
+ int len = strlen(stem), namelen, valuelen;
+ if (trace)
+ fprintf(stderr, "REXXCALL::_next stem='%s'\n", stem);
+ sv.shvcode = RXSHV_NEXTV;
+ sv.shvnext = NULL;
+ MAKERXSTRING(sv.shvvalue, NULL, 0);
+ do {
+ sv.shvnamelen = sizeof name;
+ sv.shvvaluelen = 0;
+ MAKERXSTRING(sv.shvname, name, sizeof name);
+ if (sv.shvvalue.strptr) {
+ DosFreeMem(sv.shvvalue.strptr);
+ MAKERXSTRING(sv.shvvalue, NULL, 0);
+ }
+ rc = RexxVariablePool(&sv);
+ } while (!rc && memcmp(stem, sv.shvname.strptr, len) != 0);
+ if (!rc) {
+ EXTEND(sp, 2);
+ /* returned lengths appear to be swapped */
+ /* but beware of "future bug fixes" */
+ namelen = sv.shvname.strlength; /* should be */
+ if (sv.shvnamelen < sv.shvname.strlength)
+ namelen = sv.shvnamelen; /* is */
+ valuelen = sv.shvvalue.strlength; /* should be */
+ if (sv.shvvaluelen < sv.shvvalue.strlength)
+ valuelen = sv.shvvaluelen; /* is */
+ if (trace)
+ fprintf(stderr, " %.*s='%.*s'\n",
+ namelen, sv.shvname.strptr,
+ valuelen, sv.shvvalue.strptr);
+ PUSHs(sv_2mortal(newSVpv(sv.shvname.strptr+len, namelen-len)));
+ if (sv.shvvalue.strptr) {
+ PUSHs(sv_2mortal(newSVpv(sv.shvvalue.strptr, valuelen)));
+ DosFreeMem(sv.shvvalue.strptr);
+ } else
+ PUSHs(&sv_undef);
+ } else if (rc != RXSHV_LVAR) {
+ die("Error %i when in _next", rc);
+ } else {
+ if (trace)
+ fprintf(stderr, " rc=%X\n", rc);
+ }
+ }
+
+int
+_drop(name,...)
+ char * name
+ CODE:
+ {
+ int i;
+ needvars(items);
+ for (i = 0; i < items; ++i) {
+ SHVBLOCK * var = &vars[i];
+ STRLEN namelen;
+ name = SvPV(ST(i),namelen);
+ var->shvcode = RXSHV_DROPV;
+ var->shvnext = &vars[i+1];
+ var->shvnamelen = namelen;
+ var->shvvaluelen = 0;
+ MAKERXSTRING(var->shvname, name, var->shvnamelen);
+ MAKERXSTRING(var->shvvalue, NULL, 0);
+ }
+ vars[items-1].shvnext = NULL;
+ RETVAL = (RexxVariablePool(vars) & ~RXSHV_NEWV) ? FALSE : TRUE;
+ }
+ OUTPUT:
+ RETVAL
+
+int
+_register(name)
+ char * name
+ CODE:
+ RETVAL = RexxRegisterFunctionExe(name, PERLCALL);
+ OUTPUT:
+ RETVAL
+
+SV*
+REXX_call(cv)
+ SV *cv
+ PROTOTYPE: &
+
+SV*
+REXX_eval(cmd)
+ char *cmd
+
+SV*
+REXX_eval_with(cmd,name,cv)
+ char *cmd
+ char *name
+ SV *cv
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_cmprt.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_cmprt.t
new file mode 100644
index 00000000000..f2113e3aa33
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_cmprt.t
@@ -0,0 +1,40 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib' if -d 'lib';
+ require Config; import Config;
+ if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use OS2::REXX;
+
+$| = 1; # Otherwise data from REXX may come first
+
+print "1..13\n";
+
+$n = 1;
+sub do_me {
+ print "ok $n\n";
+ "OK";
+}
+
+@res = REXX_call(\&do_me);
+print "ok 2\n";
+@res == 1 ? print "ok 3\n" : print "not ok 3\n";
+$res[0] eq "OK" ? print "ok 4\n" : print "not ok 4\n# `$res[0]'\n";
+
+# Try again
+$n = 5;
+@res = REXX_call(\&do_me);
+print "ok 6\n";
+@res == 1 ? print "ok 7\n" : print "not ok 7\n";
+$res[0] eq "OK" ? print "ok 8\n" : print "not ok 8\n# `$res[0]'\n";
+
+REXX_call { print "ok 9\n" };
+REXX_eval 'say "ok 10"';
+# Try again
+REXX_eval 'say "ok 11"';
+print "ok 12\n" if REXX_eval("return 2 + 3") eq 5;
+REXX_eval_with 'say myfunc()', myfunc => sub {"ok 13"};
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_dllld.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_dllld.t
new file mode 100644
index 00000000000..9d81bf3e56b
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_dllld.t
@@ -0,0 +1,36 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib' if -d 'lib';
+ require Config; import Config;
+ if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use OS2::REXX;
+
+$path = $ENV{LIBPATH} || $ENV{PATH} or die;
+foreach $dir (split(';', $path)) {
+ next unless -f "$dir/YDBAUTIL.DLL";
+ $found = "$dir/YDBAUTIL.DLL";
+ last;
+}
+$found or die "1..0\n#Cannot find YDBAUTIL.DLL\n";
+
+print "1..5\n";
+
+$module = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n";
+print "ok 1\n";
+
+$address = DynaLoader::dl_find_symbol($module, "RXPROCID")
+ or die "not ok 2\n# find\n";
+print "ok 2\n";
+
+$result = OS2::REXX::_call("RxProcId", $address) or die "not ok 3\n# REXX";
+print "ok 3\n";
+
+($pid, $ppid, $ssid) = split(/\s+/, $result);
+$pid == $$ ? print "ok 4\n" : print "not ok 4\n# pid\n";
+$ssid == 1 ? print "ok 5\n" : print "not ok 5\n# pid\n";
+print "# pid=$pid, ppid=$ppid, ssid=$ssid\n";
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_objcall.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_objcall.t
new file mode 100644
index 00000000000..cb3c52a8b65
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_objcall.t
@@ -0,0 +1,33 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib' if -d 'lib';
+ require Config; import Config;
+ if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use OS2::REXX;
+
+#
+# DLL
+#
+$ydba = load OS2::REXX "ydbautil" or die "1..0\n# load\n";
+print "1..5\n", "ok 1\n";
+
+#
+# function
+#
+@pid = $ydba->RxProcId();
+@pid == 1 ? print "ok 2\n" : print "not ok 2\n";
+@res = split " ", $pid[0];
+print "ok 3\n" if $res[0] == $$;
+@pid = $ydba->RxProcId();
+@res = split " ", $pid[0];
+print "ok 4\n" if $res[0] == $$;
+print "# @pid\n";
+
+eval { $ydba->nixda(); };
+print "ok 5\n" if $@ =~ /^Can't find entry 'nixda\'/;
+
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_sql.test b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_sql.test
new file mode 100644
index 00000000000..602c76dc47d
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_sql.test
@@ -0,0 +1,97 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use OS2::REXX;
+
+sub stmt
+{
+ my ($s) = @_;
+ $s =~ s/\s*\n\s*/ /g;
+ $s =~ s/^\s+//;
+ $s =~ s/\s+$//;
+ return $s;
+}
+
+sub sqlcode
+{
+ OS2::REXX::_fetch("SQLCA.SQLCODE");
+}
+
+sub sqlstate
+{
+ OS2::REXX::_fetch("SQLCA.SQLSTATE");
+}
+
+sub sql
+{
+ my ($stmt) = stmt(@_);
+ return 0 if OS2::REXX::_call("sqlexec", $sqlexec, "", $stmt);
+ return sqlcode() >= 0;
+}
+
+sub dbs
+{
+ my ($stmt) = stmt(@_);
+ return 0 if OS2::REXX::_call("sqldbs", $sqldbs, "", $stmt);
+ return sqlcode() >= 0;
+}
+
+sub error
+{
+ my ($where) = @_;
+ print "ERROR in $where: sqlcode=", sqlcode(), " sqlstate=", sqlstate(), "\n";
+ dbs("GET MESSAGE INTO :MSG LINEWIDTH 75");
+ my $msg = OS2::REXX::_fetch("MSG");
+ print "\n", $msg;
+ exit 1;
+}
+
+REXX_call {
+
+ $sqlar = DynaLoader::dl_load_file("h:/sqllib/dll/sqlar.dll") or die "load";
+ $sqldbs = DynaLoader::dl_find_symbol($sqlar, "SQLDBS") or die "find sqldbs";
+ $sqlexec = DynaLoader::dl_find_symbol($sqlar, "SQLEXEC") or die "find sqlexec";
+
+ sql(<<) or error("connect");
+ CONNECT TO sample IN SHARE MODE
+
+ OS2::REXX::_set("STMT" => stmt(<<));
+ SELECT name FROM sysibm.systables
+
+ sql(<<) or error("prepare");
+ PREPARE s1 FROM :stmt
+
+ sql(<<) or error("declare");
+ DECLARE c1 CURSOR FOR s1
+
+ sql(<<) or error("open");
+ OPEN c1
+
+ while (1) {
+ sql(<<) or error("fetch");
+ FETCH c1 INTO :name
+
+ last if sqlcode() == 100;
+
+ print "Table name is ", OS2::REXX::_fetch("NAME"), "\n";
+ }
+
+ sql(<<) or error("close");
+ CLOSE c1
+
+ sql(<<) or error("rollback");
+ ROLLBACK
+
+ sql(<<) or error("disconnect");
+ CONNECT RESET
+
+};
+
+exit 0;
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tiesql.test b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tiesql.test
new file mode 100644
index 00000000000..c85a1e990b9
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tiesql.test
@@ -0,0 +1,86 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+#extproc perl5 -Rx
+#! perl
+
+use REXX;
+
+$db2 = load REXX "sqlar" or die "load";
+tie $sqlcode, REXX, "SQLCA.SQLCODE";
+tie $sqlstate, REXX, "SQLCA.SQLSTATE";
+tie %rexx, REXX, "";
+
+sub stmt
+{
+ my ($s) = @_;
+ $s =~ s/\s*\n\s*/ /g;
+ $s =~ s/^\s+//;
+ $s =~ s/\s+$//;
+ return $s;
+}
+
+sub sql
+{
+ my ($stmt) = stmt(@_);
+ return 0 if $db2->SqlExec($stmt);
+ return $sqlcode >= 0;
+}
+
+sub dbs
+{
+ my ($stmt) = stmt(@_);
+ return 0 if $db2->SqlDBS($stmt);
+ return $sqlcode >= 0;
+}
+
+sub error
+{
+ my ($where) = @_;
+ print "ERROR in $where: sqlcode=$sqlcode, sqlstate=$sqlstate\n";
+ dbs("GET MESSAGE INTO :msg LINEWIDTH 75");
+ print "\n", $rexx{'MSG'};
+ exit 1;
+}
+
+sql(<<) or error("connect");
+ CONNECT TO sample IN SHARE MODE
+
+$rexx{'STMT'} = stmt(<<);
+ SELECT name FROM sysibm.systables
+
+sql(<<) or error("prepare");
+ PREPARE s1 FROM :stmt
+
+sql(<<) or error("declare");
+ DECLARE c1 CURSOR FOR s1
+
+sql(<<) or error("open");
+ OPEN c1
+
+while (1) {
+ sql(<<) or error("fetch");
+ FETCH c1 INTO :name
+
+ last if $sqlcode == 100;
+
+ print "Table name is $rexx{'NAME'}\n";
+}
+
+sql(<<) or error("close");
+ CLOSE c1
+
+sql(<<) or error("rollback");
+ ROLLBACK
+
+sql(<<) or error("disconnect");
+ CONNECT RESET
+
+exit 0;
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tievar.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tievar.t
new file mode 100644
index 00000000000..77f90c2f59f
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tievar.t
@@ -0,0 +1,88 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib' if -d 'lib';
+ require Config; import Config;
+ if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use OS2::REXX;
+
+#
+# DLL
+#
+load OS2::REXX "ydbautil" or die "1..0\n# load\n";
+
+print "1..19\n";
+
+REXX_call {
+ print "ok 1\n";
+
+ #
+ # scalar
+ #
+ tie $s, OS2::REXX, "TEST";
+ print "ok 2\n";
+ $s = 1;
+ print "ok 3\n" if $s eq 1;
+ print "not ok 3\n# `$s'\n" unless $s eq 1;
+ untie $s;
+
+ #
+ # hash
+ #
+
+ tie %all, OS2::REXX, ""; # all REXX vars
+ print "ok 4\n";
+
+ sub show {
+ # show all REXX vars
+ print "--@_--\n";
+ foreach (keys %all) {
+ $v = $all{$_};
+ print "$_ => $v\n";
+ }
+ }
+
+ sub check {
+ # check all REXX vars
+ my ($test, @arr) = @_;
+ my @rx;
+ foreach $key (sort keys %all) { push @rx, $key, $all{$key} }
+ if ("@rx" eq "@arr") {print "ok $test\n"}
+ else { print "not ok $test\n# expect `@arr', got `@rx'\n" }
+ }
+
+
+ tie %h, OS2::REXX, "TEST.";
+ print "ok 5\n";
+ check(6);
+
+ $h{"one"} = 1;
+ check(7, "TEST.one", 1);
+
+ $h{"two"} = 2;
+ check(8, "TEST.one", 1, "TEST.two", 2);
+
+ $h{"one"} = "";
+ check(9, "TEST.one", "", "TEST.two", 2);
+ print "ok 10\n" if exists $h{"one"};
+ print "ok 11\n" if exists $h{"two"};
+
+ delete $h{"one"};
+ check(12, "TEST.two", 2);
+ print "ok 13\n" if not exists $h{"one"};
+ print "ok 14\n" if exists $h{"two"};
+
+ OS2::REXX::dropall("TEST.");
+ print "ok 15\n";
+ check(16);
+ print "ok 17\n" if not exists $h{"one"};
+ print "ok 18\n" if not exists $h{"two"};
+
+ untie %h;
+ print "ok 19";
+
+};
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tieydb.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tieydb.t
new file mode 100644
index 00000000000..30a2dafb620
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_tieydb.t
@@ -0,0 +1,31 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib' if -d 'lib';
+ require Config; import Config;
+ if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use OS2::REXX;
+$rx = load OS2::REXX "ydbautil" or die "1..0\n# load\n"; # from RXU17.ZIP
+print "1..7\n", "ok 1\n";
+
+$rx->prefix("Rx"); # implicit function prefix
+print "ok 2\n";
+
+REXX_call {
+ tie @pib, OS2::REXX, "IB.P"; # bind array to REXX stem variable
+ print "ok 3\n";
+ tie %tib, OS2::REXX, "IB.T."; # bind associative array to REXX stem var
+ print "ok 4\n";
+
+ $rx->GetInfoBlocks("IB."); # call REXX function
+ print "ok 5\n";
+ defined $pib[6] ? print "ok 6\n" : print "not ok 6\n# pib\n";
+ defined $tib{7} && $tib{7} =~ /^\d+$/ ? print "ok 7\n"
+ : print "not ok 7\n# tib\n";
+ print "# Process status is ", unpack("I", $pib[6]),
+ ", thread ordinal is $tib{7}\n";
+};
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_varset.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_varset.t
new file mode 100644
index 00000000000..166cf536235
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_varset.t
@@ -0,0 +1,39 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib' if -d 'lib';
+ require Config; import Config;
+ if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use OS2::REXX;
+
+print "1..9\n";
+
+REXX_call {
+ OS2::REXX::_set("X" => sqrt(2)) and print "ok 1\n";
+ $x = OS2::REXX::_fetch("X") and print "ok 2\n";
+ if (abs($x - sqrt(2)) < 5e-15) {
+ print "ok 3\n";
+ } else { print "not ok 3\n# sqrt(2) = @{[sqrt(2)]} != `$x'\n" }
+ OS2::REXX::_set("Y" => sqrt(3)) and print "ok 4\n";
+ $i = 0;
+ $n = 4;
+ while (($name, $value) = OS2::REXX::_next("")) {
+ $i++; $n++;
+ if ($i <= 2 and $name eq "Y" ) {
+ if ($value eq sqrt(3)) {
+ print "ok $n\n";
+ } else {
+ print "not ok $n\n# `$name' => `$value'\n" ;
+ }
+ } elsif ($i <= 2 and $name eq "X") {
+ print "ok $n\n" if $value eq sqrt(2);
+ } else { print "not ok 7\n# name `$name', value `$value'\n" }
+ }
+ print "ok 7\n" if $i == 2;
+ OS2::REXX::_drop("X") and print "ok 8\n";
+ $x = OS2::REXX::_fetch("X") or print "ok 9\n";
+};
diff --git a/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_vrexx.t b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_vrexx.t
new file mode 100644
index 00000000000..04ca6636dbf
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/OS2/REXX/t/rx_vrexx.t
@@ -0,0 +1,59 @@
+BEGIN {
+ chdir 't' if -d 't/lib';
+ @INC = '../lib' if -d 'lib';
+ require Config; import Config;
+ if (-d 'lib' and $Config{'extensions'} !~ /\bOS2(::|\/)REXX\b/) {
+ print "1..0\n";
+ exit 0;
+ }
+}
+
+use OS2::REXX;
+
+$name = "VREXX";
+$path = $ENV{LIBPATH} || $ENV{PATH} or die;
+foreach $dir (split(';', $path)) {
+ next unless -f "$dir/$name.DLL";
+ $found = "$dir/$name.DLL";
+ print "# found at `$found'\n";
+ last;
+}
+$found or die "1..0\n#Cannot find $name.DLL\n";
+
+print "1..10\n";
+
+REXX_call {
+ $vrexx = DynaLoader::dl_load_file($found) or die "not ok 1\n# load\n";
+ print "ok 1\n";
+ $vinit = DynaLoader::dl_find_symbol($vrexx, "VINIT") or die "find vinit";
+ print "ok 2\n";
+ $vexit = DynaLoader::dl_find_symbol($vrexx, "VEXIT") or die "find vexit";
+ print "ok 3\n";
+ $vmsgbox = DynaLoader::dl_find_symbol($vrexx, "VMSGBOX") or die "find vmsgbox";
+ print "ok 4\n";
+ $vversion= DynaLoader::dl_find_symbol($vrexx, "VGETVERSION") or die "find vgetversion";
+ print "ok 5\n";
+
+ $result = OS2::REXX::_call("VInit", $vinit) or die "VInit";
+ print "ok 6\n";
+ print "# VInit: $result\n";
+
+ OS2::REXX::_set("MBOX.0" => 4,
+ "MBOX.1" => "Perl VREXX Access Test",
+ "MBOX.2" => "",
+ "MBOX.3" => "(C) Andreas Kaiser",
+ "MBOX.4" => "December 1994")
+ or die "set var";
+ print "ok 7\n";
+
+ $result = OS2::REXX::_call("VGetVersion", $vversion) or die "VMsgBox";
+ print "ok 8\n";
+ print "# VGetVersion: $result\n";
+
+ $result = OS2::REXX::_call("VMsgBox", $vmsgbox, "", "Perl", "MBOX", 1) or die "VMsgBox";
+ print "ok 9\n";
+ print "# VMsgBox: $result\n";
+
+ OS2::REXX::_call("VExit", $vexit);
+ print "ok 10\n";
+};
diff --git a/gnu/usr.bin/perl/os2/README b/gnu/usr.bin/perl/os2/README
deleted file mode 100644
index cd00a1f6032..00000000000
--- a/gnu/usr.bin/perl/os2/README
+++ /dev/null
@@ -1,229 +0,0 @@
-Current state of the patches here is with respect to perl5.002b1d ;-).
-
-========================================================
-
-The OS/2 patchkit was submitted by ilya@math.ohio-state.edu. I have
-applied some parts that I suspect won't cause any problems.
-Others do things that I haven't had time to fully consider.
-
-Still other patches included here should perhaps be integrated with the
-metaconfig package that generates Configure.
-
- Andy Dougherty <doughera@lafcol.lafayette.edu>
-
-========================================================
-
-Notes on the patch:
-~~~~~~~~~~~~~~~~~~~
-patches should be applied as
- patch -p0 <.....
-All the diff.* files and POSIX.mkfifo should be applied.
-
-Additional files are available on
- ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2
-including patched pdksh and gnumake, needed for build.
-
-
-Target:
-~~~~~~~
-
-This is not supposed to make a perfect Perl on OS/2. This patch is
-concerned only with perfect _build_ of Perl on OS/2. A lot of good
-features from Andreas Kaiser port missed this patch.
-
-Annotations of changes: (part of what is below is already included by Andy,
-~~~~~~~~~~~~~~~~~~~~~~~ thus there are skips below)
-1) C files
-2) Configure
-3) MakeMaker
-4) Build tools
-
-1) C files
- a) mkfifo macro added to Posix.c
- b) Copyright notice for OS/2 port changed
- c) MYMALLOC section in perl.h moved (why?)
- d) setgrent grent and getgrent wrapped in ifdef
- e) declarations for #if defined(MYMALLOC) && defined(HIDEMYMALLOC)
- added
- f) some diagnostics added to tests
-
-2) Configure
- b) Support for extraction from NE style libraries.
- c) a lot of
- cc -o whatever
- lines did not have $ldopts.
- d) The above variables are used throughout the file for checks
-
-3) Build tools and libraries
-
-
- a) ln changed to $ln in some places
- b) Makefiles and related scripts made to use $(O), $(A), $(AR)
- using the vars found by Configure or defaulted to
- some reasonable value.
- c) $firstmakefile is the file make looks onto before Makefile
- d) $plibext is the extension for the perl library
- e) $archobjs is the list of additional object files needed for
- local build.
- l) Makefile.SH : added sh in front of some commands
- if $d_shrplib is 'custom', looks into
- $osname/Makefile.$osname.SH to construct the section
- on shared Perl library.
- !!!!!! Also: installperl installman makedepend
- !!!!!! added as dependencies to the corresponding
- !!!!!! targets.
- m) clean target extended to delete some intermediate files
-
-Notes on build on OS/2:
-~~~~~~~~~~~~~~~~~~~~~~~
-The change of C code in this patch is based on the ak port of 5.001+.
-
-a) Make sure your sort is not the broken OS/2 one, and that you have /tmp
-on the build partition.
-
-b) when extraction perl5.*.tar.gz you need to extract perl5.*/Configure
-separately, since by default perl5.001m/configure may overwrite it;
- like this:
- tar vzxf perl5.004.tar.gz --case-sensitive perl5.004/Configure
-
-c) Necessary manual intervention when compiling on OS/2:
-
- Need to put perl.dll on LIBPATH after it is created.
-
-d) Compile summary:
-
-# Look for hints/os2.sh and correct what is different on your system
-# I have rather spartan configuration.
-
- # Prefix means where to install:
-sh Configure -des -D prefix=f:/perl5.005
-make
- # Will probably die after build of miniperl (unless you have DLL
- # from previous compile). Need to move DLL where it belongs
- #
- # Somehow with 5.002b3 I needed to type another make after pod2man
-make
- # some warnings in POSIX.c
-make test
- # some tests fail, 9 or 10 on my system (see the list at end).
- #
- # before this you should create subdirs bin and lib in the
- # prefix directory (f:/perl5.005 above):
-make install
-
-e) At the end of August GNU make and pdksh were too buggy for compile.
-Both maintainers have patches that make it possible to compile perl.
-The binaries are included in
- ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2
-patches are available too.
-Note that the pdksh5.2.4 broke builds with -Zexe option because of a
-changed order of executable extensions. A patch is sent to maintainer.
-
-!!!!!!!!!!!!!!!!!
-If you see that some '/' became '\' in pdksh 5.2.3, you did not apply
-my patches!
-Same with segfaults in Make 3.74.
-!!!!!!!!!!!!!!!!!
-
-Problems reported:
-
-a) one of the latest tr is broken, get an old one :-(
- 1.11 works. (On compuserver?)
-b) You need a perlglob.exe and link386.
-c) Get rid of invalid perl.dll on your LIBPATH.
-
-
-Send comments to ilya@math.ohio-state.edu.
-
-======================================================
-Requires 0.9b (well, provision are made to make it build under 0.9a6,
-but they are not tested, please inform me on success).
-(earlier than 0.9b ttyname was not present, it is hard to maintain this
-difference automatically, though I try).
-======================================================
-
-You may try building with a.out style by using `-D emxaout' on the Configure
-line (dynamic extensions should not use CRT (and/or any perl API) in this
-case, which prohibits most buildin extensions). Probably no extension is
-possible, since boot code should return the amount on stack.
-
-The reason why compiling with a.out style executables leads to problems
-with dynamic extensions is:
- a) OS/2 does not export symbols from executables;
- b) Thus if extension needs to import symbols from an application
- the symbols for the application should reside in a .dll.
- c) You cannot export data from a .dll compiled with a.out style.
-On the other hand, aout-style compiled extension enjoys all the
-(dis)advantages of fork().
-
-======================================================
-Tests which fail with OMF compile:
-
-io/fs.t: 2-5, 7-11, 18 as they should.
-io/pipe: all, since open("|-") is not working (even with fork, so far).
-lib/"all the dbm".t: 1 test should fail (file permission).
-op/fork all fail, as they should
-op/stat 3 20 35 as they should, 39 (-t on /dev/null) ???? Sometimes 4 ????
-
-Segfault in socket ????, only if run with Testing tools.
-
-A lot of `bad free'... in databases, bug in DB confirmed on other
-platforms.
-
-Fail: Total 30 subtests (if stat:4 fails) in 10 scripts (one of 10
-is socket, which runs OK standalone).
-
-=======================================================
-
-Changes to calls to external programs:
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Due to a popular demand the perl external program calling has been changed.
-_If_ perl needs to call an external program via shell, the sh.exe will be
-called. The name of the shell is not overridable.
-
-Thus means that you need to pickup some copy of a sh.exe as well (I use one
-from pdksh).
-
-Reasons: a consensus on perl5-porters was that perl should use one
-non-overridable shell per platform. The obvious choices for OS/2 are cmd.exe
-and sh.exe. Having perl build itself would be impossible with cmd.exe as
-a shell, thus I picked up sh.exe. Thus assures almost 100% compatibility
-with the scripts coming from *nix.
-
-Disadvantages: sh.exe calls external programs via fork/exec, and there is
-_no_ functioning exec on OS/2. exec is emulated by EMX by asyncroneous call
-while the caller waits for child completion (to pretend that pid did
-not change). This means that 1 _extra_ copy of sh.exe is made active via
-fork/exec, which may lead to some resources taken from the system.
-
-The long-term solution proposed on p5-p is to have a directive
- use OS2::Cmd;
-which will override system(), exec(), ``, and open(,' |'). With current
-perl you may override only system(), readpipe() - the explicit version
-of ``, and maybe exec(). The code will substitute a one-argument system
-by CORE::system('cmd.exe', '/c', shift).
-
-If you have some working code for OS2::Cmd.pm, please send it to me,
-I will include it into distribution. I have no need for such a module, so
-cannot test it.
-
-===================================================
-
-OS/2 extensions
-~~~~~~~~~~~~~~~
-I include 3 extensions by Andread Kaiser, OS2::REXX, OS2::UPM, and OS2::FTP,
-into my ftp directory, mirrored on CPAN. I made
-some minor changes needed to compile them by standard tools. I cannot
-test UPM and FTP, so I will appreciate your feedback.
-
-The -R switch of older perl is deprecated. If you need to call a REXX code
-which needs access to variables, include the call into a REXX compartment
-created by
- REXX_call {...block...};
-
-Two new functions are supported by REXX code,
- REXX_eval 'string';
- REXX_eval_with 'string', REXX_function_name => \&perl_sub_reference;
-
-If you have some other extensions you want to share, send the code to me.
-Two jump to mind: tied access to EA's, and tied access to system databases.
diff --git a/gnu/usr.bin/perl/os2/README.old b/gnu/usr.bin/perl/os2/README.old
deleted file mode 100644
index f49d6be1fa6..00000000000
--- a/gnu/usr.bin/perl/os2/README.old
+++ /dev/null
@@ -1,529 +0,0 @@
-This documentation to the previous version is somewhat applicable yet.
-No system() extensions, no -R option, the exec/system with one argument
-will use sh.exe only (if required). IZ
-
- Perl 5.001 for OS/2.
- Patchlevel "m"
-
- Copyright (c) 1989,1990,1991,1992,1993,1994 Larry Wall
- All rights reserved.
-
- OS/2 port Copyright (c) 1990, 1991, 1994-95
- Raymond Chen, Kai Uwe Rommel, Andreas Kaiser
-
-Version 5 port (this package) by Andreas Kaiser <ak@ananke.s.bawue.de>
-(2:246/8506.9@fidonet).
-
-To run the executables supplied with this file, you have to install the
-EMX runtime package emxrt.zip of version 0.9a05 (0.9a, fixlevel 5) or
-later.
-
-The file emxrt.zip is available at ftp.rus.uni-stuttgart.de (the
-origin), ftp-os2.nmsu.edu and many other places.
-
-The source code of the original Perl 5.0 distribution is not included
-here. You can get it at ftp://ftp.wpi.edu:/perl5/perl5.001.tar.gz (and
-many other places).
-
-For documentation of Perl 5, look at the files into the directory tree
-"pod". For TeX or Postscript docs, get perlref-5.000.0.tar.gz. A LaTeX
-and postscript reference card is available at
- ftp.NL.net:/pub/comp/programming/languages/perl/perlref-5.000.0.tar.gz
- prep.ai.mit.edu:/pub/gnu/perlref-5.000.0.tar.gz
-
-Many REXX DLLs complement the features available by standard Perl,
-supporting system calls (YdbaUtil - RXU??.ZIP), xBase (RexxBase,
-shareware), serial I/O (RxAsync) and basic PM dialogs (VRexx). These
-packages can be found at many OS/2 FTP servers.
-
------------------------------------------------------------------------------
-Installation:
--------------
-
-If you did not have HPFS up to now, this is the right time to reformat
-your filesystem(s)... While Perl itself does not require HPFS, a lot
-of Perl library files do. Or try EMXOPT=-t.
-
-copy perl5.exe perl5x.exe `some PATH dir`
-copy os2\perlglob.exe `some PATH dir`
-copy perl5.dll `some LIBPATH dir`
-
-set PERL5LIB=x:/your/own/perl/lib;y:/somewhere/perl5/lib
-
-The perl5 extension DLLs (POSIX_.DLL, REXX_.DLL, ...) do not need a
-LIBPATH entry.
-
-Executables:
-------------
-
-perl5.exe,perl5.dll : DynaLoader, REXX support, external DLLs
-
- No fork. Running a command via open() returns 1
- instead of the child process id.
-
- Other modules supported via extension DLLs, no
- builtins other than DynaLoader.
-
-perl5x.exe : No Dynaloader, no REXX.
-
- Supports fork. Running a command via open() uses fork
- (slow) and correctly returns the child process id.
-
- POSIX and Socket modules builtin. No other extension
- modules supported.
-
- Note that lib/Socket.pm and lib/POSIX.pm reflect
- DLL use. If you need them with perl5x.exe, you
- have to remove the "bootstrap" line.
-
------------------------------------------------------------------------------
-Building:
----------
-
-Requires:
-- Perl5.001.tar.gz (Perl 5.001 sources).
-- EMX 0.9a05 or later (Compiler).
-- OS/2 Development Toolkit (or change REXX inc/lib references).
-- Korn shell (ksh) or some other Unix-like shell named ksh.
-- DMake, with group recipes configured for a Unix shell.
-- Larry Walls "patch" program.
-- Several Unix-like tools, such as cp, cat, touch, find, ...
-
-get Perl 5.001 source
-apply patches\* -- "official unofficial" patches to 5.001
-apply os2\patches -- OS/2 platform patches
-copy ext\DynaLoader\dl_os2.xs ext\DynaLoader\DynaLoader.xs
-copy os2\config.sh .
-copy os2\makefile.mk .
-
-If you do not have UPM (User Profile Management), remove "UPM" from
-makefile.mk.
-
------------------------------------------------------------------------------
-Not supported, bugs, "OS/2 is Not Unix":
-----------------------------------------
-
-Depending on whether you run perl5.exe or perl5x.exe, you can either
-use extension modules and REXX, or fork, since the EMX implementation
-of fork conflicts with DLL support. Remember that there is a hidden
-fork in open(F, "-|") and open(F, "|-").
-
-config.sh (Config.pm) lies. It shows d_fork='undef' even though it is
-available in perl5x.exe. "dynamic_ext" and "extensions" are incorrect
-for perl5x.exe.
-
-flock is available but does not yet work in EMX 0.9a.
-
-ttyname and ctermid do not work (return NULL).
-
-... and of course a lot of Unix-isms like process group, user and group
-management, links, ...
-
-For details, look into config.sh and the EMX library reference.
-
-I did not test SDBM. I just added a lot of O_BINARY flags and compiled it.
-
-Several scripts of the test suite (see source distribution) fail due to
-Unix-isms like /bin/sh, `echo *`, different quoting requirements, ...
-
-When opening a command pipe [such as open(F,"cat|")], perl5.exe
-returns 1 instead of the child's process id. Perl5x.exe correctly
-returns the process id.
-
-OS/2 does not have a true exec API (which is used both by the exec
-function and when opening a command pipe with perl5x.exe). What
-actually happens is the call of a subprocess with the father waiting
-for the termination of its child. While waiting, the father still owns
-all its resources (it passes signals to the child however) and there
-may be some other side effects as well.
-
------------------------------------------------------------------------------
-OS2::REXX Module (external library):
-------------------------------------
-
-NOTE: By default, the REXX variable pool is not available, neither to
-Perl, nor to external REXX functions. To enable it, you have to start
-Perl with the switch -R, which makes Perl call its interpreter through
-REXX. REXX functions which do not use variables may be usable even
-without -R though.
-
-Load REXX DLL:
-
- $dll = load OS2::REXX NAME [, WHERE];
-
- NAME is DLL name, without path and extension.
-
- Directories are searched WHERE first (list of dirs), then
- environment paths PERL5REXX, PERLREXX or, as last resort, PATH.
-
- The DLL is not unloaded when the variable dies.
-
- Returns DLL object reference, or undef on failure.
-
-Define function prefix:
-
- $dll->prefix(NAME);
-
- Define the prefix of external functions, prepended to the
- function names used within your program, when looking for
- the entries in the DLL.
-
- Example:
- $dll = load OS2::REXX "RexxBase";
- $dll->prefix("RexxBase_");
- $dll->Init();
- is the same as
- $dll = load OS2::REXX "RexxBase";
- $dll->RexxBase_Init();
-
-Define queue:
-
- $dll->queue(NAME);
-
- Define the name of the REXX queue passed to all external
- functions of this module. Defaults to "SESSION".
-
-Check for functions (optional):
-
- BOOL = $dll->find(NAME [, NAME [, ...]]);
-
- Returns true if all functions are available.
-
-Call external REXX function:
-
- $dll->function(arguments);
-
- Returns the return string if the return code is 0, else undef.
- Dies with error message if the function is not available.
-
-Bind scalar variable to REXX variable:
-
- tie $var, OS2::REXX, "NAME";
-
-Bind array variable to REXX stem variable:
-
- tie @var, OS2::REXX, "NAME.";
-
- Only scalar operations work so far. No array assignments,
- no array operations, ... FORGET IT.
-
-Bind hash array variable to REXX stem variable:
-
- tie %var, OS2::REXX, "NAME.";
-
- To access all visible REXX variables via hash array, bind to "";
-
- No array assignments. No array operations, other than hash array
- operations. Just like the *dbm based implementations.
-
- For the usual REXX stem variables, append a "." to the name,
- as shown above. If the hash key is part of the stem name, for
- example if you bind to "", you cannot use lower case in the stem
- part of the key and it is subject to character set restrictions.
-
-Erase individual REXX variables (bound or not):
-
- OS2::REXX::drop("NAME" [, "NAME" [, ...]]);
-
-Note that while function and variable names are case insensitive in the
-REXX language, function names exported by a DLL and the REXX variables
-(as seen by Perl through the chosen API) are all case sensitive!
-
-Most REXX DLLs export function names all upper case, but there are a
-few which export mixed case names (such as RxExtras). When trying to
-find the entry point, both exact case and all upper case are searched.
-If the DLL exports "RxNap", you have to specify the exact case, if it
-exports "RXOPEN", you can use any case.
-
-To avoid interfering with subroutine names defined by Perl (DESTROY)
-or used within the REXX module (prefix, find), it is best to use mixed
-case and to avoid lowercase only or uppercase only names when calling
-REXX functions. Be consistent. The same function written in different
-ways results in different Perl stubs.
-
-There is no REXX interpolation on variable names, so the REXX variable
-name TEST.ONE is not affected by some other REXX variable ONE. And it
-is not the same variable as TEXT.one!
-
-You cannot call REXX functions which are not exported by the DLL.
-While most DLLs export all their functions, some, like RxFTP, export
-only "...LoadFuncs", which registers the functions within REXX only.
-
-You cannot call 16-bit DLLs. The few interesting ones I found
-(FTP,NETB,APPC) do not export their functions.
-
-I do not know whether the REXX API is reentrant with respect to
-exceptions (signals) when the REXX top-level exception handler is
-overridden. So unless you know better than I do, do not access REXX
-variables (probably tied to Perl variables) or call REXX functions
-which access REXX queues or REXX variables in signal handlers.
-
-See ext/OS2/REXX/rx*.pl for examples.
-
------------------------------------------------------------------------------
-OS2::UPM (external library):
-----------------------------
-
-UPM constants (see <upm.h>) are exported automatically, functions only
-on request.
-
-(USERID, TYPE) = local_user ()
-
- return local user
-
-LIST = user_list (REMOTENODE="", REMOTETYPE_UPM_LOCAL)
- LIST = 4 items per logged on user
- [0] = user id
- [1] = remote node name
- [2] = remote node type (INT)
- [3] = session id (INT)
-
-(USERID, TYPE) = local_logon ()
-
- do a local logon, PM window, if not already logged on
-
-BOOL = logon (USERID, PASSWORD, AUTHCHECK=UPM_USER, REMOTENODE="", REMOTETYPE=UPM_LOCAL)
-BOOL = logoff (USERID, REMOTENODE="", REMOTETYPE=UPM_LOCAL)
-
- logon/logoff process (DB2/2)
-
-BOOL = logon_user (USERID, PASSWORD, REMOTENODE="", REMOTETYPE=UPM_LOCAL)
-BOOL = logoff_user (USERID, REMOTENODE="", REMOTETYPE=UPM_LOCAL)
-
- logon/logoff user
-
-ERRCODE = error ()
-
- return UPM error code of last failure
-
-STRING = message (ERRCODE)
-
- return message text for supplied UPM error code
-
-Defaults:
- REMOTETYPE = UPM_LOCAL
- REMOTENODE = ""
- AUTHCHECK = UPM_USER
-
------------------------------------------------------------------------------
-OS2::FTP (external library):
-----------------------------
-
-$acct = new FTP "host", "userid", "passwd" [, "acct"]
-
- Create virtual FTP session - no login.
-
-FTP::logoff()
-
- Logoff all sessions.
-
-($msec, $address) = FTP::ping("host", pktlen);
-$msec = FTP::ping($address, pktlen);
-
- Ping host. Returns milliseconds or negative error code.
- $address is 32-bit number.
-
-$errno = $acct->errno();
-
- Return last error code (FTP*).
-
-$text = FTP::message($errno);
-
- Return message test of last error.
-
-$status: <0 on error, >=0 on success.
-$tfrtype: T_BINARY, T_ASCII, T_EBCDIC
-"mode": "w" for overwrite, "a" for append
-
-$status = $acct->dir("local", "pattern"="*");
-$status = $acct->ls("local", "pattern"="*");
-
-$status = $acct->chdir("dir");
-$status = $acct->mkdir("dir");
-$status = $acct->rmdir("dir");
-($status, $cwd) = $acct->getcwd();
-
-$status = $acct->get("local", "remote"=local, "mode"="w", $tfrtype=T_BINARY);
-
-$status = $acct->put("local", "remote"=local, $tfrtype=T_BINARY);
-$status = $acct->putunique("local", "remote"=local, $tfrtype=T_BINARY);
-$status = $acct->append("local", "remote"=local, $tfrtype=T_BINARY);
-
-$status = $acct->rename("from", "to");
-$status = $acct->delete("name");
-
-$status = $acct->proxy($source_acct, "dst_file", "src_file", $tfrtype=T_BINARY);
-
-$status = $acct->quote("string");
-$status = $acct->site("string");
-($status, $infostring) = $acct->sys();
-
------------------------------------------------------------------------------
-Other:
-------
-
- setpriority CLASS,PID,DELTA
-
- Set priority of process or process tree.
-
- PID:
- >= 0: process only
- < 0: process tree
-
- CLASS:
- 0 no change
- 1 idle-time (lowest)
- 2 regular (dynamic priority)
- 3 time-critical (highest)
- 4 fixed-high (between regular and time-critical)
-
- DELTA:
- -31..+31
-
- getpriority IGNORED,PID
-
- Return priority of process or process tree.
-
- Bits 8..15 priority class (1..4)
- Bits 0..7 priority within class (0..31)
-
- system LIST
-
- If the first element of LIST is an integer, it controls the
- started child process or session as follows:
-
- 0 = wait until child terminates (default)
- 1 = do not wait, use wait() or waitpid() for status
- 4 = new session
- 5 = detached
- 6 = PM program
-
- PM and session options, or-ed in:
-
- 0x00000 = default
- 0x00100 = minimized
- 0x00200 = maximized
- 0x00300 = fullscreen (session only)
- 0x00400 = windowed (session only)
-
- 0x00000 = foreground (only if running in foreground)
- 0x01000 = background
-
- 0x02000 = don't close window on exit (session only)
-
- 0x10000 = quote all arguments
- 0x20000 = MKS argument passing convention
-
- If the control is not zero, system() does not wait until
- the child terminates and the return code is the id of the
- child process.
-
- If the control is not zero, and you do not call wait or
- waitpid, the child status fills up memory.
-
- Note: If the program is started with a mode of 4 or 6, it may
- be aborted when the starting program (perl) terminates. Later
- releases of EMX.DLL will probably know yet another flag bit
- to cut this fatal relationship.
-
- system STRING
- exec STRING
-
- If the string starts with "@" or contains any of "%&|<>",
- it is called as a shell command. Else the program is called
- directly.
-
- If the environment variable SHELL is defined, it is used
- instead of COMSPEC when running shell commands. It should
- be a Unix-style shell.
-
- file checks (-X), stat(), ...
-
- When testing filenames, not handles, char-devices are detected
- only when prefixed by "/dev/", so "/dev/con" is valid, "con" is
- not.
-
- Currently, only /dev/con and /dev/tty are recognized.
-
------------------------------------------------------------------------------
-History:
-
-15.12.94 Initial release (perl5000.zip).
-
-17.12.94 Moved REXX sub defn to find(). Hash array for functions no
- longer required, allows overriding subs like "find".
-
- DLL entries are case sensitive, try both upper case and
- exact case.
-
-18.12.94 Detect char- and block-devices (stat() hack). Some future
- release may probably remove block device support, once
- char-device support is built into EMX.
-
- Fixed perl5db tty check.
-
-22.12.94 EMX fixlevel 2 exports its exception handler, so now
- signals work even when the REXX variable pool is enabled.
-
- Disabled error and exception popups.
-
-27.12.94 Case conversions of tied variables cleaned up.
-
- REXX (REXX.DLL, REXXAPI.DLL) now loaded on demand.
-
-7.1.95 Fixed Shell module (did not allow more than one argument).
-
-11.1.95 Accept drive letter as absolute path in do/require/use.
-
-13.1.95 Larrys memory-leak patches (#1, dated Friday 13).
-
-26.1.95 fcntl and ioctl were missing. fcntl was explicitly disabled
- in its source code (ifndef DOSISH) and the ioctl enabler is
- in the wrong place (unixish.h instead of config.sh).
-
-16.3.95 DosQueryFSAttach (stat hack) may crash the system. Now just
- look for /dev/con and /dev/tty.
-
- Applied "pad_findlex" patch (patches/1).
-
-23.3.95 Support fork. Two executables, one for DLLs and one for fork.
-
-24.3.95 5.001
-
-13.4.95 Patchlevel "c".
-
-21.4.95 Truncate names of extension DLLs to 8 chars - Warp no longer
- accepts them (2.x did).
-
-22.4.95 Replaced EMX dirent by my own to get all directory entries
- even when HPFS386 is used. Additionally, my implementation
- is not restricted in the total size of the directory (a
- conflict between Perls memory allocator and the one of the
- EMX library DLL).
-
-27.4.95 Support for fork() disabled system() in DLL version.
-
-7.5.95 Added Tye McQueen's FileGlob. See File::KGlob*.
-
-12.5.95 Fixed Cwd. Fixed OS/2 dependencies in MakeMaker, with
- a few Config.sh items added (separators, exe-extension).
-
- Moved UPM and REXX to OS2::. Combined REXXCALL and REXX.
- Plain old REXX module is still available as passthru though.
-
- Perl DLLs now have an underscore appended to avoid name
- conflicts with standard OS/2 DLLs (see DynaLoader.pm).
-
-13.5.95 Added FTP API support (OS2::FTP).
-
-2.7.95 Applied "official unofficial" patches up to level "m".
- The modpods documentation now is in the modules themselves.
-
-4.7.95 Implement command pipes (my_popen) using fork instead of
- standard popen in the fork version (perl5x.exe). While this
- is a lot slower, it correctly returns the process id and
- supports open(F,"-|") and open(F,"|-").
-
- Use the same code for exec(CMD) as for system(CMD).
-
- Support socket functions (set|get|end)(host|net|proto|serv)ent.
diff --git a/gnu/usr.bin/perl/os2/diff.configure b/gnu/usr.bin/perl/os2/diff.configure
index 53aa16b4a2e..9f42dc139fe 100644
--- a/gnu/usr.bin/perl/os2/diff.configure
+++ b/gnu/usr.bin/perl/os2/diff.configure
@@ -1,589 +1,274 @@
-*** Configure.orig Thu Dec 07 14:38:08 1995
---- Configure Mon Dec 18 19:16:22 1995
-***************
-*** 1377,1383 ****
- *)
- 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
---- 1377,1383 ----
- *)
- 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
-***************
-*** 1386,1392 ****
- say=offhand
- for file in $trylist; do
- xxx=`./loc $file $file $pth`
-! eval $file=$xxx
- eval _$file=$xxx
- case "$xxx" in
- /*)
---- 1386,1394 ----
- say=offhand
- for file in $trylist; do
- xxx=`./loc $file $file $pth`
-! if test "X$file" != "X$xxx" ; then
-! eval $file=$xxx
-! fi
- eval _$file=$xxx
- case "$xxx" in
- /*)
-***************
-*** 3173,3179 ****
- 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." ;;
---- 3175,3181 ----
- exit(0);
- }
- EOM
-! if $cc -o gccvers gccvers.c $ldflags >/dev/null 2>&1; then
- gccversion=`./gccvers`
- case "$gccversion" in
- '') echo "You are not using GNU cc." ;;
-***************
-*** 3765,3770 ****
---- 3767,3778 ----
- *"-l$thislib "*);;
- *) dflt="$dflt -l$thislib";;
- esac
-+ elif xxx=`./loc $thislib.lib X $libpth`; $test -f "$xxx"; then
-+ echo "Found -l$thislib."
-+ case " $dflt " in
-+ *"-l$thislib "*);;
-+ *) dflt="$dflt -l$thislib";;
-+ esac
- else
- echo "No -l$thislib."
- fi
-***************
-*** 3864,3870 ****
- esac
- ;;
- esac
-! libnames='';
- case "$libs" in
- '') ;;
- *) for thislib in $libs; do
---- 3872,3878 ----
- esac
- ;;
- esac
-! #libnames='';
- case "$libs" in
- '') ;;
- *) for thislib in $libs; do
-***************
-*** 3878,3889 ****
- :
- 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 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
---- 3886,3899 ----
- :
- elif try=`./loc lib$thislib.$so X $libpth`; $test -f "$try"; then
- :
-! elif try=`./loc lib$thislib$lib_ext 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 $thislib$lib_ext X $libpth`; $test -f "$try"; then
-+ :
- elif try=`./loc Slib$thislib.a X $xlibpth`; $test -f "$try"; then
- :
- else
-***************
-*** 3932,3942 ****
- 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
---- 3942,3952 ----
- 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$lib_ext; then
-! libc=$incpath/usr/lib/libc$lib_ext;
- echo "Your C library seems to be in $libc. That's fine."
-! elif $test -r /lib/libc$lib_ext; then
-! libc=/lib/libc$lib_ext;
- 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
-***************
-*** 4049,4054 ****
---- 4059,4068 ----
- 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
- else
- nm -p $* 2>/dev/null >libc.tmp
- $grep fprintf libc.tmp > libc.ptf
-***************
-*** 4059,4081 ****
- eval $xrun
- else
- echo " "
-! echo "nm didn't seem to work right. Trying ar instead..." >&4
- com=''
-! if ar t $libc > libc.tmp; then
- for thisname in $libnames; do
-! ar t $thisname >>libc.tmp
- done
-! $sed -e 's/\.o$//' < 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
---- 4073,4096 ----
- eval $xrun
- else
- echo " "
-! echo "nm didn't seem to work right. Trying $ar instead..." >&4
- com=''
-! if test "X$osname" = "Xos2"; then ar_opt=tv ; else ar_opt=t ;fi
-! if $ar $ar_opt $libc > libc.tmp; then
- for thisname in $libnames; do
-! $ar $ar_opt $thisname >>libc.tmp
- done
-! $sed -e 's/\.o$//' -e 's/^ \+//' < libc.tmp | grep -v "^IMPORT#" > 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
-***************
-*** 4421,4427 ****
- exit(0);
- }
- EOCP
-! if $cc $ccflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then
- intsize=`./try`
- echo "Your integers are $intsize bytes long."
- else
---- 4436,4442 ----
- exit(0);
- }
- EOCP
-! if $cc $ccflags $ldflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then
- intsize=`./try`
- echo "Your integers are $intsize bytes long."
- else
-***************
-*** 4501,4507 ****
- exit(result);
- }
- EOCP
-! if $cc -o try $ccflags try.c >/dev/null 2>&1; then
- ./try
- yyy=$?
- else
---- 4516,4522 ----
- exit(result);
- }
- EOCP
-! if $cc -o try $ccflags try.c $ldflags >/dev/null 2>&1; then
- ./try
- yyy=$?
- else
-***************
-*** 4582,4588 ****
-
- }
- EOCP
-! if $cc -o try $ccflags try.c >/dev/null 2>&1; then
- ./try
- castflags=$?
- else
---- 4597,4603 ----
-
- }
- EOCP
-! if $cc -o try $ccflags try.c $ldflags >/dev/null 2>&1; then
- ./try
- castflags=$?
- else
-***************
-*** 4621,4627 ****
- exit((unsigned long)vsprintf(buf,"%s",args) > 10L);
- }
- EOF
-! if $cc $ccflags vprintf.c -o vprintf >/dev/null 2>&1 && ./vprintf; then
- echo "Your vsprintf() returns (int)." >&4
- val2="$undef"
- else
---- 4636,4642 ----
- exit((unsigned long)vsprintf(buf,"%s",args) > 10L);
- }
- EOF
-! if $cc $ccflags vprintf.c $ldflags -o vprintf >/dev/null 2>&1 && ./vprintf; then
- echo "Your vsprintf() returns (int)." >&4
- val2="$undef"
- else
-***************
-*** 4691,4697 ****
- cryptlib=-lcrypt
- fi
- if $test -z "$cryptlib"; then
-! cryptlib=`./loc libcrypt.a "" $libpth`
- else
- cryptlib=-lcrypt
- fi
---- 4706,4712 ----
- cryptlib=-lcrypt
- fi
- if $test -z "$cryptlib"; then
-! cryptlib=`./loc libcrypt$lib_ext "" $libpth`
- else
- cryptlib=-lcrypt
- fi
-***************
-*** 5198,5204 ****
- }
- EOM
- if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 &&
-! $ld $lddlflags -o dyna.$dlext dyna.o > /dev/null 2>&1 &&
- $cc $ccflags $ldflags $cccdlflags $ccdlflags fred.c -o fred $libs > /dev/null 2>&1; then
- xxx=`./fred`
- case $xxx in
---- 5213,5219 ----
- }
- EOM
- if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 &&
-! $ld $lddlflags -o dyna.$dlext dyna$obj_ext > /dev/null 2>&1 &&
- $cc $ccflags $ldflags $cccdlflags $ccdlflags fred.c -o fred $libs > /dev/null 2>&1; then
- xxx=`./fred`
- case $xxx in
-***************
-*** 5355,5361 ****
- EOCP
- : check sys/file.h first to get FREAD on Sun
- if $test `./findhdr sys/file.h` && \
-! $cc $cppflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then
- h_sysfile=true;
- echo "<sys/file.h> defines the O_* constants..." >&4
- if ./open3; then
---- 5370,5376 ----
- EOCP
- : check sys/file.h first to get FREAD on Sun
- if $test `./findhdr sys/file.h` && \
-! $cc $cppflags $ldflags "-DI_SYS_FILE" open3.c -o open3 >/dev/null 2>&1 ; then
- h_sysfile=true;
- echo "<sys/file.h> defines the O_* constants..." >&4
- if ./open3; then
-***************
-*** 5366,5372 ****
- val="$undef"
- fi
- elif $test `./findhdr fcntl.h` && \
-! $cc "-DI_FCNTL" open3.c -o open3 >/dev/null 2>&1 ; then
- h_fcntl=true;
- echo "<fcntl.h> defines the O_* constants..." >&4
- if ./open3; then
---- 5381,5387 ----
- val="$undef"
- fi
- elif $test `./findhdr fcntl.h` && \
-! $cc "-DI_FCNTL" $ldflags open3.c -o open3 >/dev/null 2>&1 ; then
- h_fcntl=true;
- echo "<fcntl.h> defines the O_* constants..." >&4
- if ./open3; then
-***************
-*** 5848,5854 ****
- y*|true)
- usemymalloc='y'
- mallocsrc='malloc.c'
-! mallocobj='malloc.o'
- d_mymalloc="$define"
- case "$libs" in
- *-lmalloc*)
---- 5863,5869 ----
- y*|true)
- usemymalloc='y'
- mallocsrc='malloc.c'
-! mallocobj="malloc$obj_ext"
- d_mymalloc="$define"
- case "$libs" in
- *-lmalloc*)
-***************
-*** 6283,6292 ****
- : 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"
---- 6298,6307 ----
- : 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$lib_ext..." >&4
-! if test -f /usr/lib/libnet$lib_ext; then
-! ( (nm $nm_opt /usr/lib/libnet$lib_ext | eval $nm_extract) || \
-! $ar t /usr/lib/libnet$lib_ext) 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"
-***************
-*** 6299,6305 ****
- d_oldsock="$define"
- fi
- else
-! echo "or even in libnet.a, which is peculiar." >&4
- d_socket="$undef"
- d_oldsock="$undef"
- fi
---- 6314,6320 ----
- d_oldsock="$define"
- fi
- else
-! echo "or even in libnet$lib_ext, which is peculiar." >&4
- d_socket="$undef"
- d_oldsock="$undef"
- fi
-***************
-*** 7055,7061 ****
- printf("%d\n", (char *)&try.bar - (char *)&try.foo);
- }
- EOCP
-! if $cc $ccflags try.c -o try >/dev/null 2>&1; then
- dflt=`./try`
- else
- dflt='8'
---- 7070,7076 ----
- printf("%d\n", (char *)&try.bar - (char *)&try.foo);
- }
- EOCP
-! if $cc $ccflags $ldflags try.c -o try >/dev/null 2>&1; then
- dflt=`./try`
- else
- dflt='8'
-***************
-*** 7080,7086 ****
- '') obj_ext='.o';;
- esac
- case "$path_sep" in
-! '') path_sep=':';;
- esac
- : Which makefile gets called first. This is used by make depend.
- case "$firstmakefile" in
---- 7095,7101 ----
- '') obj_ext='.o';;
- esac
- case "$path_sep" in
-! '') path_sep="$p_";;
- esac
- : Which makefile gets called first. This is used by make depend.
- case "$firstmakefile" in
-***************
-*** 7120,7126 ****
- }
- EOCP
- xxx_prompt=y
-! if $cc $ccflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then
- dflt=`./try`
- case "$dflt" in
- [1-4][1-4][1-4][1-4]|12345678|87654321)
---- 7135,7141 ----
- }
- EOCP
- xxx_prompt=y
-! if $cc $ccflags $ldflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then
- dflt=`./try`
- case "$dflt" in
- [1-4][1-4][1-4][1-4]|12345678|87654321)
-***************
-*** 7470,7476 ****
- printf("%d\n",i);
- }
- EOCP
-! if $cc try.c -o try >/dev/null 2>&1 ; then
- dflt=`try`
- else
- dflt='?'
---- 7485,7491 ----
- printf("%d\n",i);
- }
- EOCP
-! if $cc $ldflags try.c -o try >/dev/null 2>&1 ; then
- dflt=`try`
- else
- dflt='?'
-***************
-*** 7497,7514 ****
- $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='';;
---- 7512,7529 ----
- $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$lib_ext bar2$obj_ext bar1$obj_ext >/dev/null 2>&1
-! if $cc $ccflags $ldflags -o foobar foo$obj_ext bar$lib_ext $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$lib_ext >/dev/null 2>&1 &&
-! $cc $ccflags $ldflags -o foobar foo$obj_ext bar$lib_ext $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='';;
-***************
-*** 7580,7586 ****
- '') $echo $n ".$c"
- if $cc $ccflags \
- $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \
-! try.c -o try >/dev/null 2>&1 ; then
- set X $i_time $i_systime $i_systimek $sysselect $s_timeval
- shift
- flags="$*"
---- 7595,7601 ----
- '') $echo $n ".$c"
- if $cc $ccflags \
- $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \
-! try.c -o try $ldflags >/dev/null 2>&1 ; then
- set X $i_time $i_systime $i_systimek $sysselect $s_timeval
- shift
- flags="$*"
-***************
-*** 7649,7655 ****
- #endif
- }
- EOCP
-! if $cc $ccflags -DTRYBITS fd_set.c -o fd_set >fd_set.out 2>&1 ; then
- d_fds_bits="$define"
- d_fd_set="$define"
- echo "Well, your system knows about the normal fd_set typedef..." >&4
---- 7664,7670 ----
- #endif
- }
- EOCP
-! if $cc $ccflags $ldflags -DTRYBITS fd_set.c -o fd_set >fd_set.out 2>&1 ; then
- d_fds_bits="$define"
- d_fd_set="$define"
- echo "Well, your system knows about the normal fd_set typedef..." >&4
-***************
-*** 7666,7672 ****
- $cat <<'EOM'
- Hmm, your compiler has some difficulty with fd_set. Checking further...
- EOM
-! if $cc $ccflags fd_set.c -o fd_set >fd_set.out 2>&1 ; then
- d_fds_bits="$undef"
- d_fd_set="$define"
- echo "Well, your system has some sort of fd_set available..." >&4
---- 7681,7687 ----
- $cat <<'EOM'
- Hmm, your compiler has some difficulty with fd_set. Checking further...
- EOM
-! if $cc $ccflags $ldflags fd_set.c -o fd_set >fd_set.out 2>&1 ; then
- d_fds_bits="$undef"
- d_fd_set="$define"
- echo "Well, your system has some sort of fd_set available..." >&4
-***************
-*** 8380,8386 ****
- else
- echo "false"
- fi
-! $rm -f varargs.o
- EOP
- chmod +x varargs
-
---- 8395,8401 ----
- else
- echo "false"
- fi
-! $rm -f varargs$obj_ext
- EOP
- chmod +x varargs
-
-***************
-*** 8744,8750 ****
- echo " "
- echo "Stripping down executable paths..." >&4
- for file in $loclist $trylist; do
-! eval $file="\$file"
- done
- ;;
- esac
---- 8759,8765 ----
- echo " "
- echo "Stripping down executable paths..." >&4
- for file in $loclist $trylist; do
-! if test X$file != Xln -o X$osname != Xos2; then eval $file="\$file"; fi
- done
- ;;
- esac
+--- Configure.orig Fri Aug 1 23:12:26 1997
++++ Configure Fri Aug 1 23:20:24 1997
+@@ -1489,7 +1489,7 @@
+ *)
+ echo "I don't know where '$file' is, and my life depends on it." >&4
+ echo "Go find a public domain implementation or fix your PATH setting!" >&4
+- exit 1
++ #exit 1
+ ;;
+ esac
+ done
+@@ -1498,7 +1498,9 @@
+ say=offhand
+ for file in $trylist; do
+ xxx=`./loc $file $file $pth`
+- eval $file=$xxx
++ if test "X$file" != "X$xxx" ; then
++ eval $file=$xxx
++ fi
+ eval _$file=$xxx
+ case "$xxx" in
+ /*)
+@@ -3198,7 +3200,7 @@
+ exit(0);
+ }
+ EOM
+-if $cc -o gccvers gccvers.c >/dev/null 2>&1; then
++if $cc -o gccvers gccvers.c $ldflags >/dev/null 2>&1; then
+ gccversion=`./gccvers`
+ case "$gccversion" in
+ '') echo "You are not using GNU cc." ;;
+@@ -3401,6 +3403,12 @@
+ *"-l$thislib "*);;
+ *) dflt="$dflt -l$thislib";;
+ esac
++ elif xxx=`./loc $thislib.lib X $libpth`; $test -f "$xxx"; then
++ echo "Found -l$thislib."
++ case " $dflt " in
++ *"-l$thislib "*);;
++ *) dflt="$dflt -l$thislib";;
++ esac
+ else
+ echo "No -l$thislib."
+ fi
+@@ -3950,7 +3958,7 @@
+ esac
+ ;;
+ esac
+-libnames='';
++#libnames='';
+ case "$libs" in
+ '') ;;
+ *) for thislib in $libs; do
+@@ -3972,6 +3980,8 @@
+ :
+ elif try=`./loc $thislib X $libpth`; $test -f "$try"; then
+ :
++ elif try=`./loc $thislib$lib_ext X $libpth`; $test -f "$try"; then
++ :
+ elif try=`./loc Slib$thislib$lib_ext X $xlibpth`; $test -f "$try"; then
+ :
+ else
+@@ -4156,6 +4166,10 @@
+ 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
+ else
+ nm -p $* 2>/dev/null >libc.tmp
+ $grep fprintf libc.tmp > libc.ptf
+@@ -4166,23 +4180,33 @@
+ eval $xrun
+ else
+ echo " "
+- echo "nm didn't seem to work right. Trying ar instead..." >&4
++ echo "nm didn't seem to work right. Trying $ar instead..." >&4
+ com=''
+- if ar t $libc > libc.tmp; then
+- for thisname in $libnames; do
+- ar t $thisname >>libc.tmp
++ if test "X$osname" = "Xos2"; then ar_opt=tv ; else ar_opt=t ;fi
++ if $ar $ar_opt $libc > libc.tmp; then
++ echo \; > libc.tmp
++ for thisname in $libnames $libc; do
++ $ar $ar_opt $thisname >>libc.tmp
++ if test "X$osname" = "Xos2"; then
++ # Revision 50 of EMX has bug in $ar:
++ emximp -o tmp.imp $thisname \
++ 2>/dev/null && \
++ $sed -e 's/^\([_a-zA-Z0-9]*\) .*$/\1/p' \
++ < tmp.imp >>libc.tmp
++ $rm tmp.imp
++ fi
+ done
+- $sed -e 's/\.o$//' < libc.tmp > libc.list
++ $sed -e 's/\.o$//' -e 's/^ \+//' < libc.tmp | grep -v "^IMPORT#" > libc.list
+ echo "Ok." >&4
+ else
+- echo "ar didn't seem to work right." >&4
++ 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
++ $ar t $thisname >>libc.tmp
+ done
+ echo "Ok." >&4
+ else
+@@ -5611,15 +5635,15 @@
+ EOCP
+ : check sys/file.h first, no particular reason here
+ if $test `./findhdr sys/file.h` && \
+- $cc $cppflags -DI_SYS_FILE access.c -o access >/dev/null 2>&1 ; then
++ $cc $ldflags $cppflags -DI_SYS_FILE access.c -o access >/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 access.c -o access >/dev/null 2>&1 ; then
++ $cc $ldflags $cppflags -DI_FCNTL access.c -o access >/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 access.c -o access >/dev/null 2>&1 ; then
++ $cc $ldflags $cppflags -DI_UNISTD access.c -o access >/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
+@@ -5913,7 +5937,7 @@
+ exit(result);
+ }
+ EOCP
+-if $cc -o try $ccflags try.c >/dev/null 2>&1; then
++if $cc -o try $ccflags try.c $ldflags >/dev/null 2>&1; then
+ ./try
+ yyy=$?
+ else
+@@ -5994,7 +6018,7 @@
+
+ }
+ EOCP
+-if $cc -o try $ccflags try.c >/dev/null 2>&1; then
++if $cc -o try $ccflags try.c $ldflags >/dev/null 2>&1; then
+ ./try
+ castflags=$?
+ else
+@@ -6033,7 +6057,7 @@
+ exit((unsigned long)vsprintf(buf,"%s",args) > 10L);
+ }
+ EOF
+- if $cc $ccflags vprintf.c -o vprintf >/dev/null 2>&1 && ./vprintf; then
++ if $cc $ccflags vprintf.c $ldflags -o vprintf >/dev/null 2>&1 && ./vprintf; then
+ echo "Your vsprintf() returns (int)." >&4
+ val2="$undef"
+ else
+@@ -6381,7 +6405,7 @@
+ EOCP
+ : check sys/file.h first to get FREAD on Sun
+ if $test `./findhdr sys/file.h` && \
+- $cc $ccflags "-DI_SYS_FILE" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then
++ $cc $ldflags $ccflags "-DI_SYS_FILE" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then
+ h_sysfile=true;
+ echo "<sys/file.h> defines the O_* constants..." >&4
+ if ./open3; then
+@@ -6392,7 +6416,7 @@
+ val="$undef"
+ fi
+ elif $test `./findhdr fcntl.h` && \
+- $cc $ccflags "-DI_FCNTL" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then
++ $cc $ldflags $ccflags "-DI_FCNTL" -o open3 $ldflags open3.c $libs >/dev/null 2>&1 ; then
+ h_fcntl=true;
+ echo "<fcntl.h> defines the O_* constants..." >&4
+ if ./open3; then
+@@ -6898,7 +6922,7 @@
+ y*|true)
+ usemymalloc='y'
+ mallocsrc='malloc.c'
+- mallocobj='malloc.o'
++ mallocobj="malloc$obj_ext"
+ d_mymalloc="$define"
+ case "$libs" in
+ *-lmalloc*)
+@@ -8156,7 +8180,7 @@
+ printf("%d\n", (char *)&try.bar - (char *)&try.foo);
+ }
+ EOCP
+- if $cc $ccflags try.c -o try >/dev/null 2>&1; then
++ if $cc $ccflags $ldflags try.c -o try >/dev/null 2>&1; then
+ dflt=`./try`
+ else
+ dflt='8'
+@@ -8204,7 +8228,7 @@
+ }
+ EOCP
+ xxx_prompt=y
+- if $cc $ccflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then
++ if $cc $ccflags $ldflags try.c -o try >/dev/null 2>&1 && ./try > /dev/null; then
+ dflt=`./try`
+ case "$dflt" in
+ [1-4][1-4][1-4][1-4]|12345678|87654321)
+@@ -8711,18 +8735,18 @@
+ $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$lib_ext bar2.o bar1.o >/dev/null 2>&1
++$ar rc bar$lib_ext bar2.o bar1.o >/dev/null 2>&1
+ if $cc $ccflags $ldflags -o foobar foo.o bar$lib_ext $libs > /dev/null 2>&1 &&
+ ./foobar >/dev/null 2>&1; then
+- echo "ar appears to generate random libraries itself."
++ echo "$ar appears to generate random libraries itself."
+ orderlib=false
+ ranlib=":"
+-elif ar ts bar$lib_ext >/dev/null 2>&1 &&
++elif $ar ts bar$lib_ext >/dev/null 2>&1 &&
+ $cc $ccflags $ldflags -o foobar foo.o bar$lib_ext $libs > /dev/null 2>&1 &&
+ ./foobar >/dev/null 2>&1; then
+- echo "a table of contents needs to be added with 'ar ts'."
++ echo "a table of contents needs to be added with '$ar ts'."
+ orderlib=false
+- ranlib="ar ts"
++ ranlib="$ar ts"
+ else
+ case "$ranlib" in
+ :) ranlib='';;
+@@ -8794,7 +8818,7 @@
+ '') $echo $n ".$c"
+ if $cc $ccflags \
+ $i_time $i_systime $i_systimek $sysselect $s_timeval $s_timezone \
+- try.c -o try >/dev/null 2>&1 ; then
++ try.c -o try $ldflags >/dev/null 2>&1 ; then
+ set X $i_time $i_systime $i_systimek $sysselect $s_timeval
+ shift
+ flags="$*"
+@@ -8863,7 +8887,7 @@
+ #endif
+ }
+ EOCP
+-if $cc $ccflags -DTRYBITS fd_set.c -o fd_set >fd_set.out 2>&1 ; then
++if $cc $ccflags $ldflags -DTRYBITS fd_set.c -o fd_set >fd_set.out 2>&1 ; then
+ d_fds_bits="$define"
+ d_fd_set="$define"
+ echo "Well, your system knows about the normal fd_set typedef..." >&4
+@@ -8880,7 +8904,7 @@
+ $cat <<'EOM'
+ Hmm, your compiler has some difficulty with fd_set. Checking further...
+ EOM
+- if $cc $ccflags fd_set.c -o fd_set >fd_set.out 2>&1 ; then
++ if $cc $ccflags $ldflags fd_set.c -o fd_set >fd_set.out 2>&1 ; then
+ d_fds_bits="$undef"
+ d_fd_set="$define"
+ echo "Well, your system has some sort of fd_set available..." >&4
+@@ -9627,7 +9651,7 @@
+ else
+ echo "false"
+ fi
+-$rm -f varargs.o
++$rm -f varargs$obj_ext
+ EOP
+ chmod +x varargs
+
+@@ -9954,7 +9978,7 @@
+ echo " "
+ echo "Stripping down executable paths..." >&4
+ for file in $loclist $trylist; do
+- eval $file="\$file"
++ if test X$file != Xln -o X$osname != Xos2; then eval $file="\$file"; fi
+ done
+ ;;
+ esac
diff --git a/gnu/usr.bin/perl/os2/diff.db_file b/gnu/usr.bin/perl/os2/diff.db_file
deleted file mode 100644
index 7fcca0a7933..00000000000
--- a/gnu/usr.bin/perl/os2/diff.db_file
+++ /dev/null
@@ -1,15 +0,0 @@
-*** ext/DB_File/db_file.xs~ Tue Nov 14 11:14:36 1995
---- ext/DB_File/DB_File.xs Tue Dec 19 00:50:52 1995
-***************
-*** 424,429 ****
---- 424,433 ----
- }
-
-
-+ #ifdef __EMX__
-+ flags |= O_BINARY;
-+ #endif /* __EMX__ */
-+
- RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
-
- #if 0
diff --git a/gnu/usr.bin/perl/os2/dl_os2.c b/gnu/usr.bin/perl/os2/dl_os2.c
new file mode 100644
index 00000000000..19f36f6aa7f
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/dl_os2.c
@@ -0,0 +1,71 @@
+#include "dlfcn.h"
+
+#define INCL_BASE
+#include <os2.h>
+
+static ULONG retcode;
+
+void *
+dlopen(char *path, int mode)
+{
+ HMODULE handle;
+ char tmp[260], *beg, *dot;
+ char fail[300];
+ ULONG rc;
+
+ if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0)
+ return (void *)handle;
+
+ retcode = rc;
+
+ /* Not found. Check for non-FAT name and try truncated name. */
+ /* Don't know if this helps though... */
+ for (beg = dot = path + strlen(path);
+ beg > path && !strchr(":/\\", *(beg-1));
+ beg--)
+ if (*beg == '.')
+ dot = beg;
+ if (dot - beg > 8) {
+ int n = beg+8-path;
+ memmove(tmp, path, n);
+ memmove(tmp+n, dot, strlen(dot)+1);
+ if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0)
+ return (void *)handle;
+ }
+
+ return NULL;
+}
+
+void *
+dlsym(void *handle, char *symbol)
+{
+ ULONG rc, type;
+ PFN addr;
+
+ rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr);
+ if (rc == 0) {
+ rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type);
+ if (rc == 0 && type == PT_32BIT)
+ return (void *)addr;
+ rc = ERROR_CALL_NOT_IMPLEMENTED;
+ }
+ retcode = rc;
+ return NULL;
+}
+
+char *
+dlerror(void)
+{
+ static char buf[300];
+ ULONG len;
+
+ if (retcode == 0)
+ return NULL;
+ if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len))
+ sprintf(buf, "OS/2 system error code %d", retcode);
+ else
+ buf[len] = '\0';
+ retcode = 0;
+ return buf;
+}
+
diff --git a/gnu/usr.bin/perl/os2/dlfcn.h b/gnu/usr.bin/perl/os2/dlfcn.h
new file mode 100644
index 00000000000..c96f97f82d9
--- /dev/null
+++ b/gnu/usr.bin/perl/os2/dlfcn.h
@@ -0,0 +1,3 @@
+void *dlopen(char *path, int mode);
+void *dlsym(void *handle, char *symbol);
+char *dlerror(void);
diff --git a/gnu/usr.bin/perl/os2/notes b/gnu/usr.bin/perl/os2/notes
deleted file mode 100644
index f8591878b6d..00000000000
--- a/gnu/usr.bin/perl/os2/notes
+++ /dev/null
@@ -1,28 +0,0 @@
-mv Makefile.SH Makefile.SHs
-exit 0
-
-Everything is updated to perl5.002b1d.
-
-I added a generally useful ;-) code to Makefile.SH to have dependencies
-on makedepend, installman and installperl (makedepend is the tricky one!).
-
-I did update MANIFEST with _all_ the added diff.* files, I hope
-some files will be just applied, thus not needed for MANIFEST. Well, the
-patch for MANIFEST is in os2/diff.MANIFEST ;-).
-
-diff.init is just a suggestion to move system-specific code into headers.
-
-I think that
-
-diff.Makefile
-diff.installperl
-diff.installman
-diff.x2pMakefile
-diff.mkdep
-
-are ready for prime time, though big ;-(.
-It is up to you what to do with them (They use long names like EXE_EXT now).
-
-diff.c2ph, diff.rest are small and should not break anything.
-
-diff.db_file adds binary mode.
diff --git a/gnu/usr.bin/perl/os2/os2.c b/gnu/usr.bin/perl/os2/os2.c
index a518c41d45f..8a292e30f25 100644
--- a/gnu/usr.bin/perl/os2/os2.c
+++ b/gnu/usr.bin/perl/os2/os2.c
@@ -1,10 +1,8 @@
#define INCL_DOS
#define INCL_NOPM
#define INCL_DOSFILEMGR
-#ifndef NO_SYS_ALLOC
-# define INCL_DOSMEMMGR
-# define INCL_DOSERRORS
-#endif /* ! defined NO_SYS_ALLOC */
+#define INCL_DOSMEMMGR
+#define INCL_DOSERRORS
#include <os2.h>
/*
@@ -15,29 +13,150 @@
#include <errno.h>
#include <limits.h>
#include <process.h>
+#include <fcntl.h>
#include "EXTERN.h"
#include "perl.h"
/*****************************************************************************/
+/* 2.1 would not resolve symbols on demand, and has no ExtLIBPATH. */
+static PFN ExtFCN[2]; /* Labeled by ord below. */
+static USHORT loadOrd[2] = { 874, 873 }; /* Query=874, Set=873. */
+#define ORD_QUERY_ELP 0
+#define ORD_SET_ELP 1
+
+APIRET
+loadByOrd(ULONG ord)
+{
+ if (ExtFCN[ord] == NULL) {
+ static HMODULE hdosc = 0;
+ BYTE buf[20];
+ PFN fcn;
+ APIRET rc;
+
+ if ((!hdosc && CheckOSError(DosLoadModule(buf, sizeof buf,
+ "doscalls", &hdosc)))
+ || CheckOSError(DosQueryProcAddr(hdosc, loadOrd[ord], NULL, &fcn)))
+ die("This version of OS/2 does not support doscalls.%i",
+ loadOrd[ord]);
+ ExtFCN[ord] = fcn;
+ }
+ if ((long)ExtFCN[ord] == -1) die("panic queryaddr");
+}
+
/* priorities */
+static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
+ self inverse. */
+#define QSS_INI_BUFFER 1024
-int setpriority(int which, int pid, int val)
+PQTOPLEVEL
+get_sysinfo(ULONG pid, ULONG flags)
{
- return DosSetPriority((pid < 0) ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
- val >> 8, val & 0xFF, abs(pid));
+ char *pbuffer;
+ ULONG rc, buf_len = QSS_INI_BUFFER;
+
+ New(1322, pbuffer, buf_len, char);
+ /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
+ rc = QuerySysState(flags, pid, pbuffer, buf_len);
+ while (rc == ERROR_BUFFER_OVERFLOW) {
+ Renew(pbuffer, buf_len *= 2, char);
+ rc = QuerySysState(flags, pid, pbuffer, buf_len);
+ }
+ if (rc) {
+ FillOSError(rc);
+ Safefree(pbuffer);
+ return 0;
+ }
+ return (PQTOPLEVEL)pbuffer;
+}
+
+#define PRIO_ERR 0x1111
+
+static ULONG
+sys_prio(pid)
+{
+ ULONG prio;
+ PQTOPLEVEL psi;
+
+ psi = get_sysinfo(pid, QSS_PROCESS);
+ if (!psi) {
+ return PRIO_ERR;
+ }
+ if (pid != psi->procdata->pid) {
+ Safefree(psi);
+ croak("panic: wrong pid in sysinfo");
+ }
+ prio = psi->procdata->threads->priority;
+ Safefree(psi);
+ return prio;
+}
+
+int
+setpriority(int which, int pid, int val)
+{
+ ULONG rc, prio;
+ PQTOPLEVEL psi;
+
+ prio = sys_prio(pid);
+
+ if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
+ if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
+ /* Do not change class. */
+ return CheckOSError(DosSetPriority((pid < 0)
+ ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
+ 0,
+ (32 - val) % 32 - (prio & 0xFF),
+ abs(pid)))
+ ? -1 : 0;
+ } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
+ /* Documentation claims one can change both class and basevalue,
+ * but I find it wrong. */
+ /* Change class, but since delta == 0 denotes absolute 0, correct. */
+ if (CheckOSError(DosSetPriority((pid < 0)
+ ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
+ priors[(32 - val) >> 5] + 1,
+ 0,
+ abs(pid))))
+ return -1;
+ if ( ((32 - val) % 32) == 0 ) return 0;
+ return CheckOSError(DosSetPriority((pid < 0)
+ ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
+ 0,
+ (32 - val) % 32,
+ abs(pid)))
+ ? -1 : 0;
+ }
+/* else return CheckOSError(DosSetPriority((pid < 0) */
+/* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
+/* priors[(32 - val) >> 5] + 1, */
+/* (32 - val) % 32 - (prio & 0xFF), */
+/* abs(pid))) */
+/* ? -1 : 0; */
}
-int getpriority(int which /* ignored */, int pid)
+int
+getpriority(int which /* ignored */, int pid)
{
TIB *tib;
PIB *pib;
- DosGetInfoBlocks(&tib, &pib);
- return tib->tib_ptib2->tib2_ulpri;
+ ULONG rc, ret;
+
+ if (!(_emx_env & 0x200)) return 0; /* Nop if not OS/2. */
+ /* DosGetInfoBlocks has old priority! */
+/* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
+/* if (pid != pib->pib_ulpid) { */
+ ret = sys_prio(pid);
+ if (ret == PRIO_ERR) {
+ return -1;
+ }
+/* } else */
+/* ret = tib->tib_ptib2->tib2_ulpri; */
+ return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
}
/*****************************************************************************/
/* spawn */
+typedef void (*Sigfunc) _((int));
static int
result(int flag, int pid)
@@ -45,22 +164,36 @@ result(int flag, int pid)
int r, status;
Signal_t (*ihand)(); /* place to save signal during system() */
Signal_t (*qhand)(); /* place to save signal during system() */
+#ifndef __EMX__
+ RESULTCODES res;
+ int rpid;
+#endif
- if (pid < 0 || flag != 0)
+ if (pid < 0 || flag != 0)
return pid;
- ihand = signal(SIGINT, SIG_IGN);
- qhand = signal(SIGQUIT, SIG_IGN);
+#ifdef __EMX__
+ ihand = rsignal(SIGINT, SIG_IGN);
+ qhand = rsignal(SIGQUIT, SIG_IGN);
do {
r = wait4pid(pid, &status, 0);
} while (r == -1 && errno == EINTR);
- signal(SIGINT, ihand);
- signal(SIGQUIT, qhand);
+ rsignal(SIGINT, ihand);
+ rsignal(SIGQUIT, qhand);
statusvalue = (U16)status;
if (r < 0)
return -1;
return status & 0xFFFF;
+#else
+ ihand = rsignal(SIGINT, SIG_IGN);
+ r = DosWaitChild(DCWA_PROCESS, DCWW_WAIT, &res, &rpid, pid);
+ rsignal(SIGINT, ihand);
+ statusvalue = res.codeResult << 8 | res.codeTerminate;
+ if (r)
+ return -1;
+ return statusvalue;
+#endif
}
int
@@ -70,15 +203,15 @@ register SV **mark;
register SV **sp;
{
register char **a;
- char *tmps;
+ char *tmps = NULL;
int rc;
- int flag = P_WAIT, trueflag;
+ int flag = P_WAIT, trueflag, err, secondtry = 0;
if (sp > mark) {
- New(401,Argv, sp - mark + 1, char*);
+ New(1301,Argv, sp - mark + 3, char*);
a = Argv;
- if (mark < sp && SvIOKp(*(mark+1))) {
+ if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
++mark;
flag = SvIVx(*mark);
}
@@ -95,13 +228,49 @@ register SV **sp;
if (flag == P_WAIT)
flag = P_NOWAIT;
- if (*Argv[0] != '/' && *Argv[0] != '\\') /* will swawnvp use PATH? */
+ if (strEQ(Argv[0],"/bin/sh")) Argv[0] = sh_path;
+
+ if (Argv[0][0] != '/' && Argv[0][0] != '\\'
+ && !(Argv[0][0] && Argv[0][1] == ':'
+ && (Argv[0][2] == '/' || Argv[0][2] != '\\'))
+ ) /* will swawnvp use PATH? */
TAINT_ENV(); /* testing IFS here is overkill, probably */
+ /* We should check PERL_SH* and PERLLIB_* as well? */
+ retry:
if (really && *(tmps = SvPV(really, na)))
rc = result(trueflag, spawnvp(flag,tmps,Argv));
else
rc = result(trueflag, spawnvp(flag,Argv[0],Argv));
+ if (rc < 0 && secondtry == 0
+ && (!tmps || !*tmps)) { /* Cannot transfer `really' via shell. */
+ err = errno;
+ if (err == ENOENT) { /* No such file. */
+ /* One reason may be that EMX added .exe. We suppose
+ that .exe-less files are automatically shellable. */
+ char *no_dir;
+ (no_dir = strrchr(Argv[0], '/'))
+ || (no_dir = strrchr(Argv[0], '\\'))
+ || (no_dir = Argv[0]);
+ if (!strchr(no_dir, '.')) {
+ struct stat buffer;
+ if (stat(Argv[0], &buffer) != -1) { /* File exists. */
+ /* Maybe we need to specify the full name here? */
+ goto doshell;
+ }
+ }
+ } else if (err == ENOEXEC) { /* Need to send to shell. */
+ doshell:
+ while (a >= Argv) {
+ *(a + 2) = *a;
+ a--;
+ }
+ *Argv = sh_path;
+ *(Argv + 1) = "-c";
+ secondtry = 1;
+ goto retry;
+ }
+ }
if (rc < 0 && dowarn)
warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
@@ -111,15 +280,22 @@ register SV **sp;
return rc;
}
+#define EXECF_SPAWN 0
+#define EXECF_EXEC 1
+#define EXECF_TRUEEXEC 2
+#define EXECF_SPAWN_NOWAIT 3
+
int
-do_spawn(cmd)
+do_spawn2(cmd, execf)
char *cmd;
+int execf;
{
register char **a;
register char *s;
char flags[10];
- char *shell, *copt;
- int rc;
+ char *shell, *copt, *news = NULL;
+ int rc, added_shell = 0, err, seenspace = 0;
+ char fullcmd[MAXNAMLEN + 1];
#ifdef TRYSHELL
if ((shell = getenv("EMXSHELL")) != NULL)
@@ -135,13 +311,23 @@ char *cmd;
have a shell which will not change between computers with the
same architecture, to avoid "action on a distance".
And to have simple build, this shell should be sh. */
- shell = "sh.exe";
+ shell = sh_path;
copt = "-c";
#endif
while (*cmd && isSPACE(*cmd))
cmd++;
+ if (strnEQ(cmd,"/bin/sh",7) && isSPACE(cmd[7])) {
+ STRLEN l = strlen(sh_path);
+
+ New(1302, news, strlen(cmd) - 7 + l + 1, char);
+ strcpy(news, sh_path);
+ strcpy(news + l, cmd + 7);
+ cmd = news;
+ added_shell = 1;
+ }
+
/* save an extra exec if possible */
/* see if there are shell metacharacters in it */
@@ -157,21 +343,35 @@ char *cmd;
for (s = cmd; *s; s++) {
if (*s != ' ' && !isALPHA(*s) && strchr("$&*(){}[]'\";\\|?<>~`\n",*s)) {
- if (*s == '\n' && !s[1]) {
+ if (*s == '\n' && s[1] == '\0') {
*s = '\0';
break;
+ } else if (*s == '\\' && !seenspace) {
+ continue; /* Allow backslashes in names */
}
doshell:
+ if (execf == EXECF_TRUEEXEC)
+ return execl(shell,shell,copt,cmd,(char*)0);
+ else if (execf == EXECF_EXEC)
+ return spawnl(P_OVERLAY,shell,shell,copt,cmd,(char*)0);
+ else if (execf == EXECF_SPAWN_NOWAIT)
+ return spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0);
+ /* In the ak code internal P_NOWAIT is P_WAIT ??? */
rc = result(P_WAIT,
- spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
+ spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0));
if (rc < 0 && dowarn)
- warn("Can't spawn \"%s\": %s", shell, Strerror(errno));
+ warn("Can't %s \"%s\": %s",
+ (execf == EXECF_SPAWN ? "spawn" : "exec"),
+ shell, Strerror(errno));
if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
+ if (news) Safefree(news);
return rc;
+ } else if (*s == ' ' || *s == '\t') {
+ seenspace = 1;
}
}
- New(402,Argv, (s - cmd) / 2 + 2, char*);
+ New(1303,Argv, (s - cmd) / 2 + 2, char*);
Cmd = savepvn(cmd, s-cmd);
a = Argv;
for (s = Cmd; *s;) {
@@ -184,31 +384,153 @@ char *cmd;
}
*a = Nullch;
if (Argv[0]) {
- rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
+ int err;
+
+ if (execf == EXECF_TRUEEXEC)
+ rc = execvp(Argv[0],Argv);
+ else if (execf == EXECF_EXEC)
+ rc = spawnvp(P_OVERLAY,Argv[0],Argv);
+ else if (execf == EXECF_SPAWN_NOWAIT)
+ rc = spawnvp(P_NOWAIT,Argv[0],Argv);
+ else
+ rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
+ if (rc < 0) {
+ err = errno;
+ if (err == ENOENT) { /* No such file. */
+ /* One reason may be that EMX added .exe. We suppose
+ that .exe-less files are automatically shellable. */
+ char *no_dir;
+ (no_dir = strrchr(Argv[0], '/'))
+ || (no_dir = strrchr(Argv[0], '\\'))
+ || (no_dir = Argv[0]);
+ if (!strchr(no_dir, '.')) {
+ struct stat buffer;
+ if (stat(Argv[0], &buffer) != -1) { /* File exists. */
+ /* Maybe we need to specify the full name here? */
+ goto doshell;
+ }
+ }
+ } else if (err == ENOEXEC) { /* Need to send to shell. */
+ goto doshell;
+ }
+ }
if (rc < 0 && dowarn)
- warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
+ warn("Can't %s \"%s\": %s",
+ ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC)
+ ? "spawn" : "exec"),
+ Argv[0], Strerror(err));
if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
} else
rc = -1;
+ if (news) Safefree(news);
do_execfree();
return rc;
}
-FILE *
-my_popen(cmd,mode)
+int
+do_spawn(cmd)
+char *cmd;
+{
+ return do_spawn2(cmd, EXECF_SPAWN);
+}
+
+int
+do_spawn_nowait(cmd)
+char *cmd;
+{
+ return do_spawn2(cmd, EXECF_SPAWN_NOWAIT);
+}
+
+bool
+do_exec(cmd)
+char *cmd;
+{
+ return do_spawn2(cmd, EXECF_EXEC);
+}
+
+bool
+os2exec(cmd)
+char *cmd;
+{
+ return do_spawn2(cmd, EXECF_TRUEEXEC);
+}
+
+PerlIO *
+my_syspopen(cmd,mode)
char *cmd;
char *mode;
{
- char *shell = getenv("EMXSHELL");
- FILE *res;
+#ifndef USE_POPEN
+
+ int p[2];
+ register I32 this, that, newfd;
+ register I32 pid, rc;
+ PerlIO *res;
+ SV *sv;
- my_setenv("EMXSHELL", "sh.exe");
+ if (pipe(p) < 0)
+ return Nullfp;
+ /* `this' is what we use in the parent, `that' in the child. */
+ this = (*mode == 'w');
+ that = !this;
+ if (tainting) {
+ taint_env();
+ taint_proper("Insecure %s%s", "EXEC");
+ }
+ /* Now we need to spawn the child. */
+ newfd = dup(*mode == 'r'); /* Preserve std* */
+ if (p[that] != (*mode == 'r')) {
+ dup2(p[that], *mode == 'r');
+ close(p[that]);
+ }
+ /* Where is `this' and newfd now? */
+ fcntl(p[this], F_SETFD, FD_CLOEXEC);
+ fcntl(newfd, F_SETFD, FD_CLOEXEC);
+ pid = do_spawn_nowait(cmd);
+ if (newfd != (*mode == 'r')) {
+ dup2(newfd, *mode == 'r'); /* Return std* back. */
+ close(newfd);
+ }
+ close(p[that]);
+ if (pid == -1) {
+ close(p[this]);
+ return NULL;
+ }
+ if (p[that] < p[this]) {
+ dup2(p[this], p[that]);
+ close(p[this]);
+ p[this] = p[that];
+ }
+ sv = *av_fetch(fdpid,p[this],TRUE);
+ (void)SvUPGRADE(sv,SVt_IV);
+ SvIVX(sv) = pid;
+ forkprocess = pid;
+ return PerlIO_fdopen(p[this], mode);
+
+#else /* USE_POPEN */
+
+ PerlIO *res;
+ SV *sv;
+
+# ifdef TRYSHELL
+ res = popen(cmd, mode);
+# else
+ char *shell = getenv("EMXSHELL");
+
+ my_setenv("EMXSHELL", sh_path);
res = popen(cmd, mode);
my_setenv("EMXSHELL", shell);
+# endif
+ sv = *av_fetch(fdpid, PerlIO_fileno(res), TRUE);
+ (void)SvUPGRADE(sv,SVt_IV);
+ SvIVX(sv) = -1; /* A cooky. */
return res;
+
+#endif /* USE_POPEN */
+
}
-/*****************************************************************************/
+/******************************************************************/
#ifndef HAS_FORK
int
@@ -220,7 +542,7 @@ fork(void)
}
#endif
-/*****************************************************************************/
+/*******************************************************************/
/* not implemented in EMX 0.9a */
void * ctermid(x) { return 0; }
@@ -229,18 +551,58 @@ void * ctermid(x) { return 0; }
void * ttyname(x) { return 0; }
#endif
-void * gethostent() { return 0; }
-void * getnetent() { return 0; }
-void * getprotoent() { return 0; }
-void * getservent() { return 0; }
-void sethostent(x) {}
-void setnetent(x) {}
-void setprotoent(x) {}
-void setservent(x) {}
-void endhostent(x) {}
-void endnetent(x) {}
-void endprotoent(x) {}
-void endservent(x) {}
+/******************************************************************/
+/* my socket forwarders - EMX lib only provides static forwarders */
+
+static HMODULE htcp = 0;
+
+static void *
+tcp0(char *name)
+{
+ static BYTE buf[20];
+ PFN fcn;
+
+ if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
+ if (!htcp)
+ DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
+ if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
+ return (void *) ((void * (*)(void)) fcn) ();
+ return 0;
+}
+
+static void
+tcp1(char *name, int arg)
+{
+ static BYTE buf[20];
+ PFN fcn;
+
+ if (!(_emx_env & 0x200)) croak("%s requires OS/2", name); /* Die if not OS/2. */
+ if (!htcp)
+ DosLoadModule(buf, sizeof buf, "tcp32dll", &htcp);
+ if (htcp && DosQueryProcAddr(htcp, 0, name, &fcn) == 0)
+ ((void (*)(int)) fcn) (arg);
+}
+
+void * gethostent() { return tcp0("GETHOSTENT"); }
+void * getnetent() { return tcp0("GETNETENT"); }
+void * getprotoent() { return tcp0("GETPROTOENT"); }
+void * getservent() { return tcp0("GETSERVENT"); }
+void sethostent(x) { tcp1("SETHOSTENT", x); }
+void setnetent(x) { tcp1("SETNETENT", x); }
+void setprotoent(x) { tcp1("SETPROTOENT", x); }
+void setservent(x) { tcp1("SETSERVENT", x); }
+void endhostent() { tcp0("ENDHOSTENT"); }
+void endnetent() { tcp0("ENDNETENT"); }
+void endprotoent() { tcp0("ENDPROTOENT"); }
+void endservent() { tcp0("ENDSERVENT"); }
+
+/*****************************************************************************/
+/* not implemented in C Set++ */
+
+#ifndef __EMX__
+int setuid(x) { errno = EINVAL; return -1; }
+int setgid(x) { errno = EINVAL; return -1; }
+#endif
/*****************************************************************************/
/* stat() hack for char/block device */
@@ -268,55 +630,22 @@ os2_stat(char *name, struct stat *st)
#endif
-#ifndef NO_SYS_ALLOC
-
-static char *oldchunk;
-static long oldsize;
-
-#define _32_K (1<<15)
-#define _64_K (1<<16)
+#ifdef USE_PERL_SBRK
-/* The real problem is that DosAllocMem will grant memory on 64K-chunks
- * boundaries only. Note that addressable space for application memory
- * is around 240M, thus we will run out of addressable space if we
- * allocate around 14M worth of 4K segments.
- * Thus we allocate memory in 64K chunks, and abandon the rest of the old
- * chunk if the new is bigger than that rest. Also, we just allocate
- * whatever is requested if the size is bigger that 32K. With this strategy
- * we cannot lose more than 1/2 of addressable space. */
+/* SBRK() emulation, mostly moved to malloc.c. */
void *
-sbrk(int size)
-{
- char *got;
- APIRET rc;
- int small, reqsize;
-
- if (!size) return 0;
- else if (size <= oldsize) {
- got = oldchunk;
- oldchunk += size;
- oldsize -= size;
- return (void *)got;
- } else if (size >= _32_K) {
- small = 0;
- } else {
- reqsize = size;
- size = _64_K;
- small = 1;
- }
- rc = DosAllocMem((void **)&got, size, PAG_COMMIT | PAG_WRITE);
+sys_alloc(int size) {
+ void *got;
+ APIRET rc = DosAllocMem(&got, size, PAG_COMMIT | PAG_WRITE);
+
if (rc == ERROR_NOT_ENOUGH_MEMORY) {
return (void *) -1;
} else if ( rc ) die("Got an error from DosAllocMem: %li", (long)rc);
- if (small) {
- /* Chunk is small, register the rest for future allocs. */
- oldchunk = got + reqsize;
- oldsize = size - reqsize;
- }
- return (void *)got;
+ return got;
}
-#endif /* ! defined NO_SYS_ALLOC */
+
+#endif /* USE_PERL_SBRK */
/* tmp path */
@@ -357,28 +686,630 @@ XS(XS_File__Copy_syscopy)
flag = (unsigned long)SvIV(ST(2));
}
- errno = DosCopy(src, dst, flag);
- RETVAL = !errno;
+ RETVAL = !CheckOSError(DosCopy(src, dst, flag));
ST(0) = sv_newmortal();
sv_setiv(ST(0), (IV)RETVAL);
}
XSRETURN(1);
}
-OS2_Perl_data_t OS2_Perl_data;
+char *
+mod2fname(sv)
+ SV *sv;
+{
+ static char fname[9];
+ int pos = 6, len, avlen;
+ unsigned int sum = 0;
+ AV *av;
+ SV *svp;
+ char *s;
+
+ if (!SvROK(sv)) croak("Not a reference given to mod2fname");
+ sv = SvRV(sv);
+ if (SvTYPE(sv) != SVt_PVAV)
+ croak("Not array reference given to mod2fname");
+
+ avlen = av_len((AV*)sv);
+ if (avlen < 0)
+ croak("Empty array reference given to mod2fname");
+
+ s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
+ strncpy(fname, s, 8);
+ len = strlen(s);
+ if (len < 6) pos = len;
+ while (*s) {
+ sum = 33 * sum + *(s++); /* Checksumming first chars to
+ * get the capitalization into c.s. */
+ }
+ avlen --;
+ while (avlen >= 0) {
+ s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
+ while (*s) {
+ sum = 33 * sum + *(s++); /* 7 is primitive mod 13. */
+ }
+ avlen --;
+ }
+ fname[pos] = 'A' + (sum % 26);
+ fname[pos + 1] = 'A' + (sum / 26 % 26);
+ fname[pos + 2] = '\0';
+ return (char *)fname;
+}
+
+XS(XS_DynaLoader_mod2fname)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: DynaLoader::mod2fname(sv)");
+ {
+ SV * sv = ST(0);
+ char * RETVAL;
+
+ RETVAL = mod2fname(sv);
+ ST(0) = sv_newmortal();
+ sv_setpv((SV*)ST(0), RETVAL);
+ }
+ XSRETURN(1);
+}
+
+char *
+os2error(int rc)
+{
+ static char buf[300];
+ ULONG len;
+
+ if (!(_emx_env & 0x200)) return ""; /* Nop if not OS/2. */
+ if (rc == 0)
+ return NULL;
+ if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
+ sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
+ else
+ buf[len] = '\0';
+ return buf;
+}
+
+char *
+perllib_mangle(char *s, unsigned int l)
+{
+ static char *newp, *oldp;
+ static int newl, oldl, notfound;
+ static char ret[STATIC_FILE_LENGTH+1];
+
+ if (!newp && !notfound) {
+ newp = getenv("PERLLIB_PREFIX");
+ if (newp) {
+ char *s;
+
+ oldp = newp;
+ while (*newp && !isSPACE(*newp) && *newp != ';') {
+ newp++; oldl++; /* Skip digits. */
+ }
+ while (*newp && (isSPACE(*newp) || *newp == ';')) {
+ newp++; /* Skip whitespace. */
+ }
+ newl = strlen(newp);
+ if (newl == 0 || oldl == 0) {
+ die("Malformed PERLLIB_PREFIX");
+ }
+ strcpy(ret, newp);
+ s = ret;
+ while (*s) {
+ if (*s == '\\') *s = '/';
+ s++;
+ }
+ } else {
+ notfound = 1;
+ }
+ }
+ if (!newp) {
+ return s;
+ }
+ if (l == 0) {
+ l = strlen(s);
+ }
+ if (l < oldl || strnicmp(oldp, s, oldl) != 0) {
+ return s;
+ }
+ if (l + newl - oldl > STATIC_FILE_LENGTH || newl > STATIC_FILE_LENGTH) {
+ die("Malformed PERLLIB_PREFIX");
+ }
+ strcpy(ret + newl, s + oldl);
+ return ret;
+}
+
+extern void dlopen();
+void *fakedl = &dlopen; /* Pull in dynaloading part. */
+
+#define sys_is_absolute(path) ( isALPHA((path)[0]) && (path)[1] == ':' \
+ && ((path)[2] == '/' || (path)[2] == '\\'))
+#define sys_is_rooted _fnisabs
+#define sys_is_relative _fnisrel
+#define current_drive _getdrive
+
+#undef chdir /* Was _chdir2. */
+#define sys_chdir(p) (chdir(p) == 0)
+#define change_drive(d) (_chdrive(d), (current_drive() == toupper(d)))
+
+XS(XS_Cwd_current_drive)
+{
+ dXSARGS;
+ if (items != 0)
+ croak("Usage: Cwd::current_drive()");
+ {
+ char RETVAL;
+
+ RETVAL = current_drive();
+ ST(0) = sv_newmortal();
+ sv_setpvn(ST(0), (char *)&RETVAL, 1);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_chdir)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: Cwd::sys_chdir(path)");
+ {
+ char * path = (char *)SvPV(ST(0),na);
+ bool RETVAL;
+
+ RETVAL = sys_chdir(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_change_drive)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: Cwd::change_drive(d)");
+ {
+ char d = (char)*SvPV(ST(0),na);
+ bool RETVAL;
+
+ RETVAL = change_drive(d);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_is_absolute)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: Cwd::sys_is_absolute(path)");
+ {
+ char * path = (char *)SvPV(ST(0),na);
+ bool RETVAL;
+
+ RETVAL = sys_is_absolute(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_is_rooted)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: Cwd::sys_is_rooted(path)");
+ {
+ char * path = (char *)SvPV(ST(0),na);
+ bool RETVAL;
+
+ RETVAL = sys_is_rooted(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_is_relative)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: Cwd::sys_is_relative(path)");
+ {
+ char * path = (char *)SvPV(ST(0),na);
+ bool RETVAL;
+
+ RETVAL = sys_is_relative(path);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_cwd)
+{
+ dXSARGS;
+ if (items != 0)
+ croak("Usage: Cwd::sys_cwd()");
+ {
+ char p[MAXPATHLEN];
+ char * RETVAL;
+ RETVAL = _getcwd2(p, MAXPATHLEN);
+ ST(0) = sv_newmortal();
+ sv_setpv((SV*)ST(0), RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_sys_abspath)
+{
+ dXSARGS;
+ if (items < 1 || items > 2)
+ croak("Usage: Cwd::sys_abspath(path, dir = NULL)");
+ {
+ char * path = (char *)SvPV(ST(0),na);
+ char * dir;
+ char p[MAXPATHLEN];
+ char * RETVAL;
+
+ if (items < 2)
+ dir = NULL;
+ else {
+ dir = (char *)SvPV(ST(1),na);
+ }
+ if (path[0] == '.' && (path[1] == '/' || path[1] == '\\')) {
+ path += 2;
+ }
+ if (dir == NULL) {
+ if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else {
+ /* Absolute with drive: */
+ if ( sys_is_absolute(path) ) {
+ if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else if (path[0] == '/' || path[0] == '\\') {
+ /* Rooted, but maybe on different drive. */
+ if (isALPHA(dir[0]) && dir[1] == ':' ) {
+ char p1[MAXPATHLEN];
+
+ /* Need to prepend the drive. */
+ p1[0] = dir[0];
+ p1[1] = dir[1];
+ Copy(path, p1 + 2, strlen(path) + 1, char);
+ RETVAL = p;
+ if (_abspath(p, p1, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else {
+ /* Either path is relative, or starts with a drive letter. */
+ /* If the path starts with a drive letter, then dir is
+ relevant only if
+ a/b) it is absolute/x:relative on the same drive.
+ c) path is on current drive, and dir is rooted
+ In all the cases it is safe to drop the drive part
+ of the path. */
+ if ( !sys_is_relative(path) ) {
+ int is_drived;
+
+ if ( ( ( sys_is_absolute(dir)
+ || (isALPHA(dir[0]) && dir[1] == ':'
+ && strnicmp(dir, path,1) == 0))
+ && strnicmp(dir, path,1) == 0)
+ || ( !(isALPHA(dir[0]) && dir[1] == ':')
+ && toupper(path[0]) == current_drive())) {
+ path += 2;
+ } else if (_abspath(p, path, MAXPATHLEN) == 0) {
+ RETVAL = p; goto done;
+ } else {
+ RETVAL = NULL; goto done;
+ }
+ }
+ {
+ /* Need to prepend the absolute path of dir. */
+ char p1[MAXPATHLEN];
+
+ if (_abspath(p1, dir, MAXPATHLEN) == 0) {
+ int l = strlen(p1);
+
+ if (p1[ l - 1 ] != '/') {
+ p1[ l ] = '/';
+ l++;
+ }
+ Copy(path, p1 + l, strlen(path) + 1, char);
+ if (_abspath(p, p1, MAXPATHLEN) == 0) {
+ RETVAL = p;
+ } else {
+ RETVAL = NULL;
+ }
+ } else {
+ RETVAL = NULL;
+ }
+ }
+ done:
+ }
+ }
+ ST(0) = sv_newmortal();
+ sv_setpv((SV*)ST(0), RETVAL);
+ }
+ XSRETURN(1);
+}
+typedef APIRET (*PELP)(PSZ path, ULONG type);
+
+APIRET
+ExtLIBPATH(ULONG ord, PSZ path, ULONG type)
+{
+ loadByOrd(ord); /* Guarantied to load or die! */
+ return (*(PELP)ExtFCN[ord])(path, type);
+}
+
+#define extLibpath(type) \
+ (CheckOSError(ExtLIBPATH(ORD_QUERY_ELP, to, ((type) ? END_LIBPATH \
+ : BEGIN_LIBPATH))) \
+ ? NULL : to )
+
+#define extLibpath_set(p,type) \
+ (!CheckOSError(ExtLIBPATH(ORD_SET_ELP, (p), ((type) ? END_LIBPATH \
+ : BEGIN_LIBPATH))))
+
+XS(XS_Cwd_extLibpath)
+{
+ dXSARGS;
+ if (items < 0 || items > 1)
+ croak("Usage: Cwd::extLibpath(type = 0)");
+ {
+ bool type;
+ char to[1024];
+ U32 rc;
+ char * RETVAL;
+
+ if (items < 1)
+ type = 0;
+ else {
+ type = (int)SvIV(ST(0));
+ }
+
+ RETVAL = extLibpath(type);
+ ST(0) = sv_newmortal();
+ sv_setpv((SV*)ST(0), RETVAL);
+ }
+ XSRETURN(1);
+}
+
+XS(XS_Cwd_extLibpath_set)
+{
+ dXSARGS;
+ if (items < 1 || items > 2)
+ croak("Usage: Cwd::extLibpath_set(s, type = 0)");
+ {
+ char * s = (char *)SvPV(ST(0),na);
+ bool type;
+ U32 rc;
+ bool RETVAL;
+
+ if (items < 2)
+ type = 0;
+ else {
+ type = (int)SvIV(ST(1));
+ }
+
+ RETVAL = extLibpath_set(s, type);
+ ST(0) = boolSV(RETVAL);
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
int
Xs_OS2_init()
{
char *file = __FILE__;
{
- newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
+ GV *gv;
+
+ if (_emx_env & 0x200) { /* OS/2 */
+ newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
+ newXS("Cwd::extLibpath", XS_Cwd_extLibpath, file);
+ newXS("Cwd::extLibpath_set", XS_Cwd_extLibpath_set, file);
+ }
+ newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
+ newXS("Cwd::current_drive", XS_Cwd_current_drive, file);
+ newXS("Cwd::sys_chdir", XS_Cwd_sys_chdir, file);
+ newXS("Cwd::change_drive", XS_Cwd_change_drive, file);
+ newXS("Cwd::sys_is_absolute", XS_Cwd_sys_is_absolute, file);
+ newXS("Cwd::sys_is_rooted", XS_Cwd_sys_is_rooted, file);
+ newXS("Cwd::sys_is_relative", XS_Cwd_sys_is_relative, file);
+ newXS("Cwd::sys_cwd", XS_Cwd_sys_cwd, file);
+ newXS("Cwd::sys_abspath", XS_Cwd_sys_abspath, file);
+ gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+#ifdef PERL_IS_AOUT
+ sv_setiv(GvSV(gv), 1);
+#endif
}
}
+OS2_Perl_data_t OS2_Perl_data;
+
void
-Perl_OS2_init()
+Perl_OS2_init(char **env)
{
+ char *shell;
+
settmppath();
OS2_Perl_data.xs_init = &Xs_OS2_init;
+ if (environ == NULL) {
+ environ = env;
+ }
+ if ( (shell = getenv("PERL_SH_DRIVE")) ) {
+ New(1304, sh_path, strlen(SH_PATH) + 1, char);
+ strcpy(sh_path, SH_PATH);
+ sh_path[0] = shell[0];
+ } else if ( (shell = getenv("PERL_SH_DIR")) ) {
+ int l = strlen(shell), i;
+ if (shell[l-1] == '/' || shell[l-1] == '\\') {
+ l--;
+ }
+ New(1304, sh_path, l + 8, char);
+ strncpy(sh_path, shell, l);
+ strcpy(sh_path + l, "/sh.exe");
+ for (i = 0; i < l; i++) {
+ if (sh_path[i] == '\\') sh_path[i] = '/';
+ }
+ }
+}
+
+#undef tmpnam
+#undef tmpfile
+
+char *
+my_tmpnam (char *str)
+{
+ char *p = getenv("TMP"), *tpath;
+ int len;
+
+ if (!p) p = getenv("TEMP");
+ tpath = tempnam(p, "pltmp");
+ if (str && tpath) {
+ strcpy(str, tpath);
+ return str;
+ }
+ return tpath;
+}
+
+FILE *
+my_tmpfile ()
+{
+ struct stat s;
+
+ stat(".", &s);
+ if (s.st_mode & S_IWOTH) {
+ return tmpfile();
+ }
+ return fopen(my_tmpnam(NULL), "w+b"); /* Race condition, but
+ grants TMP. */
+}
+
+#undef flock
+
+/* This code was contributed by Rocco Caputo. */
+int
+my_flock(int handle, int op)
+{
+ FILELOCK rNull, rFull;
+ ULONG timeout, handle_type, flag_word;
+ APIRET rc;
+ int blocking, shared;
+ static int use_my = -1;
+
+ if (use_my == -1) {
+ char *s = getenv("USE_PERL_FLOCK");
+ if (s)
+ use_my = atoi(s);
+ else
+ use_my = 1;
+ }
+ if (!(_emx_env & 0x200) || !use_my)
+ return flock(handle, op); /* Delegate to EMX. */
+
+ // is this a file?
+ if ((DosQueryHType(handle, &handle_type, &flag_word) != 0) ||
+ (handle_type & 0xFF))
+ {
+ errno = EBADF;
+ return -1;
+ }
+ // set lock/unlock ranges
+ rNull.lOffset = rNull.lRange = rFull.lOffset = 0;
+ rFull.lRange = 0x7FFFFFFF;
+ // set timeout for blocking
+ timeout = ((blocking = !(op & LOCK_NB))) ? 100 : 1;
+ // shared or exclusive?
+ shared = (op & LOCK_SH) ? 1 : 0;
+ // do not block the unlock
+ if (op & (LOCK_UN | LOCK_SH | LOCK_EX)) {
+ rc = DosSetFileLocks(handle, &rFull, &rNull, timeout, shared);
+ switch (rc) {
+ case 0:
+ errno = 0;
+ return 0;
+ case ERROR_INVALID_HANDLE:
+ errno = EBADF;
+ return -1;
+ case ERROR_SHARING_BUFFER_EXCEEDED:
+ errno = ENOLCK;
+ return -1;
+ case ERROR_LOCK_VIOLATION:
+ break; // not an error
+ case ERROR_INVALID_PARAMETER:
+ case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
+ case ERROR_READ_LOCKS_NOT_SUPPORTED:
+ errno = EINVAL;
+ return -1;
+ case ERROR_INTERRUPT:
+ errno = EINTR;
+ return -1;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+ }
+ // lock may block
+ if (op & (LOCK_SH | LOCK_EX)) {
+ // for blocking operations
+ for (;;) {
+ rc =
+ DosSetFileLocks(
+ handle,
+ &rNull,
+ &rFull,
+ timeout,
+ shared
+ );
+ switch (rc) {
+ case 0:
+ errno = 0;
+ return 0;
+ case ERROR_INVALID_HANDLE:
+ errno = EBADF;
+ return -1;
+ case ERROR_SHARING_BUFFER_EXCEEDED:
+ errno = ENOLCK;
+ return -1;
+ case ERROR_LOCK_VIOLATION:
+ if (!blocking) {
+ errno = EWOULDBLOCK;
+ return -1;
+ }
+ break;
+ case ERROR_INVALID_PARAMETER:
+ case ERROR_ATOMIC_LOCK_NOT_SUPPORTED:
+ case ERROR_READ_LOCKS_NOT_SUPPORTED:
+ errno = EINVAL;
+ return -1;
+ case ERROR_INTERRUPT:
+ errno = EINTR;
+ return -1;
+ default:
+ errno = EINVAL;
+ return -1;
+ }
+ // give away timeslice
+ DosSleep(1);
+ }
+ }
+
+ errno = 0;
+ return 0;
}
diff --git a/gnu/usr.bin/perl/os2/os2ish.h b/gnu/usr.bin/perl/os2/os2ish.h
index 41caa422b14..b62e3d04d4b 100644
--- a/gnu/usr.bin/perl/os2/os2ish.h
+++ b/gnu/usr.bin/perl/os2/os2ish.h
@@ -14,6 +14,41 @@
#define HAS_KILL
#define HAS_WAIT
+#define HAS_DLERROR
+#define HAS_WAITPID_RUNTIME (_emx_env & 0x200)
+
+/* 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
+
+/* 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 "extproc "
#ifndef SIGABRT
# define SIGABRT SIGILL
@@ -23,22 +58,64 @@
#endif
#define ABORT() kill(getpid(),SIGABRT);
-#define BIT_BUCKET "/dev/null" /* Will this work? */
+#define BIT_BUCKET "/dev/nul" /* Will this work? */
-void Perl_OS2_init();
+#if defined(I_SYS_UN) && !defined(TCPIPV4)
+/* It is not working without TCPIPV4 defined. */
+# undef I_SYS_UN
+#endif
+
+void Perl_OS2_init(char **);
+
+/* XXX This code hideously puts env inside: */
#define PERL_SYS_INIT(argcp, argvp) STMT_START { \
_response(argcp, argvp); \
_wildcard(argcp, argvp); \
- Perl_OS2_init(); } STMT_END
+ Perl_OS2_init(env); } STMT_END
#define PERL_SYS_TERM()
-#define dXSUB_SYS int fake = OS2_XS_init()
+/* #define PERL_SYS_TERM() STMT_START { \
+ if (Perl_HAB_set) WinTerminate(Perl_hab); } STMT_END */
+
+#define dXSUB_SYS OS2_XS_init()
+
+#ifdef PERL_IS_AOUT
+/* # define HAS_FORK */
+/* # define HIDEMYMALLOC */
+/* # define PERL_SBRK_VIA_MALLOC */ /* gets off-page sbrk... */
+#else /* !PERL_IS_AOUT */
+# ifndef PERL_FOR_X2P
+# ifdef EMX_BAD_SBRK
+# define USE_PERL_SBRK
+# endif
+# else
+# define PerlIO FILE
+# endif
+# define SYSTEM_ALLOC(a) sys_alloc(a)
+
+void *sys_alloc(int size);
+
+#endif /* !PERL_IS_AOUT */
+#if !defined(PERL_CORE) && !defined(PerlIO) /* a2p */
+# define PerlIO FILE
+#endif
#define TMPPATH tmppath
#define TMPPATH1 "plXXXXXX"
extern char *tmppath;
+PerlIO *my_syspopen(char *cmd, char *mode);
+/* Cannot prototype with I32 at this point. */
+int my_syspclose(PerlIO *f);
+FILE *my_tmpfile (void);
+char *my_tmpnam (char *);
+
+#define tmpfile my_tmpfile
+#define tmpnam my_tmpnam
+#define isatty _isterm
+#define rand random
+#define srand srandom
/*
* fwrite1() should be a routine with the same calling sequence as fwrite(),
@@ -49,6 +126,12 @@ extern char *tmppath;
#define fwrite1 fwrite
#define my_getenv(var) getenv(var)
+#define flock my_flock
+
+void *emx_calloc (size_t, size_t);
+void emx_free (void *);
+void *emx_malloc (size_t);
+void *emx_realloc (void *, size_t);
/*****************************************************************************/
@@ -61,7 +144,6 @@ extern char *tmppath;
/* This guy is needed for quick stdstd */
#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
-# define _filbuf _fill
/* Perl uses ungetc only with successful return */
# define ungetc(c,fp) \
(FILE_ptr(fp) > FILE_base(fp) && c == (int)*(FILE_ptr(fp) - 1) \
@@ -76,6 +158,7 @@ extern char *tmppath;
#define Stat(fname,bufptr) os2_stat((fname),(bufptr))
#define Fstat(fd,bufptr) fstat((fd),(bufptr))
#define Fflush(fp) fflush(fp)
+#define Mkdir(path,mode) mkdir((path),(mode))
#undef S_IFBLK
#undef S_ISBLK
@@ -87,23 +170,231 @@ extern char *tmppath;
#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))
#endif
+/* With SD386 it is impossible to debug register variables. */
+#if !defined(PERL_IS_AOUT) && defined(DEBUGGING) && !defined(register)
+# define register
+#endif
+
/* Our private OS/2 specific data. */
typedef struct OS2_Perl_data {
unsigned long flags;
unsigned long phab;
int (*xs_init)();
+ unsigned long rc;
+ unsigned long severity;
} OS2_Perl_data_t;
extern OS2_Perl_data_t OS2_Perl_data;
-#define hab ((HAB)OS2_Perl_data->phab)
-#define OS2_Perl_flag (OS2_Perl_data->flag)
+#define Perl_hab ((HAB)OS2_Perl_data.phab)
+#define Perl_rc (OS2_Perl_data.rc)
+#define Perl_severity (OS2_Perl_data.severity)
+#define errno_isOS2 12345678
+#define OS2_Perl_flags (OS2_Perl_data.flags)
#define Perl_HAB_set_f 1
-#define Perl_HAB_set (OS2_Perl_flag & Perl_HAB_set_f)
-#define set_Perl_HAB_f (OS2_Perl_flag |= Perl_HAB_set_f)
-#define set_Perl_HAB(h) (set_Perl_HAB_f, hab = h)
+#define Perl_HAB_set (OS2_Perl_flags & Perl_HAB_set_f)
+#define set_Perl_HAB_f (OS2_Perl_flags |= Perl_HAB_set_f)
+#define set_Perl_HAB(h) (set_Perl_HAB_f, Perl_hab = h)
#define OS2_XS_init() (*OS2_Perl_data.xs_init)()
+/* The expressions below return true on error. */
+/* INCL_DOSERRORS needed. rc should be declared outside. */
+#define CheckOSError(expr) (!(rc = (expr)) ? 0 : (FillOSError(rc), 1))
+/* INCL_WINERRORS needed. */
+#define SaveWinError(expr) ((expr) ? : (FillWinError, 0))
+#define CheckWinError(expr) ((expr) ? 0: (FillWinError, 1))
+#define FillOSError(rc) (Perl_rc = rc, \
+ errno = errno_isOS2, \
+ Perl_severity = SEVERITY_ERROR)
+#define FillWinError (Perl_rc = WinGetLastError(Perl_hab), \
+ errno = errno_isOS2, \
+ Perl_severity = ERRORIDSEV(Perl_rc), \
+ Perl_rc = ERRORIDERROR(Perl_rc))
+#define Acquire_hab() if (!Perl_HAB_set) { \
+ Perl_hab = WinInitialize(0); \
+ if (!Perl_hab) die("WinInitialize failed"); \
+ set_Perl_HAB_f; \
+ }
+
+#define STATIC_FILE_LENGTH 127
+
+#define PERLLIB_MANGLE(s, n) perllib_mangle((s), (n))
+char *perllib_mangle(char *, unsigned int);
+
+char *os2error(int rc);
+
+/* ************************************************************ */
+#define Dos32QuerySysState DosQuerySysState
+#define QuerySysState(flags, pid, buf, bufsz) \
+ Dos32QuerySysState(flags, 0, pid, 0, buf, bufsz)
+
+#define QSS_PROCESS 1
+#define QSS_MODULE 4
+#define QSS_SEMAPHORES 2
+#define QSS_FILE 8 /* Buggy until fixpack18 */
+#define QSS_SHARED 16
+
+#ifdef _OS2EMX_H
+
+APIRET APIENTRY Dos32QuerySysState(ULONG func,ULONG arg1,ULONG pid,
+ ULONG _res_,PVOID buf,ULONG bufsz);
+typedef struct {
+ ULONG threadcnt;
+ ULONG proccnt;
+ ULONG modulecnt;
+} QGLOBAL, *PQGLOBAL;
+
+typedef struct {
+ ULONG rectype;
+ USHORT threadid;
+ USHORT slotid;
+ ULONG sleepid;
+ ULONG priority;
+ ULONG systime;
+ ULONG usertime;
+ UCHAR state;
+ UCHAR _reserved1_; /* padding to ULONG */
+ USHORT _reserved2_; /* padding to ULONG */
+} QTHREAD, *PQTHREAD;
+
+typedef struct {
+ USHORT sfn;
+ USHORT refcnt;
+ USHORT flags1;
+ USHORT flags2;
+ USHORT accmode1;
+ USHORT accmode2;
+ ULONG filesize;
+ USHORT volhnd;
+ USHORT attrib;
+ USHORT _reserved_;
+} QFDS, *PQFDS;
+
+typedef struct qfile {
+ ULONG rectype;
+ struct qfile *next;
+ ULONG opencnt;
+ PQFDS filedata;
+ char name[1];
+} QFILE, *PQFILE;
+
+typedef struct {
+ ULONG rectype;
+ PQTHREAD threads;
+ USHORT pid;
+ USHORT ppid;
+ ULONG type;
+ ULONG state;
+ ULONG sessid;
+ USHORT hndmod;
+ USHORT threadcnt;
+ ULONG privsem32cnt;
+ ULONG _reserved2_;
+ USHORT sem16cnt;
+ USHORT dllcnt;
+ USHORT shrmemcnt;
+ USHORT fdscnt;
+ PUSHORT sem16s;
+ PUSHORT dlls;
+ PUSHORT shrmems;
+ PUSHORT fds;
+} QPROCESS, *PQPROCESS;
+
+typedef struct sema {
+ struct sema *next;
+ USHORT refcnt;
+ UCHAR sysflags;
+ UCHAR sysproccnt;
+ ULONG _reserved1_;
+ USHORT index;
+ CHAR name[1];
+} QSEMA, *PQSEMA;
+
+typedef struct {
+ ULONG rectype;
+ ULONG _reserved1_;
+ USHORT _reserved2_;
+ USHORT syssemidx;
+ ULONG index;
+ QSEMA sema;
+} QSEMSTRUC, *PQSEMSTRUC;
+
+typedef struct {
+ USHORT pid;
+ USHORT opencnt;
+} QSEMOWNER32, *PQSEMOWNER32;
+
+typedef struct {
+ PQSEMOWNER32 own;
+ PCHAR name;
+ PVOID semrecs; /* array of associated sema's */
+ USHORT flags;
+ USHORT semreccnt;
+ USHORT waitcnt;
+ USHORT _reserved_; /* padding to ULONG */
+} QSEMSMUX32, *PQSEMSMUX32;
+
+typedef struct {
+ PQSEMOWNER32 own;
+ PCHAR name;
+ PQSEMSMUX32 mux;
+ USHORT flags;
+ USHORT postcnt;
+} QSEMEV32, *PQSEMEV32;
+
+typedef struct {
+ PQSEMOWNER32 own;
+ PCHAR name;
+ PQSEMSMUX32 mux;
+ USHORT flags;
+ USHORT refcnt;
+ USHORT thrdnum;
+ USHORT _reserved_; /* padding to ULONG */
+} QSEMMUX32, *PQSEMMUX32;
+
+typedef struct semstr32 {
+ struct semstr *next;
+ QSEMEV32 evsem;
+ QSEMMUX32 muxsem;
+ QSEMSMUX32 smuxsem;
+} QSEMSTRUC32, *PQSEMSTRUC32;
+
+typedef struct shrmem {
+ struct shrmem *next;
+ USHORT hndshr;
+ USHORT selshr;
+ USHORT refcnt;
+ CHAR name[1];
+} QSHRMEM, *PQSHRMEM;
+
+typedef struct module {
+ struct module *next;
+ USHORT hndmod;
+ USHORT type;
+ ULONG refcnt;
+ ULONG segcnt;
+ PVOID _reserved_;
+ PCHAR name;
+ USHORT modref[1];
+} QMODULE, *PQMODULE;
+
+typedef struct {
+ PQGLOBAL gbldata;
+ PQPROCESS procdata;
+ PQSEMSTRUC semadata;
+ PQSEMSTRUC32 sem32data;
+ PQSHRMEM shrmemdata;
+ PQMODULE moddata;
+ PVOID _reserved2_;
+ PQFILE filedata;
+} QTOPLEVEL, *PQTOPLEVEL;
+/* ************************************************************ */
+
+PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags);
+
+#endif /* _OS2EMX_H */
+
diff --git a/gnu/usr.bin/perl/os2/perl2cmd.pl b/gnu/usr.bin/perl/os2/perl2cmd.pl
index aa1c353f136..e774f773d03 100644
--- a/gnu/usr.bin/perl/os2/perl2cmd.pl
+++ b/gnu/usr.bin/perl/os2/perl2cmd.pl
@@ -16,13 +16,14 @@ EOU
$idir = $Config{installbin};
$indir =~ s|\\|/|g ;
-foreach $file (<$idir/*.>) {
+foreach $file (<$idir/*>) {
+ next if $file =~ /\.exe/i;
$base = $file;
$base =~ s/\.$//; # just in case...
$base =~ s|.*/||;
$file =~ s|/|\\|g ;
print "Processing $file => $dir\\$base.cmd\n";
- system 'cmd.exe', '/c', "echo extproc perl -Sx > $dir\\$base.cmd";
+ system 'cmd.exe', '/c', "echo extproc perl -S >$dir\\$base.cmd";
system 'cmd.exe', '/c', "type $file >> $dir\\$base.cmd";
}
diff --git a/gnu/usr.bin/perl/patchlevel.h b/gnu/usr.bin/perl/patchlevel.h
index 5d4b324d7e1..2adaed5f721 100644
--- a/gnu/usr.bin/perl/patchlevel.h
+++ b/gnu/usr.bin/perl/patchlevel.h
@@ -1,9 +1,9 @@
-#define PATCHLEVEL 3
-#define SUBVERSION 0
+#define PATCHLEVEL 4
+#define SUBVERSION 4
/*
local_patches -- list of locally applied less-than-subversion patches.
- If you're distributing such a patch, please give it a name and a
+ If you're distributing such a patch, please give it a tag 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,
@@ -17,7 +17,7 @@
--- patchlevel.h <date here>
*** 38,43 ***
--- 38,44 ---
- ,"FOO1235 - some patch"
+ ,"MAINT_TRIAL_1 - 5.00x_0x maintenance release trial 1"
,"BAR3141 - another patch"
,"BAZ2718 - and another patch"
+ ,"MINE001 - my new patch"
@@ -36,10 +36,12 @@
This will prevent patch from choking if someone has previously
applied different patches than you.
*/
+/* The following line and terminating '};' are read by perlbug.PL. Don't alter. */
static char *local_patches[] = {
NULL
,NULL
};
-#define LOCAL_PATCH_COUNT \
+/* Initial space prevents this variable from being inserted in config.sh */
+# define LOCAL_PATCH_COUNT \
(sizeof(local_patches)/sizeof(local_patches[0])-2)
diff --git a/gnu/usr.bin/perl/perl.c b/gnu/usr.bin/perl/perl.c
index a4be9745685..f9cc65302a8 100644
--- a/gnu/usr.bin/perl/perl.c
+++ b/gnu/usr.bin/perl/perl.c
@@ -1,6 +1,6 @@
/* perl.c
*
- * Copyright (c) 1987-1996 Larry Wall
+ * 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.
@@ -15,13 +15,16 @@
#include "perl.h"
#include "patchlevel.h"
-/* Omit -- it causes too much grief on mixed systems.
+/* XXX If this causes problems, set i_unistd=undef in the hint file. */
#ifdef I_UNISTD
#include <unistd.h>
#endif
-*/
-dEXT char rcsid[] = "perl.c\nPatch level: ###\n";
+#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
+char *getenv _((char *)); /* Usually in <stdlib.h> */
+#endif
+
+dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
#ifdef IAMSUID
#ifndef DOSUID
@@ -35,8 +38,33 @@ dEXT char rcsid[] = "perl.c\nPatch level: ###\n";
#endif
#endif
+#define I_REINIT \
+ STMT_START { \
+ chopset = " \n-"; \
+ copline = NOLINE; \
+ curcop = &compiling; \
+ curcopdb = NULL; \
+ cxstack_ix = -1; \
+ cxstack_max = 128; \
+ dbargs = 0; \
+ dlmax = 128; \
+ laststatval = -1; \
+ laststype = OP_STAT; \
+ maxscream = -1; \
+ maxsysfd = MAXSYSFD; \
+ statname = Nullsv; \
+ tmps_floor = -1; \
+ tmps_ix = -1; \
+ op_mask = NULL; \
+ dlmax = 128; \
+ laststatval = -1; \
+ laststype = OP_STAT; \
+ mess_sv = Nullsv; \
+ } STMT_END
+
static void find_beginning _((void));
-static void incpush _((char *));
+static void forbid_setid _((char *));
+static void incpush _((char *, int));
static void init_ids _((void));
static void init_debugger _((void));
static void init_lexer _((void));
@@ -45,6 +73,8 @@ static void init_perllib _((void));
static void init_postdump_symbols _((int, char **, char **));
static void init_predump_symbols _((void));
static void init_stacks _((void));
+static void my_exit_jump _((void)) __attribute__((noreturn));
+static void nuke_stacks _((void));
static void open_script _((char *, bool, SV *));
static void usage _((char *));
static void validate_suid _((char *, char*));
@@ -77,19 +107,23 @@ register PerlInterpreter *sv_interp;
linestr = NEWSV(65,80);
sv_upgrade(linestr,SVt_PVIV);
- SvREADONLY_on(&sv_undef);
+ if (!SvREADONLY(&sv_undef)) {
+ SvREADONLY_on(&sv_undef);
- sv_setpv(&sv_no,No);
- SvNV(&sv_no);
- SvREADONLY_on(&sv_no);
+ sv_setpv(&sv_no,No);
+ SvNV(&sv_no);
+ SvREADONLY_on(&sv_no);
- sv_setpv(&sv_yes,Yes);
- SvNV(&sv_yes);
- SvREADONLY_on(&sv_yes);
+ sv_setpv(&sv_yes,Yes);
+ SvNV(&sv_yes);
+ SvREADONLY_on(&sv_yes);
+ }
nrs = newSVpv("\n", 1);
rs = SvREFCNT_inc(nrs);
+ pidstatus = newHV();
+
#ifdef MSDOS
/*
* There is no way we can refer to them from Perl so close them to save
@@ -102,35 +136,39 @@ register PerlInterpreter *sv_interp;
}
#ifdef MULTIPLICITY
- chopset = " \n-";
- copline = NOLINE;
- curcop = &compiling;
- dbargs = 0;
- dlmax = 128;
- laststatval = -1;
- laststype = OP_STAT;
- maxscream = -1;
- maxsysfd = MAXSYSFD;
- rsfp = Nullfp;
- statname = Nullsv;
- tmps_floor = -1;
+ I_REINIT;
+ perl_destruct_level = 1;
+#else
+ if(perl_destruct_level > 0)
+ I_REINIT;
#endif
init_ids();
+ lex_state = LEX_NOTPARSING;
+ start_env.je_prev = NULL;
+ start_env.je_ret = -1;
+ start_env.je_mustcatch = TRUE;
+ top_env = &start_env;
+ STATUS_ALL_SUCCESS;
+
+ SET_NUMERIC_STANDARD();
#if defined(SUBVERSION) && SUBVERSION > 0
- sprintf(patchlevel, "%7.5f", 5.0 + (PATCHLEVEL / 1000.0)
- + (SUBVERSION / 100000.0));
+ sprintf(patchlevel, "%7.5f", (double) 5
+ + ((double) PATCHLEVEL / (double) 1000)
+ + ((double) SUBVERSION / (double) 100000));
#else
- sprintf(patchlevel, "%5.3f", 5.0 + (PATCHLEVEL / 1000.0));
+ sprintf(patchlevel, "%5.3f", (double) 5 +
+ ((double) PATCHLEVEL / (double) 1000));
#endif
#if defined(LOCAL_PATCH_COUNT)
- Ilocalpatches = local_patches; /* For possible -v */
+ localpatches = local_patches; /* For possible -v */
#endif
+ PerlIO_init(); /* Hook to IO system */
+
fdpid = newAV(); /* for remembering popen pids by fd */
- pidstatus = newHV();/* for remembering status of dead pids */
init_stacks();
ENTER;
@@ -151,22 +189,29 @@ register PerlInterpreter *sv_interp;
#ifdef DEBUGGING
{
char *s;
- if (s = getenv("PERL_DESTRUCT_LEVEL"))
- destruct_level = atoi(s);
+ if (s = getenv("PERL_DESTRUCT_LEVEL")) {
+ int i = atoi(s);
+ if (destruct_level < i)
+ destruct_level = i;
+ }
}
#endif
LEAVE;
FREETMPS;
- if (sv_objcount) {
- /* We must account for everything. First the syntax tree. */
- if (main_root) {
- curpad = AvARRAY(comppad);
- op_free(main_root);
- main_root = 0;
- }
+ /* We must account for everything. */
+
+ /* Destroy the main CV and syntax tree */
+ if (main_root) {
+ curpad = AvARRAY(comppad);
+ op_free(main_root);
+ main_root = Nullop;
}
+ main_start = Nullop;
+ SvREFCNT_dec(main_cv);
+ main_cv = Nullcv;
+
if (sv_objcount) {
/*
* Try to destruct global references. We do this first so that the
@@ -178,6 +223,14 @@ register PerlInterpreter *sv_interp;
sv_clean_objs();
}
+ /* unhook hooks which will soon be, or use, destroyed data */
+ SvREFCNT_dec(warnhook);
+ warnhook = Nullsv;
+ SvREFCNT_dec(diehook);
+ diehook = Nullsv;
+ SvREFCNT_dec(parsehook);
+ parsehook = Nullsv;
+
if (destruct_level == 0){
DEBUG_P(debprofdump());
@@ -185,8 +238,126 @@ register PerlInterpreter *sv_interp;
/* The exit() function will do everything that needs doing. */
return;
}
-
+
+ /* loosen bonds of global variables */
+
+ if(rsfp) {
+ (void)PerlIO_close(rsfp);
+ rsfp = Nullfp;
+ }
+
+ /* Filters for program text */
+ SvREFCNT_dec(rsfp_filters);
+ rsfp_filters = Nullav;
+
+ /* switches */
+ preprocess = FALSE;
+ minus_n = FALSE;
+ minus_p = FALSE;
+ minus_l = FALSE;
+ minus_a = FALSE;
+ minus_F = FALSE;
+ doswitches = FALSE;
+ dowarn = FALSE;
+ doextract = FALSE;
+ sawampersand = FALSE; /* must save all match strings */
+ sawstudy = FALSE; /* do fbm_instr on all strings */
+ sawvec = FALSE;
+ unsafe = FALSE;
+
+ Safefree(inplace);
+ inplace = Nullch;
+
+ Safefree(e_tmpname);
+ e_tmpname = Nullch;
+
+ if (e_fp) {
+ PerlIO_close(e_fp);
+ e_fp = Nullfp;
+ }
+
+ /* magical thingies */
+
+ Safefree(ofs); /* $, */
+ ofs = Nullch;
+
+ Safefree(ors); /* $\ */
+ ors = Nullch;
+
+ SvREFCNT_dec(nrs); /* $\ helper */
+ nrs = Nullsv;
+
+ multiline = 0; /* $* */
+
+ SvREFCNT_dec(statname);
+ statname = Nullsv;
+ statgv = Nullgv;
+
+ /* defgv, aka *_ should be taken care of elsewhere */
+
+#if 0 /* just about all regexp stuff, seems to be ok */
+
+ /* shortcuts to regexp stuff */
+ leftgv = Nullgv;
+ ampergv = Nullgv;
+
+ SAVEFREEOP(curpm);
+ SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
+
+ regprecomp = NULL; /* uncompiled string. */
+ regparse = NULL; /* Input-scan pointer. */
+ regxend = NULL; /* End of input for compile */
+ regnpar = 0; /* () count. */
+ regcode = NULL; /* Code-emit pointer; &regdummy = don't. */
+ regsize = 0; /* Code size. */
+ regnaughty = 0; /* How bad is this pattern? */
+ regsawback = 0; /* Did we see \1, ...? */
+
+ reginput = NULL; /* String-input pointer. */
+ regbol = NULL; /* Beginning of input, for ^ check. */
+ regeol = NULL; /* End of input, for $ check. */
+ regstartp = (char **)NULL; /* Pointer to startp array. */
+ regendp = (char **)NULL; /* Ditto for endp. */
+ reglastparen = 0; /* Similarly for lastparen. */
+ regtill = NULL; /* How far we are required to go. */
+ regflags = 0; /* are we folding, multilining? */
+ regprev = (char)NULL; /* char before regbol, \n if none */
+
+#endif /* if 0 */
+
+ /* clean up after study() */
+ SvREFCNT_dec(lastscream);
+ lastscream = Nullsv;
+ Safefree(screamfirst);
+ screamfirst = 0;
+ Safefree(screamnext);
+ screamnext = 0;
+
+ /* startup and shutdown function lists */
+ SvREFCNT_dec(beginav);
+ SvREFCNT_dec(endav);
+ beginav = Nullav;
+ endav = Nullav;
+
+ /* temp stack during pp_sort() */
+ SvREFCNT_dec(sortstack);
+ sortstack = Nullav;
+
+ /* shortcuts just get cleared */
+ envgv = Nullgv;
+ siggv = Nullgv;
+ incgv = Nullgv;
+ errgv = Nullgv;
+ argvgv = Nullgv;
+ argvoutgv = Nullgv;
+ stdingv = Nullgv;
+ last_in_gv = Nullgv;
+
+ /* reset so print() ends up where we expect */
+ setdefout(Nullgv);
+
/* Prepare to destruct main symbol table. */
+
hv = defstash;
defstash = 0;
SvREFCNT_dec(hv);
@@ -194,26 +365,84 @@ register PerlInterpreter *sv_interp;
FREETMPS;
if (destruct_level >= 2) {
if (scopestack_ix != 0)
- warn("Unbalanced scopes: %d more ENTERs than LEAVEs\n", scopestack_ix);
+ warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
+ (long)scopestack_ix);
if (savestack_ix != 0)
- warn("Unbalanced saves: %d more saves than restores\n", savestack_ix);
+ warn("Unbalanced saves: %ld more saves than restores\n",
+ (long)savestack_ix);
if (tmps_floor != -1)
- warn("Unbalanced tmps: %d more allocs than frees\n", tmps_floor + 1);
+ warn("Unbalanced tmps: %ld more allocs than frees\n",
+ (long)tmps_floor + 1);
if (cxstack_ix != -1)
- warn("Unbalanced context: %d more PUSHes than POPs\n", 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(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
while (sv_count != 0 && sv_count != last_sv_count) {
last_sv_count = sv_count;
sv_clean_all();
}
+ SvFLAGS(strtab) &= ~SVTYPEMASK;
+ SvFLAGS(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(strtab);
+ array = HvARRAY(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(strtab);
+
if (sv_count != 0)
- warn("Scalars leaked: %d\n", sv_count);
+ warn("Scalars leaked: %ld\n", (long)sv_count);
+
sv_free_arenas();
+
+ /* No SVs have survived, need to clean out */
+ linestr = NULL;
+ pidstatus = Nullhv;
+ if (origfilename)
+ Safefree(origfilename);
+ nuke_stacks();
+ hints = 0; /* Reset hints. Should hints be per-interpreter ? */
DEBUG_P(debprofdump());
+
+ /* As the absolutely last thing, free the non-arena SV for mess() */
+
+ if (mess_sv) {
+ /* we know that type >= SVt_PV */
+ SvOOK_off(mess_sv);
+ Safefree(SvPVX(mess_sv));
+ Safefree(SvANY(mess_sv));
+ Safefree(mess_sv);
+ mess_sv = Nullsv;
+ }
}
void
@@ -224,9 +453,6 @@ PerlInterpreter *sv_interp;
return;
Safefree(sv_interp);
}
-#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
-char *getenv _((char *)); /* Usually in <stdlib.h> */
-#endif
int
perl_parse(sv_interp, xsinit, argc, argv, env)
@@ -241,7 +467,10 @@ char **env;
char *scriptname = NULL;
VOL bool dosearch = FALSE;
char *validarg = "";
+ I32 oldscope;
AV* comppadlist;
+ dJMPENV;
+ int ret;
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
@@ -254,6 +483,11 @@ setuid perl scripts securely.\n");
if (!(curinterp = sv_interp))
return 255;
+#if defined(NeXT) && defined(__DYNAMIC__)
+ _dyld_lookup_and_bind
+ ("__environ", (unsigned long *) &environ_pointer, NULL);
+#endif /* environ */
+
origargv = argv;
origargc = argc;
#ifndef VMS /* VMS doesn't have environ array */
@@ -273,24 +507,36 @@ setuid perl scripts securely.\n");
return 0;
}
- if (main_root)
+ if (main_root) {
+ curpad = AvARRAY(comppad);
op_free(main_root);
- main_root = 0;
+ main_root = Nullop;
+ }
+ main_start = Nullop;
+ SvREFCNT_dec(main_cv);
+ main_cv = Nullcv;
- switch (Sigsetjmp(top_env,1)) {
+ time(&basetime);
+ oldscope = scopestack_ix;
+
+ JMPENV_PUSH(ret);
+ switch (ret) {
case 1:
-#ifdef VMS
- statusvalue = 255;
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
+ /* FALL THROUGH */
case 2:
+ /* my_exit() was called */
+ while (scopestack_ix > oldscope)
+ LEAVE;
+ FREETMPS;
curstash = defstash;
if (endav)
- calllist(endav);
- return(statusvalue); /* my_exit() was called */
+ call_list(oldscope, endav);
+ JMPENV_POP;
+ return STATUS_NATIVE_EXPORT;
case 3:
- fprintf(stderr, "panic: top_env\n");
+ JMPENV_POP;
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
return 1;
}
@@ -298,6 +544,7 @@ setuid perl scripts securely.\n");
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;
@@ -324,7 +571,6 @@ setuid perl scripts securely.\n");
case 'n':
case 'p':
case 's':
- case 'T':
case 'u':
case 'U':
case 'v':
@@ -333,6 +579,11 @@ setuid perl scripts securely.\n");
goto reswitch;
break;
+ case 'T':
+ tainting = TRUE;
+ s++;
+ goto reswitch;
+
case 'e':
if (euid != uid || egid != gid)
croak("No -e allowed in setuid scripts");
@@ -343,40 +594,47 @@ setuid perl scripts securely.\n");
fd = mkstemp(e_tmpname);
if (fd == -1)
croak("Can't mkstemp()");
- e_fp = fdopen(fd,"w");
+ e_fp = PerlIO_fdopen(fd,"w");
if (!e_fp) {
- close(fd);
+ (void)close(fd);
croak("Cannot open temporary file");
}
}
- if (argv[1]) {
- fputs(argv[1],e_fp);
+ if (*++s)
+ PerlIO_puts(e_fp,s);
+ else if (argv[1]) {
+ PerlIO_puts(e_fp,argv[1]);
argc--,argv++;
}
- (void)putc('\n', e_fp);
+ else
+ croak("No code specified for -e");
+ (void)PerlIO_putc(e_fp,'\n');
break;
- case 'I':
- taint_not("-I");
- sv_catpv(sv,"-");
- sv_catpv(sv,s);
- sv_catpv(sv," ");
- if (*++s) {
- av_push(GvAVn(incgv),newSVpv(s,0));
- }
- else if (argv[1]) {
- av_push(GvAVn(incgv),newSVpv(argv[1],0));
- sv_catpv(sv,argv[1]);
+ case 'I': /* -I handled both here and in moreswitches() */
+ forbid_setid("-I");
+ if (!*++s && (s=argv[1]) != Nullch) {
argc--,argv++;
- sv_catpv(sv," ");
}
+ 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':
- taint_not("-P");
+ forbid_setid("-P");
preprocess = TRUE;
s++;
goto reswitch;
case 'S':
- taint_not("-S");
+ forbid_setid("-S");
dosearch = TRUE;
s++;
goto reswitch;
@@ -385,7 +643,48 @@ setuid perl scripts securely.\n");
preambleav = newAV();
av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
if (*++s != ':') {
- Sv = newSVpv("print myconfig(),'@INC: '.\"@INC\\n\"",0);
+ Sv = newSVpv("print myconfig();",0);
+#ifdef VMS
+ sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
+#else
+ sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
+#endif
+#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
+ sv_catpv(Sv,"\" Compile-time options:");
+# ifdef DEBUGGING
+ sv_catpv(Sv," DEBUGGING");
+# endif
+# ifdef NO_EMBED
+ sv_catpv(Sv," NO_EMBED");
+# endif
+# ifdef MULTIPLICITY
+ sv_catpv(Sv," MULTIPLICITY");
+# endif
+ sv_catpv(Sv,"\\n\",");
+#endif
+#if defined(LOCAL_PATCH_COUNT)
+ if (LOCAL_PATCH_COUNT > 0) {
+ int i;
+ sv_catpv(Sv,"\" Locally applied patches:\\n\",");
+ for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
+ if (localpatches[i])
+ sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
+ }
+ }
+#endif
+ sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
+#ifdef __DATE__
+# ifdef __TIME__
+ sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
+# else
+ sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
+# endif
+#endif
+ sv_catpv(Sv, "; \
+$\"=\"\\n \"; \
+@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
+print \" \\%ENV:\\n @env\\n\" if @env; \
+print \" \\@INC:\\n @INC\\n\";");
}
else {
Sv = newSVpv("config_vars(qw(",0);
@@ -402,29 +701,64 @@ setuid perl scripts securely.\n");
if (*s)
cddir = savepv(s);
break;
- case '-':
- argc--,argv++;
- goto switch_end;
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",s);
+ croak("Unrecognized switch: -%s (-h will show valid options)",s);
}
}
switch_end:
+
+ if (!tainting && (s = 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 (e_fp) {
- if (Fflush(e_fp) || ferror(e_fp) || fclose(e_fp))
+ if (PerlIO_flush(e_fp) || PerlIO_error(e_fp) || PerlIO_close(e_fp)) {
+#ifndef MULTIPLICITY
+ warn("Did you forget to compile with -DMULTIPLICITY?");
+#endif
croak("Can't write to temp file for -e: %s", Strerror(errno));
+ }
e_fp = Nullfp;
argc++,argv--;
scriptname = e_tmpname;
}
else if (scriptname == Nullch) {
#ifdef MSDOS
- if ( isatty(fileno(stdin)) )
- moreswitches("v");
+ if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
+ moreswitches("h");
#endif
scriptname = "-";
}
@@ -438,15 +772,14 @@ setuid perl scripts securely.\n");
if (doextract)
find_beginning();
- compcv = (CV*)NEWSV(1104,0);
+ main_cv = compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)compcv, SVt_PVCV);
+ CvUNIQUE_on(compcv);
- pad = newAV();
- comppad = pad;
+ comppad = newAV();
av_push(comppad, Nullsv);
curpad = AvARRAY(comppad);
- padname = newAV();
- comppad_name = padname;
+ comppad_name = newAV();
comppad_name_fill = 0;
min_intro_pending = 0;
padix = 0;
@@ -457,9 +790,10 @@ setuid perl scripts securely.\n");
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(compcv) = comppadlist;
+ boot_core_UNIVERSAL();
if (xsinit)
(*xsinit)(); /* in case linked C routines want magical variables */
-#ifdef VMS
+#if defined(VMS) || defined(WIN32)
init_os_extras();
#endif
@@ -503,13 +837,14 @@ setuid perl scripts securely.\n");
LEAVE;
FREETMPS;
-#ifdef DEBUGGING_MSTATS
+#ifdef MYMALLOC
if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
dump_mstats("after compilation:");
#endif
ENTER;
restartop = 0;
+ JMPENV_POP;
return 0;
}
@@ -517,44 +852,60 @@ int
perl_run(sv_interp)
PerlInterpreter *sv_interp;
{
+ I32 oldscope;
+ dJMPENV;
+ int ret;
+
if (!(curinterp = sv_interp))
return 255;
- switch (Sigsetjmp(top_env,1)) {
+
+ oldscope = scopestack_ix;
+
+ JMPENV_PUSH(ret);
+ switch (ret) {
case 1:
cxstack_ix = -1; /* start context stack again */
break;
case 2:
+ /* my_exit() was called */
+ while (scopestack_ix > oldscope)
+ LEAVE;
+ FREETMPS;
curstash = defstash;
if (endav)
- calllist(endav);
- FREETMPS;
-#ifdef DEBUGGING_MSTATS
+ call_list(oldscope, endav);
+#ifdef MYMALLOC
if (getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- return(statusvalue); /* my_exit() was called */
+ JMPENV_POP;
+ return STATUS_NATIVE_EXPORT;
case 3:
if (!restartop) {
- fprintf(stderr, "panic: restartop\n");
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
FREETMPS;
+ JMPENV_POP;
return 1;
}
- if (stack != mainstack) {
+ if (curstack != mainstack) {
dSP;
- SWITCHSTACK(stack, mainstack);
+ SWITCHSTACK(curstack, mainstack);
}
break;
}
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
+ sawampersand ? "Enabling" : "Omitting"));
+
if (!restartop) {
DEBUG_x(dump_all());
- DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
+ DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
if (minus_c) {
- fprintf(stderr,"%s syntax OK\n", origfilename);
+ PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
my_exit(0);
}
- if (perldb && DBsingle)
+ if (PERLDB_SINGLE && DBsingle)
sv_setiv(DBsingle, 1);
}
@@ -566,32 +917,16 @@ PerlInterpreter *sv_interp;
runops();
}
else if (main_start) {
+ CvDEPTH(main_cv) = 1;
op = main_start;
runops();
}
my_exit(0);
+ /* NOTREACHED */
return 0;
}
-void
-my_exit(status)
-U32 status;
-{
- register CONTEXT *cx;
- I32 gimme;
- SV **newsp;
-
- statusvalue = FIXSTATUS(status);
- if (cxstack_ix >= 0) {
- if (cxstack_ix > 0)
- dounwind(0);
- POPBLOCK(cx,curpm);
- LEAVE;
- }
- Siglongjmp(top_env, 2);
-}
-
SV*
perl_get_sv(name, create)
char* name;
@@ -635,13 +970,13 @@ char* name;
I32 create;
{
GV* gv = gv_fetchpv(name, create, SVt_PVCV);
- if (create && !GvCV(gv))
- return newSUB(start_subparse(),
+ if (create && !GvCVu(gv))
+ return newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
Nullop,
Nullop);
if (gv)
- return GvCV(gv);
+ return GvCVu(gv);
return Nullcv;
}
@@ -697,39 +1032,50 @@ I32 flags; /* See G_* flags in cop.h */
{
LOGOP myop; /* fake syntax tree node */
SV** sp = stack_sp;
- I32 oldmark = TOPMARK;
+ I32 oldmark;
I32 retval;
- Sigjmp_buf oldtop;
I32 oldscope;
-
+ static CV *DBcv;
+ bool oldcatch = CATCH_GET;
+ dJMPENV;
+ int ret;
+ OP* oldop = 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);
SAVESPTR(op);
op = (OP*)&myop;
- Zero(op, 1, LOGOP);
+
EXTEND(stack_sp, 1);
*++stack_sp = sv;
+ oldmark = TOPMARK;
oldscope = scopestack_ix;
- if (!(flags & G_NOARGS))
- myop.op_flags = OPf_STACKED;
- myop.op_next = Nullop;
- myop.op_flags |= OPf_KNOW;
- if (flags & G_ARRAY)
- myop.op_flags |= OPf_LIST;
+ if (PERLDB_SUB && curstash != debstash
+ /* Handle first BEGIN of -d. */
+ && (DBcv || (DBcv = GvCV(DBsub)))
+ /* Try harder, since this may have been a sighandler, thus
+ * curstash may be meaningless. */
+ && (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != debstash))
+ op->op_private |= OPpENTERSUB_DB;
if (flags & G_EVAL) {
- Copy(top_env, oldtop, 1, Sigjmp_buf);
-
cLOGOP->op_other = op;
markstack_ptr--;
/* we're trying to emulate pp_entertry() here */
{
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
@@ -747,31 +1093,27 @@ I32 flags; /* See G_* flags in cop.h */
}
markstack_ptr++;
- restart:
- switch (Sigsetjmp(top_env,1)) {
+ JMPENV_PUSH(ret);
+ switch (ret) {
case 0:
break;
case 1:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
curstash = defstash;
FREETMPS;
- Copy(oldtop, top_env, 1, Sigjmp_buf);
+ JMPENV_POP;
if (statusvalue)
croak("Callback called exit");
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
case 3:
if (restartop) {
op = restartop;
restartop = 0;
- goto restart;
+ break;
}
stack_sp = stack_base + oldmark;
if (flags & G_ARRAY)
@@ -783,6 +1125,8 @@ I32 flags; /* See G_* flags in cop.h */
goto cleanup;
}
}
+ else
+ CATCH_SET(TRUE);
if (op == (OP*)&myop)
op = pp_entersub();
@@ -807,18 +1151,22 @@ I32 flags; /* See G_* flags in cop.h */
curpm = newpm;
LEAVE;
}
- Copy(oldtop, top_env, 1, Sigjmp_buf);
+ JMPENV_POP;
}
+ else
+ CATCH_SET(oldcatch);
+
if (flags & G_DISCARD) {
stack_sp = stack_base + oldmark;
retval = 0;
FREETMPS;
LEAVE;
}
+ op = oldop;
return retval;
}
-/* Eval a string. */
+/* Eval a string. The G_EVAL flag is always assumed. */
I32
perl_eval_sv(sv, flags)
@@ -829,9 +1177,11 @@ I32 flags; /* See G_* flags in cop.h */
SV** sp = stack_sp;
I32 oldmark = sp - stack_base;
I32 retval;
- Sigjmp_buf oldtop;
I32 oldscope;
-
+ dJMPENV;
+ int ret;
+ OP* oldop = op;
+
if (flags & G_DISCARD) {
ENTER;
SAVETMPS;
@@ -847,37 +1197,34 @@ I32 flags; /* See G_* flags in cop.h */
if (!(flags & G_NOARGS))
myop.op_flags = OPf_STACKED;
myop.op_next = Nullop;
- myop.op_flags |= OPf_KNOW;
- if (flags & G_ARRAY)
- myop.op_flags |= OPf_LIST;
-
- Copy(top_env, oldtop, 1, Sigjmp_buf);
-
-restart:
- switch (Sigsetjmp(top_env,1)) {
+ 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:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
curstash = defstash;
FREETMPS;
- Copy(oldtop, top_env, 1, Sigjmp_buf);
+ JMPENV_POP;
if (statusvalue)
croak("Callback called exit");
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
case 3:
if (restartop) {
op = restartop;
restartop = 0;
- goto restart;
+ break;
}
stack_sp = stack_base + oldmark;
if (flags & G_ARRAY)
@@ -894,20 +1241,43 @@ restart:
if (op)
runops();
retval = stack_sp - (stack_base + oldmark);
- if ((flags & G_EVAL) && !(flags & G_KEEPERR))
+ if (!(flags & G_KEEPERR))
sv_setpv(GvSV(errgv),"");
cleanup:
- Copy(oldtop, top_env, 1, Sigjmp_buf);
+ JMPENV_POP;
if (flags & G_DISCARD) {
stack_sp = stack_base + oldmark;
retval = 0;
FREETMPS;
LEAVE;
}
+ op = oldop;
return retval;
}
+SV*
+perl_eval_pv(p, croak_on_error)
+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(GvSV(errgv)))
+ croak(SvPVx(GvSV(errgv), na));
+
+ return sv;
+}
+
/* Require a module. */
void
@@ -933,76 +1303,45 @@ I32 namlen;
sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
}
-#if defined(DOSISH)
-# define PERLLIB_SEP ';'
-#else
-# if defined(VMS)
-# define PERLLIB_SEP '|'
-# else
-# define PERLLIB_SEP ':'
-# endif
-#endif
-
-static void
-incpush(p)
-char *p;
-{
- char *s;
-
- if (!p)
- return;
-
- /* Break at all separators */
- while (*p) {
- /* First, skip any consecutive separators */
- while ( *p == PERLLIB_SEP ) {
- /* Uncomment the next line for PATH semantics */
- /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
- p++;
- }
- if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
- av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
- p = s + 1;
- } else {
- av_push(GvAVn(incgv), newSVpv(p, 0));
- break;
- }
- }
-}
-
static void
usage(name) /* XXX move this out into a module ? */
char *name;
{
/* This message really ought to be max 23 lines.
* Removed -h because the user already knows that opton. Others? */
+
+ static char *usage[] = {
+"-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 and patchlevel of perl",
+"-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;
+
printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
- printf("\n -0[octal] specify record separator (\\0, if no argument)");
- printf("\n -a autosplit mode with -n or -p (splits $_ into @F)");
- printf("\n -c check syntax only (runs BEGIN and END blocks)");
- printf("\n -d[:debugger] run scripts under debugger");
- printf("\n -D[number/list] set debugging flags (argument is a bit mask or flags)");
- printf("\n -e 'command' one line of script. Several -e's allowed. Omit [programfile].");
- printf("\n -F/pattern/ split() pattern for autosplit (-a). The //'s are optional.");
- printf("\n -i[extension] edit <> files in place (make backup if extension supplied)");
- printf("\n -Idirectory specify @INC/#include directory (may be used more then once)");
- printf("\n -l[octal] enable line ending processing, specifies line teminator");
- printf("\n -[mM][-]module.. executes `use/no module...' before executing your script.");
- printf("\n -n assume 'while (<>) { ... }' loop arround your script");
- printf("\n -p assume loop like -n but print line also like sed");
- printf("\n -P run script through C preprocessor before compilation");
-#ifdef OS2
- printf("\n -R enable REXX variable pool");
-#endif
- printf("\n -s enable some switch parsing for switches after script name");
- printf("\n -S look for the script using PATH environment variable");
- printf("\n -T turn on tainting checks");
- printf("\n -u dump core after parsing script");
- printf("\n -U allow unsafe operations");
- printf("\n -v print version number and patchlevel of perl");
- printf("\n -V[:variable] print perl configuration information");
- printf("\n -w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT.");
- printf("\n -x[directory] strip off text before #!perl line and perhaps cd to directory\n");
+ while (*p)
+ printf("\n %s", *p++);
}
/* This routine handles any switches that can be given during run */
@@ -1041,21 +1380,20 @@ char *s;
s++;
return s;
case 'd':
- taint_not("-d");
+ forbid_setid("-d");
s++;
if (*s == ':' || *s == '=') {
- sprintf(buf, "use Devel::%s;", ++s);
+ my_setenv("PERL5DB", form("use Devel::%s;", ++s));
s += strlen(s);
- my_setenv("PERL5DB",buf);
}
if (!perldb) {
- perldb = TRUE;
+ perldb = PERLDB_ALL;
init_debugger();
}
return s;
case 'D':
#ifdef DEBUGGING
- taint_not("-D");
+ forbid_setid("-D");
if (isALPHA(s[1])) {
static char debopts[] = "psltocPmfrxuLHXD";
char *d;
@@ -1083,20 +1421,25 @@ char *s;
inplace = savepv(s+1);
/*SUPPRESS 530*/
for (s = inplace; *s && !isSPACE(*s); s++) ;
- *s = '\0';
- break;
- case 'I':
- taint_not("-I");
- if (*++s) {
- char *e;
+ if (*s)
+ *s++ = '\0';
+ 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++) ;
- av_push(GvAVn(incgv),newSVpv(s,e-s));
- if (*e)
- return e;
+ p = savepvn(s, e-s);
+ incpush(p, TRUE);
+ Safefree(p);
+ s = e;
}
else
croak("No space allowed after -I");
- break;
+ return s;
case 'l':
minus_l = TRUE;
s++;
@@ -1110,18 +1453,19 @@ char *s;
}
else {
if (RsPARA(nrs)) {
- ors = savepvn("\n\n", 2);
+ ors = "\n\n";
orslen = 2;
}
else
ors = SvPV(nrs, orslen);
+ ors = savepvn(ors, orslen);
}
return s;
case 'M':
- taint_not("-M"); /* XXX ? */
+ forbid_setid("-M"); /* XXX ? */
/* FALL THROUGH */
case 'm':
- taint_not("-m"); /* XXX ? */
+ forbid_setid("-m"); /* XXX ? */
if (*++s) {
char *start;
char *use = "use ";
@@ -1161,12 +1505,13 @@ char *s;
s++;
return s;
case 's':
- taint_not("-s");
+ forbid_setid("-s");
doswitches = TRUE;
s++;
return s;
case 'T':
- tainting = TRUE;
+ if (!tainting)
+ croak("Too late for \"-T\" option");
s++;
return s;
case 'u':
@@ -1179,61 +1524,35 @@ char *s;
return s;
case 'v':
#if defined(SUBVERSION) && SUBVERSION > 0
- printf("\nThis is perl, version 5.%03d_%02d", PATCHLEVEL, SUBVERSION);
+ printf("\nThis is perl, version 5.%03d_%02d built for %s",
+ PATCHLEVEL, SUBVERSION, ARCHNAME);
#else
- printf("\nThis is perl, version %s",patchlevel);
-#endif
-
-#if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY)
- fputs(" with", stdout);
-#ifdef DEBUGGING
- fputs(" DEBUGGING", stdout);
-#endif
-#ifdef EMBED
- fputs(" EMBED", stdout);
+ printf("\nThis is perl, version %s built for %s",
+ patchlevel, ARCHNAME);
#endif
-#ifdef MULTIPLICITY
- fputs(" MULTIPLICITY", stdout);
-#endif
-#endif
-
#if defined(LOCAL_PATCH_COUNT)
- if (LOCAL_PATCH_COUNT > 0)
- { int i;
- fputs("\n\tLocally applied patches:\n", stdout);
- for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
- if (Ilocalpatches[i])
- fprintf(stdout, "\t %s\n", Ilocalpatches[i]);
- }
- }
-#endif
- printf("\n\tbuilt under %s",OSNAME);
-#ifdef __DATE__
-# ifdef __TIME__
- printf(" at %s %s",__DATE__,__TIME__);
-# else
- printf(" on %s",__DATE__);
-# endif
+ 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
- fputs("\n\t+ suidperl security patch", stdout);
- fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
+
+ printf("\n\nCopyright 1987-1997, Larry Wall\n");
#ifdef MSDOS
- fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
- stdout);
+ printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
+#endif
+#ifdef DJGPP
+ printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
#endif
#ifdef OS2
- fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
- "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout);
+ printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
+ "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
#endif
#ifdef atarist
- fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
+ printf("atariST series port, ++jrb bammi@cadence.com\n");
#endif
- fputs("\n\
+ 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",stdout);
-#ifdef MSDOS
- usage(origargv[0]);
-#endif
+GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
exit(0);
case 'w':
dowarn = TRUE;
@@ -1249,6 +1568,10 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n",
case '\n':
case '\t':
break;
+#ifdef ALTERNATE_SHEBANG
+ case 'S': /* OS/2 needs -S on "extproc" line. */
+ break;
+#endif
case 'P':
if (preprocess)
return s+1;
@@ -1267,23 +1590,28 @@ void
my_unexec()
{
#ifdef UNEXEC
+ SV* prog;
+ SV* file;
int status;
extern int etext;
- sprintf (buf, "%s.perldump", origfilename);
- sprintf (tokenbuf, "%s/perl", BIN);
+ prog = newSVpv(BIN_EXP);
+ sv_catpv(prog, "/perl");
+ file = newSVpv(origfilename);
+ sv_catpv(file, ".perldump");
- status = unexec(buf, tokenbuf, &etext, sbrk(0), 0);
+ status = unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
if (status)
- fprintf(stderr, "unexec of %s into %s failed!\n", tokenbuf, buf);
+ PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
+ SvPVX(prog), SvPVX(file));
exit(status);
#else
# ifdef VMS
# include <lib$routines.h>
lib$signal(SS$_DEBUG); /* ssdef.h #included from vmsish.h */
-#else
+# else
ABORT(); /* for use with undump */
-#endif
+# endif
#endif
}
@@ -1291,6 +1619,15 @@ static void
init_main_stash()
{
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() */
+ strtab = newHV();
+ HvSHAREKEYS_off(strtab); /* mandatory */
+ Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
+ sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
+
curstash = defstash = newHV();
curstname = newSVpv("main",4);
gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
@@ -1303,6 +1640,9 @@ init_main_stash()
defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
GvMULTI_on(errgv);
+ (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
+ sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
+ sv_setpvn(GvSV(errgv), "", 0);
curstash = defstash;
compiling.cop_stash = defstash;
debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
@@ -1327,52 +1667,141 @@ SV *sv;
I32 len;
int retval;
#if defined(DOSISH) && !defined(OS2) && !defined(atarist)
-#define SEARCH_EXTS ".bat", ".cmd", NULL
+# 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 *ext[] = { SEARCH_EXTS };
- int extidx = (strchr(scriptname,'.')) ? -1 : 0; /* has ext already */
+ int extidx = 0, i = 0;
+ char *curext = Nullch;
+#else
+# define MAX_EXT_LEN 0
#endif
-#ifdef VMS
- if (dosearch && !strpbrk(scriptname,":[</") && (my_getenv("DCL$PATH"))) {
- int idx = 0;
+ /*
+ * 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:
+ * + 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)
+ */
- while (my_trnlnm("DCL$PATH",tokenbuf,idx++)) {
- strcat(tokenbuf,scriptname);
+#ifdef VMS
+ if (dosearch) {
+ int hasdir, idx = 0, deftypes = 1;
+ bool seen_dot = 1;
+
+ hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
+ /* 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",tokenbuf,idx++)) )
+ {
+ if (deftypes) {
+ deftypes = 0;
+ *tokenbuf = '\0';
+ }
+ if ((strlen(tokenbuf) + strlen(scriptname)
+ + MAX_EXT_LEN) >= sizeof tokenbuf)
+ continue; /* don't search dir with too-long name */
+ strcat(tokenbuf, scriptname);
#else /* !VMS */
- if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
- bufend = s + strlen(s);
- while (*s) {
-#ifndef DOSISH
- s = cpytill(tokenbuf,s,bufend,':',&len);
-#else
-#ifdef atarist
- for (len = 0; *s && *s != ',' && *s != ';'; tokenbuf[len++] = *s++);
- tokenbuf[len] = '\0';
-#else
- for (len = 0; *s && *s != ';'; tokenbuf[len++] = *s++);
- tokenbuf[len] = '\0';
+#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 (Stat(cur,&statbuf) >= 0) {
+ dosearch = 0;
+ scriptname = cur;
+#ifdef SEARCH_EXTS
+ break;
#endif
- if (*s)
- s++;
-#ifndef DOSISH
- if (len && tokenbuf[len-1] != '/')
-#else
-#ifdef atarist
- if (len && ((tokenbuf[len-1] != '\\') && (tokenbuf[len-1] != '/')))
-#else
- if (len && tokenbuf[len-1] != '\\')
+ }
+#ifdef SEARCH_EXTS
+ if (cur == scriptname) {
+ len = strlen(scriptname);
+ if (len+MAX_EXT_LEN+1 >= sizeof(tokenbuf))
+ break;
+ cur = strcpy(tokenbuf, scriptname);
+ }
+ } while (extidx >= 0 && ext[extidx] /* try an extension? */
+ && strcpy(tokenbuf+len, ext[extidx++]));
#endif
+ }
+#endif
+
+ if (dosearch && !strchr(scriptname, '/')
+#ifdef DOSISH
+ && !strchr(scriptname, '\\')
#endif
- (void)strcat(tokenbuf+len,"/");
- (void)strcat(tokenbuf+len,scriptname);
+ && (s = getenv("PATH"))) {
+ bool seen_dot = 0;
+
+ bufend = s + strlen(s);
+ while (s < bufend) {
+#if defined(atarist) || defined(DOSISH)
+ for (len = 0; *s
+# ifdef atarist
+ && *s != ','
+# endif
+ && *s != ';'; len++, s++) {
+ if (len < sizeof tokenbuf)
+ tokenbuf[len] = *s;
+ }
+ if (len < sizeof tokenbuf)
+ tokenbuf[len] = '\0';
+#else /* ! (atarist || DOSISH) */
+ s = delimcpy(tokenbuf, tokenbuf + sizeof tokenbuf, s, bufend,
+ ':',
+ &len);
+#endif /* ! (atarist || DOSISH) */
+ if (s < bufend)
+ s++;
+ if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tokenbuf)
+ continue; /* don't search dir with too-long name */
+ if (len
+#if defined(atarist) || defined(DOSISH)
+ && tokenbuf[len - 1] != '/'
+ && tokenbuf[len - 1] != '\\'
+#endif
+ )
+ tokenbuf[len++] = '/';
+ if (len == 2 && tokenbuf[0] == '.')
+ seen_dot = 1;
+ (void)strcpy(tokenbuf + len, scriptname);
#endif /* !VMS */
#ifdef SEARCH_EXTS
@@ -1381,7 +1810,7 @@ SV *sv;
extidx = 0;
do {
#endif
- DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
+ DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
retval = Stat(tokenbuf,&statbuf);
#ifdef SEARCH_EXTS
} while ( retval < 0 /* not there */
@@ -1392,15 +1821,28 @@ SV *sv;
if (retval < 0)
continue;
if (S_ISREG(statbuf.st_mode)
- && cando(S_IRUSR,TRUE,&statbuf) && cando(S_IXUSR,TRUE,&statbuf)) {
+ && cando(S_IRUSR,TRUE,&statbuf)
+#ifndef DOSISH
+ && cando(S_IXUSR,TRUE,&statbuf)
+#endif
+ )
+ {
xfound = tokenbuf; /* bingo! */
break;
}
if (!xfailed)
xfailed = savepv(tokenbuf);
}
+#ifndef DOSISH
+ if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
+#endif
+ seen_dot = 1; /* Disable message. */
if (!xfound)
- croak("Can't execute %s", xfailed ? xfailed : scriptname );
+ croak("Can't %s %s%s%s",
+ (xfailed ? "execute" : "find"),
+ (xfailed ? xfailed : scriptname),
+ (xfailed ? "" : " on PATH"),
+ (xfailed || seen_dot) ? "" : ", '.' not in PATH");
if (xfailed)
Safefree(xfailed);
scriptname = xfound;
@@ -1421,22 +1863,26 @@ SV *sv;
if (strEQ(origfilename,"-"))
scriptname = "";
if (fdscript >= 0) {
- rsfp = fdopen(fdscript,"r");
+ rsfp = PerlIO_fdopen(fdscript,"r");
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
+ if (rsfp)
+ fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
#endif
}
else if (preprocess) {
- char *cpp = CPPSTDIN;
+ char *cpp_cfg = CPPSTDIN;
+ SV *cpp = NEWSV(0,0);
+ SV *cmd = NEWSV(0,0);
+
+ if (strEQ(cpp_cfg, "cppstdin"))
+ sv_catpvf(cpp, "%s/", BIN_EXP);
+ sv_catpv(cpp, cpp_cfg);
- if (strEQ(cpp,"cppstdin"))
- sprintf(tokenbuf, "%s/%s", SCRIPTDIR, cpp);
- else
- sprintf(tokenbuf, "%s", cpp);
sv_catpv(sv,"-I");
sv_catpv(sv,PRIVLIB_EXP);
+
#ifdef MSDOS
- (void)sprintf(buf, "\
+ sv_setpvf(cmd, "\
sed %s -e \"/^[^#]/b\" \
-e \"/^#[ ]*include[ ]/b\" \
-e \"/^#[ ]*define[ ]/b\" \
@@ -1448,10 +1894,10 @@ sed %s -e \"/^[^#]/b\" \
-e \"/^#[ ]*undef[ ]/b\" \
-e \"/^#[ ]*endif/b\" \
-e \"s/^#.*//\" \
- %s | %s -C %s %s",
+ %s | %_ -C %_ %s",
(doextract ? "-e \"1,/^#/d\n\"" : ""),
#else
- (void)sprintf(buf, "\
+ sv_setpvf(cmd, "\
%s %s -e '/^[^#]/b' \
-e '/^#[ ]*include[ ]/b' \
-e '/^#[ ]*define[ ]/b' \
@@ -1463,7 +1909,7 @@ sed %s -e \"/^[^#]/b\" \
-e '/^#[ ]*undef[ ]/b' \
-e '/^#[ ]*endif/b' \
-e 's/^[ ]*#.*//' \
- %s | %s -C %s %s",
+ %s | %_ -C %_ %s",
#ifdef LOC_SED
LOC_SED,
#else
@@ -1471,7 +1917,7 @@ sed %s -e \"/^[^#]/b\" \
#endif
(doextract ? "-e '1,/^#/d\n'" : ""),
#endif
- scriptname, tokenbuf, SvPV(sv, na), CPPMINUS);
+ scriptname, cpp, sv, CPPMINUS);
doextract = FALSE;
#ifdef IAMSUID /* actually, this is caught earlier */
if (euid != uid && !euid) { /* if running suidperl */
@@ -1492,25 +1938,31 @@ sed %s -e \"/^[^#]/b\" \
croak("Can't do seteuid!\n");
}
#endif /* IAMSUID */
- rsfp = my_popen(buf,"r");
+ rsfp = my_popen(SvPVX(cmd), "r");
+ SvREFCNT_dec(cmd);
+ SvREFCNT_dec(cpp);
}
else if (!*scriptname) {
- taint_not("program input from stdin");
- rsfp = stdin;
+ forbid_setid("program input from stdin");
+ rsfp = PerlIO_stdin();
}
else {
- rsfp = fopen(scriptname,"r");
+ rsfp = PerlIO_open(scriptname,"r");
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
+ if (rsfp)
+ fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
#endif
}
- if ((FILE*)rsfp == Nullfp) {
+ if (e_tmpname) {
+ e_fp = rsfp;
+ }
+ if (!rsfp) {
#ifdef DOSUID
#ifndef IAMSUID /* in case script is not readable before setuid */
if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
statbuf.st_mode & (S_ISUID|S_ISGID)) {
- (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
- execv(buf, origargv); /* try again */
+ /* try again */
+ execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
croak("Can't do setuid\n");
}
#endif
@@ -1548,9 +2000,9 @@ char *scriptname;
*/
#ifdef DOSUID
- char *s;
+ char *s, *s2;
- if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
+ if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
croak("Can't stat script \"%s\"",origfilename);
if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
@@ -1590,15 +2042,15 @@ char *scriptname;
croak("Permission denied"); /* testing full pathname here */
if (tmpstatbuf.st_dev != statbuf.st_dev ||
tmpstatbuf.st_ino != statbuf.st_ino) {
- (void)fclose(rsfp);
+ (void)PerlIO_close(rsfp);
if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
- fprintf(rsfp,
-"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
-(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
- uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
- statbuf.st_dev, statbuf.st_ino,
+ PerlIO_printf(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)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
+ (long)statbuf.st_dev, (long)statbuf.st_ino,
SvPVX(GvSV(curcop->cop_filegv)),
- statbuf.st_uid, statbuf.st_gid);
+ (long)statbuf.st_uid, (long)statbuf.st_gid);
(void)my_pclose(rsfp);
}
croak("Permission denied\n");
@@ -1625,13 +2077,15 @@ char *scriptname;
croak("Setuid/gid script is writable by world");
doswitches = FALSE; /* -s is insecure in suid */
curcop->cop_line++;
- if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
- strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
+ if (sv_gets(linestr, rsfp, 0) == Nullch ||
+ strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
croak("No #! line");
- s = tokenbuf+2;
+ s = SvPV(linestr,na)+2;
if (*s == ' ') s++;
while (!isSPACE(*s)) s++;
- if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
+ for (s2 = s; (s2 > SvPV(linestr,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++;
/*
@@ -1653,10 +2107,10 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#endif /* IAMSUID */
if (euid) { /* oops, we're not the setuid root perl */
- (void)fclose(rsfp);
+ (void)PerlIO_close(rsfp);
#ifndef IAMSUID
- (void)sprintf(buf, "%s/sperl%s", BIN, patchlevel);
- execv(buf, origargv); /* try again */
+ /* try again */
+ execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
#endif
croak("Can't do setuid\n");
}
@@ -1728,25 +2182,23 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\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.) */
- rewind(rsfp);
+ PerlIO_rewind(rsfp);
+ lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
if (!origargv[which])
croak("Permission denied");
- (void)sprintf(buf, "/dev/fd/%d/%.127s", fileno(rsfp), origargv[which]);
- origargv[which] = buf;
-
+ origargv[which] = savepv(form("/dev/fd/%d/%s",
+ PerlIO_fileno(rsfp), origargv[which]));
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
+ fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
#endif
-
- (void)sprintf(tokenbuf, "%s/perl%s", BIN, patchlevel);
- execv(tokenbuf, origargv); /* try again */
+ execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
croak("Can't do setuid\n");
#endif /* IAMSUID */
#else /* !DOSUID */
if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
- Fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
+ Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
||
(egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
@@ -1763,21 +2215,25 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
static void
find_beginning()
{
- register char *s;
+ register char *s, *s2;
/* skip forward in input to the real script? */
- taint_not("-x");
+ forbid_setid("-x");
while (doextract) {
if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
croak("No Perl script found in input\n");
- if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
- ungetc('\n',rsfp); /* to keep line count right */
+ if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
+ PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
doextract = FALSE;
- if (s = instr(s,"perl -")) {
- s += 6;
- /*SUPPRESS 530*/
- while (s = moreswitches(s)) ;
+ 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 (cddir && chdir(cddir) < 0)
croak("Can't chdir to %s",cddir);
@@ -1800,6 +2256,16 @@ init_ids()
}
static void
+forbid_setid(s)
+char *s;
+{
+ if (euid != uid)
+ croak("No %s allowed while running setuid", s);
+ if (egid != gid)
+ croak("No %s allowed while running setgid", s);
+}
+
+static void
init_debugger()
{
curstash = debstash;
@@ -1820,31 +2286,15 @@ init_debugger()
static void
init_stacks()
{
- stack = newAV();
- mainstack = stack; /* remember in case we switch stacks */
- AvREAL_off(stack); /* not a real array */
- av_extend(stack,127);
+ curstack = newAV();
+ mainstack = curstack; /* remember in case we switch stacks */
+ AvREAL_off(curstack); /* not a real array */
+ av_extend(curstack,127);
- stack_base = AvARRAY(stack);
+ stack_base = AvARRAY(curstack);
stack_sp = stack_base;
stack_max = stack_base + 127;
- New(54,markstack,64,I32);
- markstack_ptr = markstack;
- markstack_max = markstack + 64;
-
- New(54,scopestack,32,I32);
- scopestack_ix = 0;
- scopestack_max = 32;
-
- New(54,savestack,128,ANY);
- savestack_ix = 0;
- savestack_max = 128;
-
- New(54,retstack,16,OP*);
- retstack_ix = 0;
- retstack_max = 16;
-
cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
New(50,cxstack,cxstack_max + 1,CONTEXT);
cxstack_ix = -1;
@@ -1857,14 +2307,63 @@ init_stacks()
New(51,debname,128,char);
New(52,debdelim,128,char);
} )
+
+ /*
+ * The following stacks almost certainly should be per-interpreter,
+ * but for now they're not. XXX
+ */
+
+ if (markstack) {
+ markstack_ptr = markstack;
+ } else {
+ New(54,markstack,64,I32);
+ markstack_ptr = markstack;
+ markstack_max = markstack + 64;
+ }
+
+ if (scopestack) {
+ scopestack_ix = 0;
+ } else {
+ New(54,scopestack,32,I32);
+ scopestack_ix = 0;
+ scopestack_max = 32;
+ }
+
+ if (savestack) {
+ savestack_ix = 0;
+ } else {
+ New(54,savestack,128,ANY);
+ savestack_ix = 0;
+ savestack_max = 128;
+ }
+
+ if (retstack) {
+ retstack_ix = 0;
+ } else {
+ New(54,retstack,16,OP*);
+ retstack_ix = 0;
+ retstack_max = 16;
+ }
+}
+
+static void
+nuke_stacks()
+{
+ Safefree(cxstack);
+ Safefree(tmps_stack);
+ DEBUG( {
+ Safefree(debname);
+ Safefree(debdelim);
+ } )
}
-static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
+static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
+
static void
init_lexer()
{
tmpfp = rsfp;
-
+ rsfp = Nullfp;
lex_start(linestr);
rsfp = tmpfp;
subname = newSVpv("main",4);
@@ -1880,14 +2379,14 @@ init_predump_symbols()
stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
GvMULTI_on(stdingv);
- IoIFP(GvIOp(stdingv)) = stdin;
+ IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(stdingv));
tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
GvMULTI_on(tmpgv);
- IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = stdout;
+ IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
setdefout(tmpgv);
tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
@@ -1895,14 +2394,15 @@ init_predump_symbols()
othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
GvMULTI_on(othergv);
- IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = stderr;
+ 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));
statname = NEWSV(66,0); /* last filename we did stat on */
- osname = savepv(OSNAME);
+ if (!osname)
+ osname = savepv(OSNAME);
}
static void
@@ -1940,13 +2440,11 @@ register char **env;
sv_setpvn(bodytarget, "", 0);
formtarget = bodytarget;
- tainted = 1;
+ TAINT;
if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
sv_setpv(GvSV(tmpgv),origfilename);
magicname("0", "0", 1);
}
- if (tmpgv = gv_fetchpv("\024",TRUE, SVt_PV))
- time(&basetime);
if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
sv_setpv(GvSV(tmpgv),origargv[0]);
if (argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
@@ -1961,7 +2459,7 @@ register char **env;
HV *hv;
GvMULTI_on(envgv);
hv = GvHVn(envgv);
- hv_clear(hv);
+ hv_magic(hv, 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
@@ -1970,29 +2468,31 @@ register char **env;
*/
if (!env)
env = environ;
- if (env != environ) {
+ if (env != environ)
environ[0] = Nullch;
- hv_magic(hv, envgv, 'E');
- }
for (; *env; env++) {
if (!(s = strchr(*env,'=')))
continue;
*s++ = '\0';
+#ifdef WIN32
+ (void)strupr(*env);
+#endif
sv = newSVpv(s--,0);
- sv_magic(sv, sv, 'e', *env, s - *env);
(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)putenv(savepv(*env));
+#endif
}
#endif
#ifdef DYNAMIC_ENV_FETCH
HvNAME(hv) = savepv(ENV_HV_NAME);
#endif
- hv_magic(hv, envgv, 'E');
}
- tainted = 0;
+ TAINT_NOT;
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv),(I32)getpid());
-
+ sv_setiv(GvSV(tmpgv), (IV)getpid());
}
static void
@@ -2000,86 +2500,208 @@ init_perllib()
{
char *s;
if (!tainting) {
+#ifndef VMS
s = getenv("PERL5LIB");
if (s)
- incpush(s);
+ incpush(s, TRUE);
else
- incpush(getenv("PERLLIB"));
+ incpush(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 SITELIB and OLDARCHLIB
+*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP);
+ incpush(APPLLIB_EXP, FALSE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP);
+ incpush(ARCHLIB_EXP, FALSE);
#endif
#ifndef PRIVLIB_EXP
#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
- incpush(PRIVLIB_EXP);
+ incpush(PRIVLIB_EXP, FALSE);
#ifdef SITEARCH_EXP
- incpush(SITEARCH_EXP);
+ incpush(SITEARCH_EXP, FALSE);
#endif
#ifdef SITELIB_EXP
- incpush(SITELIB_EXP);
+ incpush(SITELIB_EXP, FALSE);
#endif
#ifdef OLDARCHLIB_EXP /* 5.00[01] compatibility */
- incpush(OLDARCHLIB_EXP);
+ incpush(OLDARCHLIB_EXP, FALSE);
#endif
if (!tainting)
- incpush(".");
+ 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(p, addsubdirs)
+char *p;
+int addsubdirs;
+{
+ SV *subdir = Nullsv;
+ static char *archpat_auto;
+
+ if (!p)
+ return;
+
+ if (addsubdirs) {
+ subdir = newSV(0);
+ if (!archpat_auto) {
+ STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
+ + sizeof("//auto"));
+ New(55, archpat_auto, len, char);
+ sprintf(archpat_auto, "/%s/%s/auto", ARCHNAME, patchlevel);
+#ifdef VMS
+ for (len = sizeof(ARCHNAME) + 2;
+ archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
+ if (archpat_auto[len] == '.') archpat_auto[len] = '_';
+#endif
+ }
+ }
+
+ /* Break at all separators */
+ while (p && *p) {
+ SV *libdir = newSV(0);
+ char *s;
+
+ /* skip any consecutive separators */
+ while ( *p == PERLLIB_SEP ) {
+ /* Uncomment the next line for PATH semantics */
+ /* av_push(GvAVn(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,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,na));
+#endif
+ /* .../archname/version if -d .../archname/version/auto */
+ sv_setsv(subdir, libdir);
+ sv_catpv(subdir, archpat_auto);
+ if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(incgv),
+ newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+
+ /* .../archname if -d .../archname/auto */
+ sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
+ strlen(patchlevel) + 1, "", 0);
+ if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode))
+ av_push(GvAVn(incgv),
+ newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ }
+
+ /* finally push this lib directory on the end of @INC */
+ av_push(GvAVn(incgv), libdir);
+ }
+
+ SvREFCNT_dec(subdir);
}
void
-calllist(list)
+call_list(oldscope, list)
+I32 oldscope;
AV* list;
{
- Sigjmp_buf oldtop;
- STRLEN len;
line_t oldline = curcop->cop_line;
-
- Copy(top_env, oldtop, 1, Sigjmp_buf);
+ STRLEN len;
+ dJMPENV;
+ int ret;
while (AvFILL(list) >= 0) {
CV *cv = (CV*)av_shift(list);
SAVEFREESV(cv);
- switch (Sigsetjmp(top_env,1)) {
+ JMPENV_PUSH(ret);
+ switch (ret) {
case 0: {
SV* atsv = GvSV(errgv);
PUSHMARK(stack_sp);
perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
(void)SvPV(atsv, len);
if (len) {
- Copy(oldtop, top_env, 1, Sigjmp_buf);
+ JMPENV_POP;
curcop = &compiling;
curcop->cop_line = oldline;
if (list == beginav)
sv_catpv(atsv, "BEGIN failed--compilation aborted");
else
sv_catpv(atsv, "END failed--cleanup aborted");
+ while (scopestack_ix > oldscope)
+ LEAVE;
croak("%s", SvPVX(atsv));
}
}
break;
case 1:
-#ifdef VMS
- statusvalue = 255; /* XXX I don't think we use 1 anymore. */
-#else
- statusvalue = 1;
-#endif
+ STATUS_ALL_FAILURE;
/* FALL THROUGH */
case 2:
/* my_exit() was called */
+ while (scopestack_ix > oldscope)
+ LEAVE;
+ FREETMPS;
curstash = defstash;
if (endav)
- calllist(endav);
- FREETMPS;
- Copy(oldtop, top_env, 1, Sigjmp_buf);
+ call_list(oldscope, endav);
+ JMPENV_POP;
curcop = &compiling;
curcop->cop_line = oldline;
if (statusvalue) {
@@ -2088,22 +2710,87 @@ AV* list;
else
croak("END failed--cleanup aborted");
}
- my_exit(statusvalue);
+ my_exit_jump();
/* NOTREACHED */
- return;
case 3:
if (!restartop) {
- fprintf(stderr, "panic: restartop\n");
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
FREETMPS;
break;
}
- Copy(oldtop, top_env, 1, Sigjmp_buf);
+ JMPENV_POP;
curcop = &compiling;
curcop->cop_line = oldline;
- Siglongjmp(top_env, 3);
+ JMPENV_JUMP(3);
}
+ JMPENV_POP;
}
+}
- Copy(oldtop, top_env, 1, Sigjmp_buf);
+void
+my_exit(status)
+U32 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()
+{
+#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
+ if (errno & 255)
+ STATUS_POSIX_SET(errno);
+ else if (STATUS_POSIX == 0)
+ STATUS_POSIX_SET(255);
+#endif
+ my_exit_jump();
+}
+
+static void
+my_exit_jump()
+{
+ register CONTEXT *cx;
+ I32 gimme;
+ SV **newsp;
+
+ if (e_tmpname) {
+ if (e_fp) {
+ PerlIO_close(e_fp);
+ e_fp = Nullfp;
+ }
+ (void)UNLINK(e_tmpname);
+ Safefree(e_tmpname);
+ e_tmpname = Nullch;
+ }
+
+ if (cxstack_ix >= 0) {
+ if (cxstack_ix > 0)
+ dounwind(0);
+ POPBLOCK(cx,curpm);
+ LEAVE;
+ }
+
+ JMPENV_JUMP(2);
+}
diff --git a/gnu/usr.bin/perl/perl.h b/gnu/usr.bin/perl/perl.h
index bfb921034c8..fefceeda816 100644
--- a/gnu/usr.bin/perl/perl.h
+++ b/gnu/usr.bin/perl/perl.h
@@ -1,6 +1,6 @@
/* perl.h
*
- * Copyright (c) 1987-1994, Larry Wall
+ * 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.
@@ -10,6 +10,25 @@
#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 */
+
+#define VOIDUSED 1
+#include "config.h"
+
+#include "embed.h"
+
/*
* STMT_START { statements; } STMT_END;
* can be used as a single statement, as in
@@ -18,7 +37,7 @@
* Trying to select a version that gives no warnings...
*/
#if !(defined(STMT_START) && defined(STMT_END))
-# if defined(__GNUC__) && !defined(__STRICT_ANSI__)
+# if defined(__GNUC__) && !defined(__STRICT_ANSI__) && !defined(__cplusplus)
# define STMT_START (void)( /* gcc supports ``({ STATEMENTS; })'' */
# define STMT_END )
# else
@@ -33,10 +52,15 @@
# endif
#endif
-#include "embed.h"
-
-#define VOIDUSED 1
-#include "config.h"
+/*
+ * 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
# define BYTEORDER 0x1234
@@ -56,7 +80,7 @@
*/
/* define this once if either system, instead of cluttering up the src */
-#if defined(MSDOS) || defined(atarist)
+#if defined(MSDOS) || defined(atarist) || defined(WIN32)
#define DOSISH 1
#endif
@@ -64,6 +88,10 @@
# define STANDARD_C 1
#endif
+#if defined(__cplusplus) || defined(WIN32)
+# define DONT_DECLARE_STD 1
+#endif
+
#if defined(HASVOLATILE) || defined(STANDARD_C)
# ifdef __cplusplus
# define VOL // to temporarily suppress warnings
@@ -74,47 +102,117 @@
# define VOL
#endif
-#define TAINT_IF(c) (tainted |= (c))
-#define TAINT_NOT (tainted = 0)
-#define TAINT_PROPER(s) if (tainting) taint_proper(no_security, s)
-#define TAINT_ENV() if (tainting) taint_env()
+#define TAINT (tainted = TRUE)
+#define TAINT_NOT (tainted = FALSE)
+#define TAINT_IF(c) if (c) { tainted = TRUE; }
+#define TAINT_ENV() if (tainting) { taint_env(); }
+#define TAINT_PROPER(s) if (tainting) { taint_proper(no_security, s); }
-#ifdef USE_BSDPGRP
-# ifdef HAS_GETPGRP
-# define BSD_GETPGRP(pid) getpgrp((pid))
-# endif
-# ifdef HAS_SETPGRP
-# define BSD_SETPGRP(pid, pgrp) setpgrp((pid), (pgrp))
-# endif
+/* 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
-# ifdef HAS_GETPGRP2
-# define BSD_GETPGRP(pid) getpgrp2((pid))
-# ifndef HAS_GETPGRP
-# define HAS_GETPGRP
-# endif
-# endif
-# ifdef HAS_SETPGRP2
-# define BSD_SETPGRP(pid, pgrp) setpgrp2((pid), (pgrp))
-# ifndef HAS_SETPGRP
-# define HAS_SETPGRP
-# endif
+# 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
-#include <stdio.h>
+#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 "perlio.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>
-#else
+#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>
+# include <locale.h>
#endif
-#ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */
-#undef METHOD
-#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>
@@ -129,25 +227,46 @@
/* Use all the "standard" definitions? */
#if defined(STANDARD_C) && defined(I_STDLIB)
# include <stdlib.h>
-#endif /* STANDARD_C */
+#endif
+
+/* 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. */
-/* Maybe 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. I guess. The patch had no explanation.
-*/
#ifdef MYMALLOC
+
# ifdef HIDEMYMALLOC
-# define malloc Mymalloc
+# define malloc Mymalloc
+# define calloc Mycalloc
# define realloc Myremalloc
-# define free Myfree
+# define free Myfree
# endif
-# define safemalloc malloc
+# ifdef EMBEDMYMALLOC
+# define malloc Perl_malloc
+# define calloc Perl_calloc
+# define realloc Perl_realloc
+# define free Perl_free
+# endif
+
+# undef safemalloc
+# undef safecalloc
+# undef saferealloc
+# undef safefree
+# define safemalloc malloc
+# define safecalloc calloc
# define saferealloc realloc
-# define safefree free
-#endif
+# define safefree free
+
+#endif /* MYMALLOC */
#define MEM_SIZE Size_t
+#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
@@ -159,10 +278,6 @@
#define strrchr rindex
#endif
-#if defined(mips) && defined(ultrix) && !defined(__STDC__)
-# undef HAS_MEMCMP
-#endif
-
#ifdef I_MEMORY
# include <memory.h>
#endif
@@ -189,60 +304,71 @@
extern char *memset _((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)
+# 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 memzero(d,l) my_bzero(d,l)
+# define memmove(d,s,l) my_bcopy(s,d,l)
# endif
# endif
-#endif /* HAS_MEMSET */
+#endif
+
+#if defined(mips) && defined(ultrix) && !defined(__STDC__)
+# undef HAS_MEMCMP
+#endif
-#ifdef HAS_MEMCMP
+#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 */
-
-/* XXX we prefer bcmp slightly for comparisons that don't care about ordering */
-#ifndef HAS_BCMP
-# ifndef bcmp
-# define bcmp(s1,s2,l) memcmp(s1,s2,l)
-# endif
-#endif /* HAS_BCMP */
+#endif /* HAS_MEMCMP && HAS_SANE_MEMCMP */
-#if !defined(HAS_MEMMOVE) && !defined(memmove)
-# if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
-# define memmove(d,s,l) bcopy(s,d,l)
+#ifndef memzero
+# ifdef HAS_MEMSET
+# define memzero(d,l) memset(d,0,l)
# else
-# if defined(HAS_MEMCPY) && defined(HAS_SAFE_MEMCPY)
-# define memmove(d,s,l) memcpy(d,s,l)
+# ifdef HAS_BZERO
+# define memzero(d,l) bzero(d,l)
# else
-# define memmove(d,s,l) my_bcopy(s,d,l)
+# define memzero(d,l) my_bzero(d,l)
# endif
# 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>
+#ifndef HAS_BCMP
+# ifndef bcmp
+# define bcmp(s1,s2,l) memcmp(s1,s2,l)
# endif
-#endif
+#endif /* !HAS_BCMP */
#ifdef I_NETINET_IN
# include <netinet/in.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>
+# include <sys/stat.h>
#endif
/* The stat macros for Amdahl UTS, Unisoft System V/88 (and derivatives
@@ -277,10 +403,8 @@
# endif
#endif
-#ifndef MSDOS
-# if defined(HAS_TIMES) && defined(I_SYS_TIMES)
+#if defined(HAS_TIMES) && defined(I_SYS_TIMES)
# include <sys/times.h>
-# endif
#endif
#if defined(HAS_STRERROR) && (!defined(HAS_MKDIR) || !defined(HAS_RMDIR))
@@ -299,27 +423,28 @@
# include <net/errno.h>
# endif
#endif
-#ifndef VMS
-# define FIXSTATUS(sts) (U_L((sts) & 0xffff))
-# define SHIFTSTATUS(sts) ((sts) >> 8)
-# define SETERRNO(errcode,vmserrcode) errno = (errcode)
+
+#ifdef VMS
+# define SETERRNO(errcode,vmserrcode) \
+ STMT_START { \
+ set_errno(errcode); \
+ set_vaxc_errno(vmserrcode); \
+ } STMT_END
#else
-# define FIXSTATUS(sts) (U_L(sts))
-# define SHIFTSTATUS(sts) (sts)
-# define SETERRNO(errcode,vmserrcode) STMT_START {set_errno(errcode); set_vaxc_errno(vmserrcode);} STMT_END
+# define SETERRNO(errcode,vmserrcode) errno = (errcode)
#endif
-#ifndef MSDOS
-# ifndef errno
+#ifndef errno
extern int errno; /* ANSI allows errno to be an lvalue expr */
-# endif
#endif
#ifdef HAS_STRERROR
# ifdef VMS
char *strerror _((int,...));
# else
+#ifndef DONT_DECLARE_STD
char *strerror _((int));
+#endif
# endif
# ifndef Strerror
# define Strerror strerror
@@ -493,29 +618,231 @@
# define SLOPPYDIVIDE
#endif
-#if defined(cray) || defined(convex) || defined (uts) || BYTEORDER > 0xffff
-# define HAS_QUAD
-#endif
-
#ifdef UV
#undef UV
#endif
-#ifdef HAS_QUAD
-# ifdef cray
-# define Quad_t int
+/* 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 defined(convex) || defined (uts)
-# define Quad_t long long
-# else
+# if BYTEORDER > 0xFFFF
# define Quad_t long
# endif
# 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
+# define PERL_USHORT_MAX ((unsigned short)~(unsigned)0)
+# 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
+# define PERL_SHORT_MAX ((short) (PERL_USHORT_MAX >> 1))
+# endif
+#endif
+
+#ifdef SHORT_MIN
+# define PERL_SHORT_MIN ((short)SHORT_MIN)
+#else
+# ifdef MINSHORT
+# define PERL_SHORT_MIN ((short)MINSHORT)
+# else
+# define PERL_SHORT_MIN (-PERL_SHORT_MAX - ((3 & -1) == 3))
+# 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;
@@ -535,14 +862,16 @@ typedef struct loop LOOP;
typedef struct Outrec Outrec;
typedef struct interpreter PerlInterpreter;
-typedef struct ff FF;
+#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 sv GV;
+typedef struct gv GV;
typedef struct io IO;
typedef struct context CONTEXT;
typedef struct block BLOCK;
@@ -551,6 +880,7 @@ 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;
@@ -581,12 +911,71 @@ typedef I32 (*filter_t) _((int, SV *, int));
# if defined(VMS)
# include "vmsish.h"
# else
-# include "unixish.h"
+# if defined(PLAN9)
+# include "./plan9/plan9ish.h"
+# else
+# include "unixish.h"
+# endif
# endif
#endif
-
-#ifndef HAS_PAUSE
-#define pause() sleep((32767<<16)+32767)
+
+#ifdef VMS
+# define STATUS_NATIVE statusvalue_vms
+# define STATUS_NATIVE_EXPORT \
+ ((I32)statusvalue_vms == -1 ? 44 : statusvalue_vms)
+# define STATUS_NATIVE_SET(n) \
+ STMT_START { \
+ statusvalue_vms = (n); \
+ if ((I32)statusvalue_vms == -1) \
+ statusvalue = -1; \
+ else if (statusvalue_vms & STS$M_SUCCESS) \
+ statusvalue = 0; \
+ else if ((statusvalue_vms & STS$M_SEVERITY) == 0) \
+ statusvalue = 1 << 8; \
+ else \
+ statusvalue = (statusvalue_vms & STS$M_SEVERITY) << 8; \
+ } STMT_END
+# define STATUS_POSIX 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 { \
+ statusvalue = (n); \
+ if (statusvalue != -1) { \
+ statusvalue &= 0xFFFF; \
+ statusvalue_vms = statusvalue ? 44 : 1; \
+ } \
+ else statusvalue_vms = -1; \
+ } STMT_END
+# define STATUS_ALL_SUCCESS (statusvalue = 0, statusvalue_vms = 1)
+# define STATUS_ALL_FAILURE (statusvalue = 1, 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 statusvalue
+# define STATUS_POSIX_SET(n) \
+ STMT_START { \
+ statusvalue = (n); \
+ if (statusvalue != -1) \
+ statusvalue &= 0xFFFF; \
+ } STMT_END
+# define STATUS_CURRENT STATUS_POSIX
+# define STATUS_ALL_SUCCESS (statusvalue = 0)
+# define STATUS_ALL_FAILURE (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
@@ -607,6 +996,11 @@ union any {
void (*any_dptr) _((void*));
};
+/* 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"
@@ -689,7 +1083,13 @@ EXT char Error[1];
#define U_I(what) ((unsigned int)(what))
#define U_L(what) ((U32)(what))
#else
+# ifdef __cplusplus
+ extern "C" {
+# endif
U32 cast_ulong _((double));
+# ifdef __cplusplus
+ }
+# endif
#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)))
@@ -700,11 +1100,17 @@ U32 cast_ulong _((double));
#define I_V(what) ((IV)(what))
#define U_V(what) ((UV)(what))
#else
+# ifdef __cplusplus
+ extern "C" {
+# endif
I32 cast_i32 _((double));
-#define I_32(what) (cast_i32((double)(what)))
IV cast_iv _((double));
-#define I_V(what) (cast_iv((double)(what)))
UV cast_uv _((double));
+# ifdef __cplusplus
+ }
+# endif
+#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
@@ -730,6 +1136,9 @@ Gid_t getegid _((void));
#endif
#ifdef DEBUGGING
+#ifndef Perl_debug_log
+#define Perl_debug_log PerlIO_stderr()
+#endif
#define YYDEBUG 1
#define DEB(a) a
#define DEBUG(a) if (debug) a
@@ -740,7 +1149,7 @@ Gid_t getegid _((void));
#define DEBUG_o(a) if (debug & 16) a
#define DEBUG_c(a) if (debug & 32) a
#define DEBUG_P(a) if (debug & 64) a
-#define DEBUG_m(a) if (debug & 128) a
+#define DEBUG_m(a) if (curinterp && debug & 128) a
#define DEBUG_f(a) if (debug & 256) a
#define DEBUG_r(a) if (debug & 512) a
#define DEBUG_x(a) if (debug & 1024) a
@@ -771,12 +1180,14 @@ Gid_t getegid _((void));
#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__); \
exit(1); \
}})
+#endif
struct ufuncs {
I32 (*uf_val)_((IV, SV*));
@@ -785,7 +1196,7 @@ struct ufuncs {
};
/* Fix these up for __STDC__ */
-#ifndef __cplusplus
+#ifndef DONT_DECLARE_STD
char *mktemp _((char*));
double atof _((const char*));
#endif
@@ -807,7 +1218,10 @@ char *strcpy(), *strcat();
# endif
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));
@@ -819,9 +1233,17 @@ char *strcpy(), *strcat();
#endif
#ifndef __cplusplus
+#ifdef __NeXT__ /* or whatever catches all NeXTs */
+char *crypt (); /* Maybe more hosts will need the unprototyped version */
+#else
char *crypt _((const char*, const char*));
+#endif
+#ifndef DONT_DECLARE_STD
+#ifndef getenv
char *getenv _((const char*));
+#endif
Off_t lseek _((int,Off_t,int));
+#endif
char *getlogin _((void));
#endif
@@ -845,6 +1267,14 @@ I32 unlnk _((char*));
# 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
@@ -853,9 +1283,6 @@ I32 unlnk _((char*));
# ifndef register
# define register
# endif
-# ifdef MYMALLOC
-# define DEBUGGING_MSTATS
-# endif
# define PAD_SV(po) pad_sv(po)
#else
# define PAD_SV(po) curpad[po]
@@ -867,9 +1294,20 @@ I32 unlnk _((char*));
/* global state */
EXT PerlInterpreter * curinterp; /* currently running interpreter */
-#ifndef VMS /* VMS doesn't use environ array */
+/* VMS doesn't use environ array and NeXT has problems with crt0.o globals */
+#if !defined(VMS) && !(defined(NeXT) && defined(__DYNAMIC__))
+#ifndef DONT_DECLARE_STD
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 */
+
EXT int uid; /* current real user id */
EXT int euid; /* current effective user id */
EXT int gid; /* current real group id */
@@ -882,9 +1320,11 @@ EXT U32 evalseq; /* eval sequence number */
EXT U32 sub_generation; /* inc to force methods to be looked up again */
EXT char ** origenviron;
EXT U32 origalen;
+EXT HV * pidstatus; /* pid-to-status mappings for waitpid */
EXT U32 * profiledata;
EXT int maxo INIT(MAXO);/* Number of ops */
EXT char * osname; /* operating system */
+EXT char * sh_path INIT(SH_PATH); /* full path of shell */
EXT XPV* xiv_arenaroot; /* list of allocated xiv areas */
EXT IV ** xiv_root; /* free xiv list--shared by interpreters */
@@ -925,7 +1365,6 @@ EXT SV ** curpad;
/* temp space */
EXT SV * Sv;
EXT XPV * Xpv;
-EXT char buf[2048]; /* should be longer than PATH_MAX */
EXT char tokenbuf[256];
EXT struct stat statbuf;
#ifdef HAS_TIMES
@@ -939,43 +1378,43 @@ EXT short * ds;
EXT char * dc;
/* handy constants */
-EXT char * Yes INIT("1");
-EXT char * No INIT("");
-EXT char * hexdigit INIT("0123456789abcdef0123456789ABCDEFx");
-EXT char * patleave INIT("\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}");
-EXT char * vert INIT("|");
+EXTCONST char * Yes INIT("1");
+EXTCONST char * No INIT("");
+EXTCONST char * hexdigit INIT("0123456789abcdef0123456789ABCDEFx");
+EXTCONST char * patleave INIT("\\.^$@dDwWsSbB+*?|()-nrtfeaxc0123456789[{]}");
+EXTCONST char * vert INIT("|");
-EXT char warn_uninit[]
+EXTCONST char warn_uninit[]
INIT("Use of uninitialized value");
-EXT char warn_nosemi[]
+EXTCONST char warn_nosemi[]
INIT("Semicolon seems to be missing");
-EXT char warn_reserved[]
+EXTCONST char warn_reserved[]
INIT("Unquoted string \"%s\" may clash with future reserved word");
-EXT char warn_nl[]
+EXTCONST char warn_nl[]
INIT("Unsuccessful %s on filename containing newline");
-EXT char no_wrongref[]
+EXTCONST char no_wrongref[]
INIT("Can't use %s ref as %s ref");
-EXT char no_symref[]
+EXTCONST char no_symref[]
INIT("Can't use string (\"%.32s\") as %s ref while \"strict refs\" in use");
-EXT char no_usym[]
+EXTCONST char no_usym[]
INIT("Can't use an undefined value as %s reference");
-EXT char no_aelem[]
+EXTCONST char no_aelem[]
INIT("Modification of non-creatable array value attempted, subscript %d");
-EXT char no_helem[]
+EXTCONST char no_helem[]
INIT("Modification of non-creatable hash value attempted, subscript \"%s\"");
-EXT char no_modify[]
+EXTCONST char no_modify[]
INIT("Modification of a read-only value attempted");
-EXT char no_mem[]
+EXTCONST char no_mem[]
INIT("Out of memory!\n");
-EXT char no_security[]
+EXTCONST char no_security[]
INIT("Insecure dependency in %s%s");
-EXT char no_sock_func[]
+EXTCONST char no_sock_func[]
INIT("Unsupported socket function \"%s\" called");
-EXT char no_dir_func[]
+EXTCONST char no_dir_func[]
INIT("Unsupported directory function \"%s\" called");
-EXT char no_func[]
+EXTCONST char no_func[]
INIT("The %s function is unimplemented");
-EXT char no_myglob[]
+EXTCONST char no_myglob[]
INIT("\"my\" variable %s can't be in a package");
EXT SV sv_undef;
@@ -989,13 +1428,58 @@ EXT SV sv_yes;
#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
+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
+};
+#else
+EXTCONST unsigned char fold[];
#endif
#ifdef DOINIT
-EXT unsigned char fold[] = { /* fast case folding table */
+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,
@@ -1030,11 +1514,11 @@ EXT unsigned char fold[] = { /* fast case folding table */
248, 249, 250, 251, 252, 253, 254, 255
};
#else
-EXT unsigned char fold[];
+EXT unsigned char fold_locale[];
#endif
#ifdef DOINIT
-EXT unsigned char freq[] = { /* letter frequencies for mixed English/C */
+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,
@@ -1069,12 +1553,12 @@ EXT unsigned char freq[] = { /* letter frequencies for mixed English/C */
138, 139, 141, 142, 143, 144, 145, 146
};
#else
-EXT unsigned char freq[];
+EXTCONST unsigned char freq[];
#endif
#ifdef DEBUGGING
#ifdef DOINIT
-EXT char* block_type[] = {
+EXTCONST char* block_type[] = {
"NULL",
"SUB",
"EVAL",
@@ -1083,7 +1567,7 @@ EXT char* block_type[] = {
"BLOCK",
};
#else
-EXT char* block_type[];
+EXTCONST char* block_type[];
#endif
#endif
@@ -1094,6 +1578,8 @@ EXT char* block_type[];
#include "perly.h"
+#define LEX_NOTPARSING 11 /* borrowed from toke.c */
+
typedef enum {
XOPERATOR,
XTERM,
@@ -1125,7 +1611,7 @@ EXT YYSTYPE nextval[5]; /* value of next token, if any */
EXT I32 nexttype[5]; /* type of next token */
EXT I32 nexttoke;
-EXT FILE * VOL rsfp INIT(Nullfp);
+EXT PerlIO * VOL rsfp INIT(Nullfp);
EXT SV * linestr;
EXT char * bufptr;
EXT char * oldbufptr;
@@ -1148,6 +1634,7 @@ EXT CV * compcv; /* currently compiling subroutine */
EXT AV * comppad; /* storage for lexically scoped temporaries */
EXT AV * comppad_name; /* variable names for "my" variables */
EXT I32 comppad_name_fill;/* last "introduced" variable offset */
+EXT I32 comppad_name_floor;/* start of vars in innermost block */
EXT I32 min_intro_pending;/* start of vars to introduce */
EXT I32 max_intro_pending;/* end of vars to introduce */
EXT I32 padix; /* max used index in current "register" pad */
@@ -1174,6 +1661,7 @@ EXT U32 hints; /* various compilation flags */
#define HINT_BLOCK_SCOPE 0x00000100
#define HINT_STRICT_SUBS 0x00000200
#define HINT_STRICT_VARS 0x00000400
+#define HINT_LOCALE 0x00000800
/**************************************************************************/
/* This regexp stuff is global since it always happens within 1 expr eval */
@@ -1198,6 +1686,9 @@ EXT char * regtill; /* How far we are required to go. */
EXT U16 regflags; /* are we folding, multilining? */
EXT char regprev; /* char before regbol, \n if none */
+EXT bool do_undump; /* -u or dump seen? */
+EXT VOL U32 debug;
+
/***********************************************/
/* Global only to current interpreter instance */
/***********************************************/
@@ -1245,17 +1736,14 @@ IEXT bool Idowarn;
IEXT bool Idoextract;
IEXT bool Isawampersand; /* must save all match strings */
IEXT bool Isawstudy; /* do fbm_instr on all strings */
-IEXT bool Isawi; /* study must assume case insensitive */
IEXT bool Isawvec;
IEXT bool Iunsafe;
-IEXT bool Ido_undump; /* -u or dump seen? */
IEXT char * Iinplace;
IEXT char * Ie_tmpname;
-IEXT FILE * Ie_fp;
-IEXT VOL U32 Idebug;
+IEXT PerlIO * Ie_fp;
IEXT U32 Iperldb;
/* This value may be raised by extensions for testing purposes */
-IEXT int Iperl_destruct_level; /* 0=none, 1=full, 2=full with checks */
+IEXT int Iperl_destruct_level IINIT(0); /* 0=none, 1=full, 2=full with checks */
/* magical thingies */
IEXT Time_t Ibasetime; /* $^T */
@@ -1268,8 +1756,11 @@ IEXT char * Iors; /* $\ */
IEXT STRLEN Iorslen;
IEXT char * Iofmt; /* $# */
IEXT I32 Imaxsysfd IINIT(MAXSYSFD); /* top fd to pass to subprocesses */
-IEXT int Imultiline; /* $*--do strings hold >1 line? */
-IEXT U32 Istatusvalue; /* $? */
+IEXT int Imultiline; /* $*--do strings hold >1 line? */
+IEXT I32 Istatusvalue; /* $? */
+#ifdef VMS
+IEXT U32 Istatusvalue_vms;
+#endif
IEXT struct stat Istatcache; /* _ */
IEXT GV * Istatgv;
@@ -1313,8 +1804,7 @@ IEXT HV * Idebstash; /* symbol table for perldb package */
IEXT SV * Icurstname; /* name of current package */
IEXT AV * Ibeginav; /* names of BEGIN subroutines */
IEXT AV * Iendav; /* names of END subroutines */
-IEXT AV * Ipad; /* storage for lexically scoped temporaries */
-IEXT AV * Ipadname; /* variable names for "my" variables */
+IEXT HV * Istrtab; /* shared string table */
/* memory management */
IEXT SV ** Itmps_stack;
@@ -1333,7 +1823,6 @@ IEXT int Iforkprocess; /* so do_open |- can return proc# */
/* subprocess state */
IEXT AV * Ifdpid; /* keep fd-to-pid mappings for my_popen */
-IEXT HV * Ipidstatus; /* keep pid-to-status mappings for waitpid */
/* internal state */
IEXT VOL int Iin_eval; /* trap "fatal" errors? */
@@ -1360,15 +1849,17 @@ IEXT OP * Ieval_start;
/* runtime control stuff */
IEXT COP * VOL Icurcop IINIT(&compiling);
+IEXT COP * Icurcopdb IINIT(NULL);
IEXT line_t Icopline IINIT(NOLINE);
IEXT CONTEXT * Icxstack;
IEXT I32 Icxstack_ix IINIT(-1);
IEXT I32 Icxstack_max IINIT(128);
-IEXT Sigjmp_buf Itop_env;
+IEXT JMPENV Istart_env; /* empty startup sigjmp() environment */
+IEXT JMPENV * Itop_env; /* ptr. to current sigjmp() environment */
IEXT I32 Irunlevel;
/* stack stuff */
-IEXT AV * Istack; /* THE STACK */
+IEXT AV * Icurstack; /* THE STACK */
IEXT AV * Imainstack; /* the stack when nothing funny is happening */
IEXT SV ** Imystack_base; /* stack->array_ary */
IEXT SV ** Imystack_sp; /* stack pointer now */
@@ -1400,6 +1891,7 @@ IEXT bool Ipreambled;
IEXT AV * Ipreambleav;
IEXT int Ilaststatval IINIT(-1);
IEXT I32 Ilaststype IINIT(OP_STAT);
+IEXT SV * Imess_sv;
#undef IEXT
#undef IINIT
@@ -1418,20 +1910,6 @@ struct interpreter {
extern "C" {
#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 "proto.h"
#ifdef EMBED
@@ -1449,17 +1927,22 @@ extern "C" {
/* The following must follow proto.h */
#ifdef DOINIT
+
EXT MGVTBL vtbl_sv = {magic_get,
magic_set,
magic_len,
0, 0};
-EXT MGVTBL vtbl_env = {0, 0, 0, 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 = {0, magic_setsig,
- 0, 0, 0};
+EXT MGVTBL vtbl_sigelem = {magic_getsig,
+ magic_setsig,
+ 0, magic_clearsig,
+ 0};
EXT MGVTBL vtbl_pack = {0, 0, 0, magic_wipepack,
0};
EXT MGVTBL vtbl_packelem = {magic_getpack,
@@ -1469,7 +1952,8 @@ EXT MGVTBL vtbl_packelem = {magic_getpack,
EXT MGVTBL vtbl_dbline = {0, magic_setdbline,
0, 0, 0};
EXT MGVTBL vtbl_isa = {0, magic_setisa,
- 0, 0, 0};
+ 0, magic_setisa,
+ 0};
EXT MGVTBL vtbl_isaelem = {0, magic_setisa,
0, 0, 0};
EXT MGVTBL vtbl_arylen = {magic_getarylen,
@@ -1480,6 +1964,8 @@ EXT MGVTBL vtbl_glob = {magic_getglob,
0, 0, 0};
EXT MGVTBL vtbl_mglob = {0, magic_setmglob,
0, 0, 0};
+EXT MGVTBL vtbl_nkeys = {0, magic_setnkeys,
+ 0, 0, 0};
EXT MGVTBL vtbl_taint = {magic_gettaint,magic_settaint,
0, 0, 0};
EXT MGVTBL vtbl_substr = {0, magic_setsubstr,
@@ -1491,9 +1977,19 @@ EXT MGVTBL vtbl_pos = {magic_getpos,
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};
+EXT MGVTBL vtbl_defelem = {magic_getdefelem,magic_setdefelem,
+ 0, 0, magic_freedefelem};
+
+#ifdef USE_LOCALE_COLLATE
+EXT MGVTBL vtbl_collxfrm = {0,
+ magic_setcollxfrm,
+ 0, 0, 0};
+#endif
#ifdef OVERLOAD
EXT MGVTBL vtbl_amagic = {0, magic_setamagic,
@@ -1502,7 +1998,8 @@ EXT MGVTBL vtbl_amagicelem = {0, magic_setamagic,
0, 0, magic_setamagic};
#endif /* OVERLOAD */
-#else
+#else /* !DOINIT */
+
EXT MGVTBL vtbl_sv;
EXT MGVTBL vtbl_env;
EXT MGVTBL vtbl_envelem;
@@ -1516,72 +2013,92 @@ 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;
+EXT MGVTBL vtbl_defelem;
+
+#ifdef USE_LOCALE_COLLATE
+EXT MGVTBL vtbl_collxfrm;
+#endif
#ifdef OVERLOAD
EXT MGVTBL vtbl_amagic;
EXT MGVTBL vtbl_amagicelem;
#endif /* OVERLOAD */
-#endif
+#endif /* !DOINIT */
#ifdef OVERLOAD
+
EXT long amagic_generation;
-#define NofAMmeth 29
+#define NofAMmeth 58
#ifdef DOINIT
-EXT char * AMG_names[NofAMmeth][2] = {
- {"fallback","abs"},
- {"bool", "nomethod"},
- {"\"\"", "0+"},
- {"+","+="},
- {"-","-="},
- {"*", "*="},
- {"/", "/="},
- {"%", "%="},
- {"**", "**="},
- {"<<", "<<="},
- {">>", ">>="},
- {"&", "&="},
- {"|", "|="},
- {"^", "^="},
- {"<", "<="},
- {">", ">="},
- {"==", "!="},
- {"<=>", "cmp"},
- {"lt", "le"},
- {"gt", "ge"},
- {"eq", "ne"},
- {"!", "~"},
- {"++", "--"},
- {"atan2", "cos"},
- {"sin", "exp"},
- {"log", "sqrt"},
- {"x","x="},
- {".",".="},
- {"=","neg"}
+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
-EXT char * AMG_names[NofAMmeth][2];
+EXTCONST char * AMG_names[NofAMmeth];
#endif /* def INITAMAGIC */
-struct am_table {
+struct am_table {
long was_ok_sub;
long was_ok_am;
- CV* table[NofAMmeth*2];
+ 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,
@@ -1613,6 +2130,96 @@ enum {
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 0xff
+#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 PERLDB_SUB (perldb && (perldb & PERLDBf_SUB))
+#define PERLDB_LINE (perldb && (perldb & PERLDBf_LINE))
+#define PERLDB_NOOPT (perldb && (perldb & PERLDBf_NOOPT))
+#define PERLDB_INTER (perldb && (perldb & PERLDBf_INTER))
+#define PERLDB_SUBLINE (perldb && (perldb & PERLDBf_SUBLINE))
+#define PERLDB_SINGLE (perldb && (perldb & PERLDBf_SINGLE))
+
+#ifdef USE_LOCALE_COLLATE
+EXT U32 collation_ix; /* Collation generation index */
+EXT char * collation_name; /* Name of current collation */
+EXT bool collation_standard INIT(TRUE); /* Assume simple collation */
+EXT Size_t collxfrm_base; /* Basic overhead in *xfrm() */
+EXT Size_t collxfrm_mult INIT(2); /* Expansion factor in *xfrm() */
+#endif /* USE_LOCALE_COLLATE */
+
+#ifdef USE_LOCALE_NUMERIC
+
+EXT char * numeric_name; /* Name of current numeric locale */
+EXT bool numeric_standard INIT(TRUE); /* Assume simple numerics */
+EXT bool numeric_local INIT(TRUE); /* Assume local numerics */
+
+#define SET_NUMERIC_STANDARD() \
+ STMT_START { \
+ if (! numeric_standard) \
+ perl_set_numeric_standard(); \
+ } STMT_END
+
+#define SET_NUMERIC_LOCAL() \
+ STMT_START { \
+ if (! 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(HAS_ATTRIBUTE)
+/*
+ * Now we have __attribute__ out of the way
+ * Remap printf
+ */
+#define printf PerlIO_stdoutf
+#endif
+
#endif /* Include guard */
+
diff --git a/gnu/usr.bin/perl/perl_exp.SH b/gnu/usr.bin/perl/perl_exp.SH
index 2e7bb20e082..06b587f9ef9 100644
--- a/gnu/usr.bin/perl/perl_exp.SH
+++ b/gnu/usr.bin/perl/perl_exp.SH
@@ -1,32 +1,84 @@
#!/bin/sh
-
+#
# Written: Nov 1994 Wayne Scott (wscott@ichips.intel.com)
-
+#
# Create the export list for perl.
# Needed by AIX to do dynamic linking.
+#
+# This simple program relys on 'global.sym' and other *.sym 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_ prefix because that's what embed.h sticks
+# in front of them. Variations depend on binary compatibility with
+# Perl 5.003.
+#
-# This simple program relys on 'global.sym' being up to date
-# with all of the global symbols that a dynamicly link library
-# might want to access.
-
-# All symbols have a Perl_ prefix because that's what embed.h
-# sticks in front of them.
+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
-sed -n '/^[A-Za-z]/ s/^/Perl_/p' global.sym >> perl.exp
+case "$bincompat3" in
+y*)
+ global=/tmp/exp$$g
+ interp=/tmp/exp$$i
+ compat3=/tmp/exp$$c
+ grep '^[A-Za-z]' global.sym | sort >$global
+ grep '^[A-Za-z]' interp.sym | sort >$interp
+ grep '^[A-Za-z]' compat3.sym | sort >$compat3
+ comm -23 $global $compat3 | sed 's/^/Perl_/' >> perl.exp
+ comm -12 $interp $compat3 | sed 's/^/Perl_/' >> perl.exp
+ comm -12 $global $compat3 >> perl.exp
+ comm -23 $interp $compat3 >> perl.exp
+ rm -f $global $interp $compat3
+ ;;
+*)
+ sed -n '/^[A-Za-z]/ s/^/Perl_/p' global.sym interp.sym >> perl.exp
+ ;;
+esac
+
+#
+# If we use the PerlIO abstraction layer, add its symbols
+#
+
+if [ $useperlio = "define" ]
+then
+ grep '^[A-Za-z]' perlio.sym >> perl.exp
+fi
-# also add symbols from interp.sym
-# They are only needed if -DMULTIPLICITY is not set but it
-# doesn't hurt to include them anyway.
-sed -n '/^[A-Za-z]/ p' interp.sym >> perl.exp
+#
+# Extra globals not included above (including a few that might
+# not actually be defined, but there's no harm in that).
+#
-# extra globals not included above.
cat <<END >> perl.exp
+perl_init_i18nl10n
perl_init_i18nl14n
-perl_init_ext
+perl_new_collate
+perl_new_ctype
+perl_new_numeric
+perl_set_numeric_local
+perl_set_numeric_standard
perl_alloc
perl_construct
perl_destruct
@@ -41,8 +93,15 @@ perl_call_argv
perl_call_pv
perl_call_method
perl_call_sv
-perl_requirepv
-safemalloc
-saferealloc
-safefree
+perl_eval_pv
+perl_eval_sv
+perl_require_pv
+Mymalloc
+Mycalloc
+Myremalloc
+Myfree
+Perl_malloc
+Perl_calloc
+Perl_realloc
+Perl_free
END
diff --git a/gnu/usr.bin/perl/perlio.c b/gnu/usr.bin/perl/perlio.c
new file mode 100644
index 00000000000..f269dcdb1de
--- /dev/null
+++ b/gnu/usr.bin/perl/perlio.c
@@ -0,0 +1,656 @@
+/* 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 perlio.h.
+ * Which these are depends on various Configure #ifdef's
+ */
+
+#include "EXTERN.h"
+#include "perl.h"
+
+#ifdef PERLIO_IS_STDIO
+
+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
+ */
+}
+
+#undef PerlIO_tmpfile
+PerlIO *
+PerlIO_tmpfile()
+{
+ 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
+
+/* 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
+#ifdef I_STDARG
+PerlIO_printf(PerlIO *f,const char *fmt,...)
+#else
+PerlIO_printf(f,fmt,va_alist)
+PerlIO *f;
+const char *fmt;
+va_dcl
+#endif
+{
+ va_list ap;
+ int result;
+#ifdef I_STDARG
+ va_start(ap,fmt);
+#else
+ va_start(ap);
+#endif
+ result = vfprintf(f,fmt,ap);
+ va_end(ap);
+ return result;
+}
+
+#undef PerlIO_stdoutf
+int
+#ifdef I_STDARG
+PerlIO_stdoutf(const char *fmt,...)
+#else
+PerlIO_stdoutf(fmt, va_alist)
+const char *fmt;
+va_dcl
+#endif
+{
+ va_list ap;
+ int result;
+#ifdef I_STDARG
+ va_start(ap,fmt);
+#else
+ va_start(ap);
+#endif
+ 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(s,n,fmt,ap)
+char *s;
+const char *fmt;
+int n;
+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
+#ifdef I_STDARG
+PerlIO_sprintf(char *s, int n, const char *fmt,...)
+#else
+PerlIO_sprintf(s, n, fmt, va_alist)
+char *s;
+int n;
+const char *fmt;
+va_dcl
+#endif
+{
+ va_list ap;
+ int result;
+#ifdef I_STDARG
+ va_start(ap,fmt);
+#else
+ va_start(ap);
+#endif
+ result = PerlIO_vsprintf(s, n, fmt, ap);
+ va_end(ap);
+ return result;
+}
+#endif
+
diff --git a/gnu/usr.bin/perl/perlio.h b/gnu/usr.bin/perl/perlio.h
new file mode 100644
index 00000000000..59d1a193f85
--- /dev/null
+++ b/gnu/usr.bin/perl/perlio.h
@@ -0,0 +1,199 @@
+#ifndef H_PERLIO
+#define H_PERLIO 1
+
+/* 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
+
+#include "perlsdio.h"
+
+#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
+#endif /* Include guard */
diff --git a/gnu/usr.bin/perl/perlio.sym b/gnu/usr.bin/perl/perlio.sym
new file mode 100644
index 00000000000..d7a345c4ccb
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/perlsdio.h b/gnu/usr.bin/perl/perlsdio.h
new file mode 100644
index 00000000000..5a15a719ca7
--- /dev/null
+++ b/gnu/usr.bin/perl/perlsdio.h
@@ -0,0 +1,309 @@
+/*
+ * 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)
+#define PerlIO_seek(f,o,w) fseek(f,o,w)
+#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 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
+#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)
+#define getc_unlocked(f) PerlIO_getc(f)
+#define putc(c,f) PerlIO_putc(f,c)
+#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/gnu/usr.bin/perl/perlsfio.h b/gnu/usr.bin/perl/perlsfio.h
new file mode 100644
index 00000000000..8c9387fbd0c
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/perlsh b/gnu/usr.bin/perl/perlsh
index 2b2cccd0641..63662d6c6a1 100644
--- a/gnu/usr.bin/perl/perlsh
+++ b/gnu/usr.bin/perl/perlsh
@@ -8,7 +8,7 @@
$/ = "\n\n"; # set paragraph mode
$SHlinesep = "\n";
-while ($SHcmd = <>) {
+while (defined($SHcmd = <>)) {
$/ = $SHlinesep;
eval $SHcmd; print $@ || "\n";
$SHlinesep = $/; $/ = '';
diff --git a/gnu/usr.bin/perl/perly.c b/gnu/usr.bin/perl/perly.c
index 9ecf6d2063e..ae6a0da922a 100644
--- a/gnu/usr.bin/perl/perly.c
+++ b/gnu/usr.bin/perl/perly.c
@@ -12,1094 +12,1044 @@ dep()
deprecate("\"do\" to call subroutines");
}
+#line 16 "perly.c"
#define YYERRCODE 256
short yylhs[] = { -1,
- 31, 0, 5, 3, 6, 6, 6, 7, 7, 7,
- 7, 21, 21, 21, 21, 21, 21, 11, 11, 11,
- 9, 9, 9, 9, 30, 30, 8, 8, 8, 8,
- 8, 8, 8, 8, 10, 10, 25, 25, 29, 29,
- 1, 1, 1, 1, 2, 2, 32, 32, 28, 28,
- 4, 33, 33, 34, 13, 13, 13, 12, 12, 12,
- 26, 26, 26, 26, 26, 26, 26, 26, 27, 27,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 22, 22, 23, 23, 23, 20,
- 15, 16, 17, 18, 19, 24, 24, 24, 24,
+ 45, 0, 9, 7, 10, 8, 11, 11, 11, 12,
+ 12, 12, 12, 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, 0, 2, 2, 2, 1, 2,
- 3, 1, 1, 3, 3, 3, 3, 0, 2, 6,
- 6, 6, 4, 4, 0, 2, 7, 7, 5, 5,
- 8, 7, 10, 3, 0, 1, 0, 1, 0, 1,
- 1, 1, 1, 1, 4, 3, 5, 5, 0, 1,
- 0, 3, 2, 5, 3, 3, 1, 2, 3, 1,
- 3, 5, 6, 3, 5, 2, 4, 4, 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, 1, 2,
- 2, 1, 2, 2, 2, 1, 3, 1, 3, 4,
- 4, 6, 1, 1, 0, 1, 0, 1, 2, 2,
- 2, 2, 2, 2, 2, 1, 1, 1, 1,
+ 0, 2, 4, 0, 4, 0, 0, 2, 2, 2,
+ 1, 2, 3, 1, 1, 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, 5, 0, 40, 51, 51, 0, 51, 6, 41,
- 7, 9, 0, 42, 43, 44, 0, 0, 0, 53,
- 0, 12, 4, 143, 0, 0, 118, 0, 138, 0,
- 51, 51, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 7, 0, 44, 55, 53, 0, 53, 8, 45,
+ 9, 11, 0, 46, 47, 48, 0, 0, 0, 62,
+ 63, 14, 4, 156, 0, 0, 129, 0, 151, 0,
+ 54, 54, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 163, 164, 0,
+ 0, 0, 0, 0, 0, 0, 0, 12, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 10, 0, 0,
+ 0, 0, 119, 121, 0, 0, 0, 0, 157, 50,
+ 0, 56, 0, 61, 0, 7, 172, 175, 174, 173,
+ 0, 0, 0, 0, 0, 0, 4, 4, 4, 4,
+ 4, 4, 0, 0, 0, 0, 0, 146, 0, 0,
+ 0, 0, 76, 0, 170, 0, 135, 0, 0, 0,
+ 0, 0, 166, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 109, 0, 167, 168, 169, 171, 0,
+ 0, 33, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 10, 0, 0, 0,
- 0, 0, 0, 0, 0, 8, 0, 0, 0, 0,
- 0, 108, 110, 0, 0, 0, 144, 0, 46, 0,
- 52, 0, 5, 156, 159, 158, 157, 0, 0, 0,
+ 0, 0, 0, 101, 102, 0, 0, 0, 0, 0,
+ 0, 0, 0, 13, 0, 49, 58, 0, 0, 0,
+ 74, 0, 0, 78, 0, 0, 0, 0, 0, 0,
+ 0, 4, 150, 152, 0, 0, 0, 0, 0, 0,
+ 0, 111, 0, 133, 0, 0, 108, 26, 0, 0,
+ 19, 0, 0, 0, 65, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 154, 0, 124,
- 0, 0, 0, 0, 0, 0, 150, 0, 0, 0,
- 0, 66, 0, 133, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 98, 0, 151, 152, 153, 155,
- 0, 34, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 90, 91, 0, 0, 0, 0,
- 0, 0, 0, 0, 11, 45, 50, 0, 0, 0,
- 64, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 36, 0, 137, 139,
- 0, 0, 0, 0, 0, 0, 100, 0, 122, 0,
- 0, 0, 97, 26, 0, 0, 0, 0, 0, 0,
- 55, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 69, 0, 70,
- 0, 0, 0, 0, 0, 0, 0, 120, 0, 48,
- 47, 54, 3, 0, 141, 0, 68, 101, 0, 29,
- 0, 30, 0, 0, 0, 23, 0, 24, 0, 0,
- 0, 140, 149, 67, 0, 125, 0, 127, 0, 99,
- 0, 0, 0, 0, 0, 0, 0, 107, 0, 105,
- 0, 116, 0, 121, 65, 0, 0, 0, 0, 19,
- 0, 0, 0, 0, 0, 62, 126, 128, 115, 0,
- 113, 0, 0, 106, 0, 111, 117, 103, 142, 27,
- 28, 21, 0, 22, 0, 32, 0, 114, 112, 63,
- 0, 0, 31, 0, 0, 20, 33,
+ 0, 80, 0, 0, 81, 0, 0, 0, 0, 0,
+ 0, 0, 131, 0, 0, 60, 59, 52, 0, 3,
+ 0, 154, 0, 0, 112, 0, 41, 0, 42, 0,
+ 0, 0, 0, 165, 0, 0, 35, 40, 0, 0,
+ 0, 153, 162, 77, 0, 136, 0, 138, 0, 110,
+ 0, 0, 0, 0, 0, 140, 0, 0, 0, 118,
+ 0, 116, 0, 127, 0, 132, 0, 75, 0, 79,
+ 0, 0, 0, 0, 0, 0, 0, 0, 72, 137,
+ 139, 126, 0, 124, 0, 0, 141, 117, 0, 122,
+ 128, 114, 64, 155, 6, 0, 0, 0, 0, 0,
+ 0, 0, 0, 125, 123, 73, 7, 27, 28, 0,
+ 0, 23, 24, 0, 31, 0, 0, 0, 21, 0,
+ 0, 0, 30, 5, 0, 29, 0, 0, 32, 0,
+ 22,
};
short yydgoto[] = { 1,
- 9, 10, 83, 17, 86, 3, 11, 12, 66, 195,
- 266, 67, 202, 69, 70, 71, 72, 73, 74, 75,
- 197, 122, 203, 88, 187, 77, 241, 178, 13, 142,
- 2, 14, 15, 16,
+ 9, 66, 10, 18, 95, 17, 86, 337, 89, 326,
+ 3, 11, 12, 68, 342, 261, 70, 71, 72, 73,
+ 74, 75, 76, 267, 78, 268, 257, 259, 262, 270,
+ 258, 260, 113, 197, 91, 79, 236, 81, 83, 178,
+ 248, 142, 265, 13, 2, 14, 15, 16, 85, 254,
};
short yysindex[] = { 0,
- 0, 0, -82, 0, 0, 0, -52, 0, 0, 0,
- 0, 0, 853, 0, 0, 0, -80, -256, -19, 0,
- -245, 0, 0, 0, 19, 19, 0, 20, 0, 2177,
- 0, 0, -2, 1, 28, 41, 133, 2177, 27, 33,
- 52, 19, 1028, 2177, 1303, -210, 19, 2177, 965, 1359,
- 2177, 2177, 2177, 2177, 2177, 1415, 0, 2177, 2177, 1478,
- 19, 19, 19, 19, -225, 0, 71, 209, 1535, -49,
- -30, 0, 0, 8, 101, 42, 0, 30, 0, -112,
- 0, 2177, 0, 0, 0, 0, 0, 2177, 127, 2177,
- 1535, 30, -112, 2177, 30, 2177, 30, 2177, 30, 2177,
- 30, 1712, 128, 1535, 139, 1768, 965, 0, 141, 0,
- 1485, -14, 1485, 65, -42, 2177, 0, 71, 0, 71,
- -49, 0, 2177, 0, 1485, 334, 334, 334, -47, -47,
- 92, -26, 334, 334, 0, 63, 0, 0, 0, 0,
- 30, 0, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
- 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
- 2177, 2177, 2177, 2177, 0, 0, -27, 2177, 2177, 2177,
- 2177, 2177, 2177, 1824, 0, 0, 0, -48, 137, -92,
- 0, 2177, 221, 2177, 30, -191, 151, -225, -22, -225,
- -12, -147, 7, -147, 138, 5, 0, 2177, 0, 0,
- 9, -39, 160, 2177, 1887, 2121, 0, 77, 0, 71,
- 2177, 113, 0, 0, 1535, -191, -191, -191, -191, -86,
- 0, -20, 395, 1485, 1566, 461, -88, 1535, 4122, 1064,
- 679, 364, 1120, 728, 334, 334, 2177, 0, 2177, 0,
- 174, 89, 51, 98, 55, 118, 57, 0, 11, 0,
- 0, 0, 0, 175, 0, 2177, 0, 0, 30, 0,
- 30, 0, 30, 30, 178, 0, 30, 0, 2177, 30,
- 15, 0, 0, 0, 22, 0, 25, 0, 29, 0,
- 152, 2177, 94, 2177, 59, 177, 2177, 0, 96, 0,
- 97, 0, 102, 0, 0, 1190, -225, -225, -147, 0,
- 2177, -147, 176, -225, 30, 0, 0, 0, 0, 205,
- 0, 3039, 111, 0, 206, 0, 0, 0, 0, 0,
- 0, 0, 37, 0, 1712, 0, -225, 0, 0, 0,
- 30, 208, 0, -147, 30, 0, 0,
+ 0, 0, -120, 0, 0, 0, -50, 0, 0, 0,
+ 0, 0, 661, 0, 0, 0, -240, -238, -29, 0,
+ 0, 0, 0, 0, -32, -32, 0, -8, 0, 2115,
+ 0, 0, -4, 31, 32, 35, -35, 2115, 56, 57,
+ 61, 1037, 981, -32, 1100, 1364, -218, 0, 0, -32,
+ 2115, 2115, 2115, 2115, 2115, 2115, 1420, 0, 2115, 2115,
+ 1476, -32, -32, -32, -32, 2115, -205, 0, 201, 306,
+ -63, -62, 0, 0, -24, 67, 45, 65, 0, 0,
+ -15, 0, -149, 0, -144, 0, 0, 0, 0, 0,
+ 2115, 80, 2115, 841, -15, -149, 0, 0, 0, 0,
+ 0, 0, 85, 306, 86, 1535, 981, 0, 841, 0,
+ -63, 65, 0, 2115, 0, 88, 0, 841, -28, 4,
+ -51, 2115, 0, 65, 340, 340, 340, -76, -76, 49,
+ -31, 340, 340, 0, -82, 0, 0, 0, 0, 841,
+ -15, 0, 2115, 2115, 2115, 2115, 2115, 2115, 2115, 2115,
+ 2115, 2115, 2115, 2115, 2115, 2115, 2115, 2115, 2115, 2115,
+ 2115, 2115, 2115, 0, 0, 48, 2115, 2115, 2115, 2115,
+ 2115, 2115, 1710, 0, 2115, 0, 0, -43, -116, 241,
+ 0, 2115, 1193, 0, -15, 2115, 2115, 2115, 2115, 106,
+ 1769, 0, 0, 0, -23, 20, 104, 2115, 65, 1825,
+ 1881, 0, 36, 0, 2115, 62, 0, 0, -232, -232,
+ 0, -232, -232, -134, 0, -46, 1131, 841, 689, 316,
+ 859, 306, 3778, 1980, 3652, 1299, 480, 396, 340, 340,
+ 2115, 0, 1944, 2115, 0, 128, -58, 22, -56, 24,
+ 33, 28, 0, -19, 306, 0, 0, 0, 2115, 0,
+ 134, 0, 2115, 2115, 0, -232, 0, 142, 0, 148,
+ -232, 149, 150, 0, 153, 201, 0, 0, 154, 138,
+ 2115, 0, 0, 0, -7, 0, 2, 0, 16, 0,
+ 70, 2115, 73, 2115, 30, 0, 18, 101, 2115, 0,
+ 75, 0, 78, 0, 81, 0, 151, 0, 1247, 0,
+ 90, 90, 90, 90, 2115, 90, 2115, 167, 0, 0,
+ 0, 0, 103, 0, 3869, 84, 0, 0, 170, 0,
+ 0, 0, 0, 0, 0, -205, -205, -207, -207, 176,
+ -205, 168, 90, 0, 0, 0, 0, 0, 0, 90,
+ 192, 0, 0, 90, 0, 1769, -205, 402, 0, 2115,
+ -205, 207, 0, 0, 208, 0, 90, 90, 0, -207,
+ 0,
};
short yyrindex[] = { 0,
- 0, 0, 297, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 265, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 131, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 2156, -17, 0,
+ 0, 2675, 2720, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 2253, 505, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 2847, 2935,
+ 0, 0, 0, 0, 0, 0, 79, 0, -3, 108,
+ 2774, 2860, 0, 0, 2034, 121, 0, 140, 0, 0,
+ 0, 0, -33, 0, 0, 0, 0, 0, 0, 0,
+ 2203, 0, 0, 3504, 0, 145, 0, 0, 0, 0,
+ 0, 0, 0, 3772, 0, 0, 252, 0, 3551, 541,
+ 602, 2270, 0, 0, 0, 442, 0, 3587, 2774, 0,
+ 0, 2203, 0, 2324, 3010, 3049, 3096, 2911, 2972, 2439,
+ 0, 3147, 3193, 0, 0, 0, 0, 0, 0, 3633,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 107, 0, -35, 10, 53, 3109,
- 3156, 0, 0, 2298, 1976, 0, 0, 0, 0, -23,
- 0, 230, 0, 0, 0, 0, 0, 2385, 0, 0,
- 1004, 0, 168, 253, 0, 0, 0, 0, 0, 0,
- 0, 254, 0, 2242, 0, 0, 274, 0, 2032, 0,
- 3844, 3109, 3902, 0, 0, 2385, 0, 2440, 452, 2554,
- 572, 0, 0, 0, 3981, 3274, 3312, 3421, 3200, 3237,
- 2661, 0, 3560, 3596, 0, 0, 0, 0, 0, 0,
- 0, 0, 2714, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 909,
- 0, 274, 0, 2385, 0, 39, 0, 107, 0, 107,
- 0, 170, 0, 170, 0, 262, 0, 0, 0, 0,
- 0, 288, 0, 0, 0, 0, 0, 0, 0, 2805,
- 0, 2757, 0, 0, 2650, 49, 58, 61, 64, 365,
- 0, 0, -31, 4018, 4028, 3719, 630, 2995, 0, 1623,
- 4106, 4096, 4064, 3756, 3640, 3683, 0, 0, 0, 0,
+ 0, 0, 0, 0, 2522, 0, 0, 0, 0, 925,
+ 0, 252, 0, 0, 0, 263, 0, 0, 0, 0,
+ 223, 0, 0, 0, 0, 282, 0, 0, 2576, 0,
+ 0, 0, 0, 0, 0, 2624, 0, 0, -1, 26,
+ 0, 27, 51, 718, 0, 0, 3752, 1576, 1632, 3368,
+ 3413, 3799, 0, -38, 3710, 3678, 3060, 3459, 3285, 3332,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 3835, 0, 0, 0, 273, 0,
+ 0, 0, 0, 2203, 0, 59, 0, 0, 0, 0,
+ 293, 0, 0, 0, 0, 64, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 277, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 252, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 274, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 107, 107, 170, 0,
- 0, 170, 0, 107, 0, 0, 0, 0, 0, 0,
- 0, 13, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 300, 0, 107, 0, 0, 0,
- 0, 0, 0, 170, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 296, 0, 0, 0,
+ 0, 0, 0, 0, 2380, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 79, 79, 186, 186, 0,
+ 79, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 300, 79, 925, 0, 0,
+ 79, 0, 0, 0, 0, 0, 0, 0, 0, 186,
+ 0,
};
short yygindex[] = { 0,
- 0, 0, 0, 506, -13, 255, 0, 0, 0, 18,
- -180, 839, -11, 4398, 2162, 0, 0, 0, 0, 0,
- 342, -57, -174, 1032, 90, 0, 0, 267, 0, -172,
- 0, 0, 0, 0,
+ 0, 0, 0, 349, 328, 0, -48, 0, 679, 378,
+ -84, 0, 0, 0, -298, -13, 4075, 2485, 0, 0,
+ 0, 0, 0, 363, 908, 0, 0, 233, -168, 38,
+ 72, 196, -77, -175, 999, 0, 0, 0, 0, 290,
+ 0, -249, 0, 0, 0, 0, 0, 0, 0, 0,
};
-#define YYTABLESIZE 4682
-short yytable[] = { 65,
- 80, 68, 168, 79, 273, 57, 20, 254, 61, 80,
- 250, 82, 80, 268, 212, 260, 208, 262, 261, 95,
- 97, 99, 101, 57, 179, 206, 80, 80, 263, 110,
- 181, 80, 253, 115, 150, 49, 124, 94, 283, 81,
- 96, 170, 23, 168, 132, 270, 116, 267, 136, 272,
- 13, 294, 141, 83, 61, 305, 83, 57, 209, 90,
- 172, 80, 306, 239, 176, 307, 105, 98, 13, 308,
- 83, 83, 106, 169, 23, 150, 170, 331, 184, 38,
- 100, 188, 186, 190, 189, 192, 191, 194, 193, 16,
- 196, 107, 171, 60, 201, 237, 60, 38, 17, 49,
- 175, 14, 148, 149, 15, 83, 25, 16, 169, 289,
- 60, 60, 315, 291, 143, 293, 17, 313, 322, 14,
- 23, 324, 15, 23, 320, 321, 257, 214, 264, 265,
- 173, 326, 216, 217, 218, 219, 220, 221, 222, 25,
- 174, 23, 25, 25, 25, 60, 25, 177, 25, 25,
- 23, 25, 23, 336, 333, 213, 242, 243, 244, 245,
- 246, 247, 249, 23, 251, 25, 182, 198, 61, 18,
- 25, 258, 102, 4, 5, 6, 78, 7, 8, 199,
- 205, 288, 211, 4, 5, 6, 271, 7, 8, 207,
- 290, 259, 275, 277, 279, 252, 269, 25, 154, 281,
- 274, 280, 18, 282, 19, 18, 18, 18, 149, 18,
- 292, 18, 18, 287, 18, 295, 163, 301, 311, 164,
- 316, 317, 165, 166, 167, 285, 318, 286, 18, 25,
- 238, 25, 25, 18, 325, 329, 57, 57, 57, 57,
- 80, 80, 80, 80, 309, 297, 330, 298, 335, 299,
- 300, 148, 149, 302, 148, 149, 304, 186, 57, 57,
- 18, 255, 80, 80, 256, 167, 80, 148, 149, 314,
- 310, 148, 149, 148, 149, 84, 144, 145, 146, 147,
- 85, 148, 149, 157, 83, 83, 83, 83, 145, 323,
- 49, 327, 18, 37, 18, 18, 2, 328, 148, 149,
- 148, 149, 148, 149, 148, 149, 83, 83, 148, 149,
- 83, 168, 35, 68, 147, 148, 149, 334, 148, 149,
- 13, 337, 148, 149, 60, 60, 60, 60, 148, 39,
- 148, 149, 39, 39, 39, 37, 39, 180, 39, 39,
- 35, 39, 332, 150, 148, 149, 60, 60, 148, 149,
- 148, 149, 148, 149, 76, 39, 148, 149, 303, 185,
- 39, 0, 25, 25, 25, 25, 25, 25, 0, 25,
- 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
- 25, 25, 148, 149, 0, 25, 25, 39, 25, 25,
- 25, 148, 149, 0, 0, 25, 25, 25, 25, 25,
- 0, 0, 25, 25, 0, 56, 0, 0, 56, 25,
- 0, 148, 149, 25, 0, 25, 25, 0, 0, 39,
- 0, 0, 39, 56, 168, 18, 18, 18, 18, 18,
- 18, 0, 18, 18, 18, 18, 18, 18, 18, 18,
- 18, 18, 18, 18, 18, 148, 149, 0, 18, 18,
- 0, 18, 18, 18, 168, 0, 150, 56, 18, 18,
- 18, 18, 18, 0, 0, 18, 18, 0, 0, 0,
- 148, 149, 18, 0, 0, 0, 18, 0, 18, 18,
- 144, 145, 146, 147, 156, 168, 150, 156, 156, 156,
- 0, 156, 143, 156, 156, 143, 156, 0, 148, 149,
- 0, 151, 148, 149, 0, 152, 153, 154, 155, 143,
- 143, 18, 0, 21, 143, 156, 0, 150, 156, 158,
- 159, 160, 161, 0, 162, 163, 0, 0, 164, 0,
- 0, 165, 166, 167, 0, 0, 92, 93, 0, 0,
- 0, 0, 143, 0, 143, 136, 0, 0, 136, 0,
- 0, 168, 39, 39, 39, 39, 39, 39, 0, 39,
- 39, 39, 136, 136, 0, 39, 0, 136, 39, 39,
- 39, 39, 0, 0, 143, 39, 39, 156, 39, 39,
- 39, 0, 0, 150, 0, 39, 39, 39, 39, 39,
- 0, 0, 39, 39, 0, 136, 0, 136, 0, 39,
- 0, 0, 0, 39, 157, 39, 39, 157, 157, 157,
- 0, 157, 102, 157, 157, 102, 157, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 136, 0, 102,
- 102, 0, 0, 0, 102, 157, 56, 56, 56, 56,
- 0, 164, 0, 0, 165, 166, 167, 0, 152, 153,
- 154, 155, 0, 0, 0, 0, 0, 0, 56, 0,
- 0, 0, 0, 0, 102, 161, 0, 162, 163, 0,
- 74, 164, 0, 74, 165, 166, 167, 0, 0, 152,
- 153, 154, 155, 0, 0, 0, 0, 74, 74, 0,
- 0, 0, 74, 158, 159, 160, 161, 157, 162, 163,
- 0, 0, 164, 0, 0, 165, 166, 167, 156, 156,
- 156, 156, 156, 0, 156, 156, 156, 0, 0, 0,
- 156, 0, 74, 143, 143, 143, 143, 0, 0, 0,
- 0, 156, 143, 156, 156, 156, 143, 143, 143, 143,
- 156, 156, 156, 156, 156, 143, 143, 156, 156, 143,
- 143, 143, 143, 143, 156, 143, 143, 0, 156, 143,
- 156, 156, 143, 143, 143, 163, 0, 0, 164, 168,
- 0, 165, 166, 167, 0, 0, 136, 136, 136, 136,
- 0, 0, 0, 0, 0, 136, 0, 0, 0, 136,
- 136, 136, 136, 0, 0, 0, 0, 0, 136, 136,
- 0, 150, 136, 136, 136, 136, 136, 0, 136, 136,
- 0, 0, 136, 0, 0, 136, 136, 136, 168, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 157, 157,
- 157, 157, 157, 0, 157, 157, 157, 0, 0, 0,
- 157, 0, 0, 102, 102, 102, 102, 0, 0, 0,
- 150, 157, 102, 157, 157, 157, 102, 102, 102, 102,
- 157, 157, 157, 157, 157, 102, 102, 157, 157, 102,
- 102, 102, 102, 102, 157, 102, 102, 0, 157, 102,
- 157, 157, 102, 102, 102, 51, 118, 120, 61, 63,
- 47, 0, 56, 0, 64, 59, 0, 58, 0, 0,
- 0, 74, 74, 74, 74, 0, 0, 0, 0, 0,
- 74, 57, 0, 0, 74, 74, 62, 74, 0, 0,
- 120, 0, 0, 74, 74, 0, 120, 74, 74, 74,
- 74, 74, 0, 74, 0, 0, 0, 0, 0, 0,
- 0, 39, 0, 60, 39, 39, 39, 0, 39, 0,
- 39, 39, 0, 39, 120, 0, 0, 0, 0, 0,
- 0, 210, 0, 152, 153, 154, 155, 39, 0, 0,
- 0, 0, 39, 0, 0, 23, 0, 0, 52, 160,
- 161, 0, 162, 163, 0, 0, 164, 0, 0, 165,
- 166, 167, 0, 0, 0, 0, 0, 51, 0, 39,
- 61, 63, 47, 0, 56, 0, 64, 59, 0, 58,
- 0, 0, 0, 0, 154, 155, 0, 0, 0, 0,
- 0, 0, 120, 0, 0, 0, 0, 0, 62, 0,
- 0, 39, 163, 0, 39, 164, 0, 0, 165, 166,
- 167, 0, 0, 0, 135, 0, 0, 135, 0, 0,
- 0, 0, 0, 0, 0, 60, 0, 89, 0, 0,
- 51, 135, 135, 61, 63, 47, 0, 56, 0, 64,
- 59, 0, 58, 108, 0, 0, 0, 0, 117, 0,
- 123, 0, 0, 0, 0, 0, 0, 23, 0, 0,
- 52, 62, 137, 138, 139, 140, 135, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 22, 24,
- 25, 26, 27, 28, 0, 29, 30, 31, 60, 0,
- 0, 32, 0, 0, 33, 34, 35, 36, 0, 0,
- 0, 37, 38, 0, 39, 40, 41, 0, 204, 0,
- 0, 42, 43, 44, 45, 46, 0, 0, 48, 49,
- 23, 0, 0, 52, 168, 50, 0, 0, 0, 53,
- 0, 54, 55, 0, 39, 39, 39, 39, 39, 39,
- 0, 39, 39, 39, 0, 0, 0, 39, 0, 0,
- 39, 39, 39, 39, 0, 0, 150, 39, 39, 0,
- 39, 39, 39, 0, 0, 0, 0, 39, 39, 39,
- 39, 39, 0, 0, 39, 39, 0, 0, 0, 0,
- 168, 39, 0, 0, 0, 39, 0, 39, 39, 0,
- 0, 119, 25, 26, 27, 28, 85, 29, 30, 31,
- 319, 0, 0, 32, 0, 0, 0, 0, 0, 0,
- 0, 0, 150, 0, 38, 0, 39, 40, 41, 0,
- 0, 0, 157, 42, 43, 44, 45, 46, 0, 0,
- 48, 49, 0, 0, 0, 0, 0, 50, 0, 0,
- 0, 53, 0, 54, 55, 135, 135, 135, 135, 0,
- 168, 0, 0, 0, 109, 25, 26, 27, 28, 0,
- 29, 30, 31, 0, 0, 0, 32, 135, 135, 0,
- 0, 0, 0, 0, 0, 0, 0, 38, 0, 39,
- 40, 41, 150, 0, 0, 0, 42, 43, 44, 45,
- 46, 0, 0, 48, 49, 0, 0, 0, 0, 0,
- 50, 0, 0, 0, 53, 51, 54, 55, 61, 63,
- 47, 0, 56, 0, 64, 59, 0, 58, 152, 153,
- 154, 155, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 114, 0, 159, 160, 161, 62, 162, 163, 0,
- 0, 164, 0, 0, 165, 166, 167, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 51, 0, 60, 61, 63, 47, 0, 56, 0,
- 64, 59, 0, 58, 152, 153, 154, 155, 0, 0,
+#define YYTABLESIZE 4359
+short yytable[] = { 69,
+ 62, 180, 93, 62, 102, 93, 251, 203, 20, 206,
+ 207, 201, 283, 181, 167, 246, 80, 272, 82, 93,
+ 93, 296, 269, 149, 93, 57, 149, 169, 171, 84,
+ 343, 93, 121, 309, 290, 97, 292, 15, 122, 18,
+ 149, 149, 310, 131, 204, 149, 149, 135, 186, 187,
+ 188, 189, 190, 191, 93, 15, 311, 18, 317, 168,
+ 170, 361, 169, 273, 147, 148, 38, 16, 340, 341,
+ 98, 99, 141, 149, 100, 149, 338, 339, 25, 23,
+ 291, 345, 293, 62, 38, 16, 295, 233, 316, 57,
+ 23, 17, 195, 196, 168, 105, 106, 353, 172, 37,
+ 107, 356, 308, 174, 39, 149, 173, 23, 175, 17,
+ 177, 25, 179, 319, 25, 25, 25, 37, 25, 182,
+ 25, 25, 15, 25, 192, 294, 193, 200, 202, 209,
+ 210, 212, 213, 214, 215, 216, 330, 25, 234, 205,
+ 249, 62, 25, 271, 274, 4, 5, 6, 70, 7,
+ 8, 70, 282, 237, 238, 239, 240, 241, 242, 244,
+ 280, 130, 312, 148, 130, 70, 70, 289, 196, 25,
+ 231, 297, 256, 210, 298, 210, 300, 266, 130, 130,
+ 67, 355, 301, 130, 275, 20, 277, 279, 302, 303,
+ 304, 281, 305, 318, 306, 334, 307, 314, 67, 320,
+ 70, 25, 321, 25, 25, 322, 19, 333, 335, 323,
+ 336, 130, 325, 130, 147, 148, 344, 285, 20, 287,
+ 288, 20, 20, 20, 87, 20, 346, 20, 20, 88,
+ 20, 350, 67, 93, 93, 93, 93, 166, 147, 148,
+ 147, 148, 93, 130, 20, 147, 148, 357, 358, 20,
+ 147, 148, 348, 51, 149, 149, 149, 149, 93, 93,
+ 101, 93, 93, 149, 2, 147, 148, 57, 313, 149,
+ 149, 149, 149, 147, 148, 196, 20, 147, 148, 149,
+ 149, 34, 149, 149, 149, 149, 149, 149, 149, 147,
+ 148, 149, 160, 256, 149, 149, 149, 43, 147, 148,
+ 43, 43, 43, 36, 43, 232, 43, 43, 20, 43,
+ 20, 20, 147, 148, 147, 148, 147, 148, 147, 148,
+ 147, 148, 161, 43, 147, 148, 147, 148, 43, 147,
+ 148, 158, 69, 39, 25, 25, 25, 25, 25, 25,
+ 34, 25, 25, 25, 25, 25, 25, 25, 25, 25,
+ 25, 25, 25, 25, 36, 43, 21, 25, 25, 96,
+ 25, 25, 25, 25, 25, 250, 147, 148, 156, 25,
+ 25, 25, 25, 25, 25, 77, 211, 25, 332, 70,
+ 70, 70, 70, 352, 263, 185, 25, 43, 25, 25,
+ 43, 0, 130, 130, 130, 130, 167, 147, 148, 147,
+ 148, 130, 0, 0, 70, 70, 167, 130, 130, 130,
+ 130, 67, 67, 67, 67, 0, 0, 130, 130, 0,
+ 130, 130, 130, 130, 130, 130, 130, 0, 149, 130,
+ 167, 0, 130, 130, 130, 0, 67, 67, 149, 0,
+ 0, 20, 20, 20, 20, 20, 20, 0, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 0, 149, 0, 20, 20, 0, 20, 20, 20,
+ 20, 20, 143, 144, 145, 146, 20, 20, 20, 20,
+ 20, 20, 156, 0, 20, 156, 167, 0, 0, 0,
+ 0, 0, 0, 20, 0, 20, 20, 147, 148, 156,
+ 156, 0, 0, 0, 156, 0, 4, 5, 6, 0,
+ 7, 8, 0, 0, 0, 0, 0, 0, 149, 0,
+ 43, 43, 43, 43, 43, 43, 354, 43, 43, 43,
+ 0, 0, 156, 43, 156, 0, 43, 43, 43, 43,
+ 0, 0, 0, 43, 43, 0, 43, 43, 43, 43,
+ 43, 0, 0, 0, 0, 43, 43, 43, 43, 43,
+ 43, 0, 0, 43, 156, 0, 0, 0, 0, 0,
+ 167, 0, 43, 172, 43, 43, 172, 172, 172, 0,
+ 172, 156, 172, 172, 156, 172, 150, 0, 0, 0,
+ 0, 0, 151, 152, 153, 154, 0, 0, 156, 156,
+ 0, 0, 149, 156, 172, 155, 157, 158, 159, 160,
+ 161, 162, 0, 0, 163, 0, 0, 164, 165, 166,
+ 0, 162, 0, 0, 163, 0, 0, 164, 165, 166,
+ 0, 156, 0, 156, 173, 0, 0, 173, 173, 173,
+ 0, 173, 113, 173, 173, 113, 173, 0, 163, 0,
+ 0, 164, 165, 166, 0, 0, 0, 0, 0, 113,
+ 113, 0, 0, 156, 113, 173, 172, 4, 5, 6,
+ 0, 7, 8, 0, 0, 0, 0, 0, 0, 327,
+ 328, 329, 0, 331, 153, 154, 0, 0, 0, 0,
+ 0, 67, 0, 52, 113, 0, 62, 64, 50, 0,
+ 57, 162, 65, 60, 163, 59, 0, 164, 165, 166,
+ 347, 0, 0, 156, 156, 156, 156, 349, 0, 58,
+ 108, 351, 156, 117, 63, 0, 0, 173, 156, 156,
+ 156, 156, 0, 0, 359, 360, 0, 0, 156, 156,
+ 0, 156, 156, 156, 156, 156, 156, 156, 0, 0,
+ 156, 61, 0, 156, 156, 156, 0, 0, 66, 176,
+ 0, 66, 0, 0, 0, 0, 151, 152, 153, 154,
+ 0, 0, 0, 184, 0, 0, 66, 0, 0, 167,
+ 0, 0, 0, 23, 161, 162, 53, 0, 163, 0,
+ 0, 164, 165, 166, 0, 0, 0, 172, 172, 172,
+ 172, 172, 0, 172, 172, 172, 0, 0, 0, 172,
+ 66, 149, 156, 156, 156, 156, 0, 0, 0, 208,
+ 172, 156, 172, 172, 172, 172, 172, 156, 156, 156,
+ 156, 172, 172, 172, 172, 172, 172, 156, 156, 172,
+ 156, 156, 156, 156, 156, 156, 156, 0, 172, 156,
+ 172, 172, 156, 156, 156, 0, 247, 0, 173, 173,
+ 173, 173, 173, 255, 173, 173, 173, 0, 0, 0,
+ 173, 0, 0, 113, 113, 113, 113, 0, 0, 0,
+ 0, 173, 113, 173, 173, 173, 173, 173, 113, 113,
+ 113, 113, 173, 173, 173, 173, 173, 173, 113, 113,
+ 173, 113, 113, 113, 113, 113, 113, 113, 0, 173,
+ 113, 173, 173, 113, 113, 113, 22, 24, 25, 26,
+ 27, 28, 0, 29, 30, 31, 0, 0, 0, 32,
+ 0, 167, 33, 34, 35, 36, 0, 0, 0, 37,
+ 38, 0, 39, 40, 41, 42, 43, 0, 0, 167,
+ 112, 44, 45, 46, 47, 48, 49, 43, 124, 51,
+ 43, 43, 43, 149, 43, 0, 43, 43, 54, 43,
+ 55, 56, 0, 0, 0, 151, 0, 153, 154, 0,
+ 0, 149, 0, 43, 0, 0, 0, 0, 43, 66,
+ 66, 66, 66, 161, 162, 0, 0, 163, 112, 0,
+ 164, 165, 166, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 52, 66, 43, 62, 64, 50, 0,
+ 57, 199, 65, 60, 92, 59, 0, 0, 0, 112,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 62, 162, 163, 0, 0, 164, 52, 0,
- 165, 166, 167, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 51, 0, 60,
- 61, 63, 47, 0, 56, 131, 64, 59, 0, 58,
+ 0, 114, 115, 0, 63, 0, 0, 43, 123, 0,
+ 43, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 136, 137, 138, 139, 0, 0, 0, 0, 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,
- 151, 0, 0, 0, 152, 153, 154, 155, 62, 0,
- 0, 23, 0, 0, 52, 0, 0, 156, 158, 159,
- 160, 161, 0, 162, 163, 0, 0, 164, 0, 0,
- 165, 166, 167, 0, 0, 60, 0, 0, 0, 0,
- 51, 0, 0, 61, 63, 47, 0, 56, 0, 64,
- 59, 0, 58, 0, 0, 0, 0, 0, 0, 0,
+ 63, 0, 0, 23, 0, 198, 53, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 52, 62, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 24,
- 25, 26, 27, 28, 0, 29, 30, 31, 60, 0,
- 135, 32, 0, 0, 0, 168, 0, 0, 0, 0,
- 0, 0, 38, 0, 39, 40, 41, 0, 0, 0,
- 0, 42, 43, 44, 45, 46, 0, 157, 48, 49,
- 0, 0, 0, 52, 0, 50, 0, 150, 0, 53,
- 0, 54, 55, 0, 0, 24, 25, 26, 27, 28,
- 0, 29, 30, 31, 0, 168, 0, 32, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 61, 0, 153,
+ 154, 0, 52, 0, 0, 62, 64, 50, 0, 57,
+ 0, 65, 60, 0, 59, 161, 162, 153, 0, 163,
+ 0, 0, 164, 165, 166, 0, 112, 0, 0, 23,
+ 0, 112, 53, 63, 162, 0, 0, 163, 0, 0,
+ 164, 165, 166, 0, 0, 0, 0, 0, 0, 0,
+ 43, 43, 43, 43, 43, 43, 0, 43, 43, 43,
+ 61, 0, 0, 43, 0, 0, 43, 43, 43, 43,
+ 0, 0, 0, 43, 43, 0, 43, 43, 43, 43,
+ 43, 0, 0, 0, 0, 43, 43, 43, 43, 43,
+ 43, 167, 23, 43, 0, 53, 0, 0, 0, 0,
+ 0, 0, 43, 252, 43, 43, 253, 110, 25, 26,
+ 27, 28, 88, 29, 30, 31, 0, 0, 0, 32,
+ 0, 0, 0, 149, 0, 156, 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, 167, 0, 0, 0, 324, 54, 0,
+ 55, 56, 0, 24, 25, 26, 27, 28, 0, 29,
+ 30, 31, 0, 0, 0, 32, 0, 0, 0, 156,
+ 0, 0, 0, 0, 0, 149, 38, 0, 39, 40,
+ 41, 42, 43, 0, 0, 0, 0, 44, 45, 46,
+ 47, 48, 49, 0, 0, 51, 0, 167, 0, 0,
+ 0, 0, 0, 0, 54, 0, 55, 56, 0, 0,
+ 0, 0, 0, 0, 0, 0, 116, 25, 26, 27,
+ 28, 0, 29, 30, 31, 0, 0, 0, 32, 149,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 38,
+ 0, 39, 40, 41, 42, 43, 0, 0, 0, 167,
+ 44, 45, 46, 47, 48, 49, 52, 0, 51, 62,
+ 64, 50, 0, 57, 0, 65, 60, 54, 59, 55,
+ 56, 0, 0, 0, 0, 0, 0, 151, 152, 153,
+ 154, 149, 120, 0, 0, 0, 0, 63, 0, 0,
+ 0, 157, 158, 159, 160, 161, 162, 0, 0, 163,
+ 0, 0, 164, 165, 166, 0, 0, 0, 0, 0,
+ 0, 0, 52, 0, 61, 62, 64, 50, 0, 57,
+ 130, 65, 60, 0, 59, 0, 0, 0, 0, 0,
+ 0, 0, 0, 150, 0, 0, 0, 0, 0, 151,
+ 152, 153, 154, 63, 0, 0, 0, 0, 0, 53,
+ 0, 0, 155, 157, 158, 159, 160, 161, 162, 0,
+ 0, 163, 0, 0, 164, 165, 166, 0, 52, 0,
+ 61, 62, 64, 50, 0, 57, 0, 65, 60, 0,
+ 59, 0, 0, 0, 0, 0, 0, 150, 0, 0,
+ 0, 0, 0, 151, 152, 153, 154, 0, 0, 63,
+ 0, 0, 0, 0, 0, 53, 155, 157, 158, 159,
+ 160, 161, 162, 0, 0, 163, 0, 0, 164, 165,
+ 166, 0, 0, 0, 0, 0, 61, 52, 134, 0,
+ 62, 64, 50, 0, 57, 194, 65, 60, 0, 59,
+ 0, 0, 0, 0, 0, 151, 152, 153, 154, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 63, 0,
+ 0, 53, 160, 161, 162, 0, 0, 163, 0, 0,
+ 164, 165, 166, 0, 0, 0, 87, 0, 0, 87,
+ 24, 25, 26, 27, 28, 61, 29, 30, 31, 0,
+ 0, 0, 32, 87, 87, 0, 0, 0, 87, 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, 87, 0,
+ 0, 54, 88, 55, 56, 88, 24, 25, 26, 27,
+ 28, 0, 29, 30, 31, 0, 0, 0, 32, 88,
+ 88, 0, 0, 0, 88, 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, 88, 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,
+ 243, 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, 87, 87, 87,
+ 87, 0, 0, 0, 0, 0, 87, 52, 0, 61,
+ 62, 64, 50, 87, 57, 276, 65, 60, 0, 59,
+ 0, 0, 87, 87, 0, 87, 87, 87, 87, 87,
+ 0, 0, 0, 0, 0, 0, 0, 0, 63, 0,
+ 0, 0, 0, 0, 53, 0, 0, 0, 0, 0,
+ 0, 0, 0, 88, 88, 88, 88, 0, 0, 0,
+ 0, 0, 88, 52, 0, 61, 62, 64, 50, 0,
+ 57, 278, 65, 60, 0, 59, 0, 0, 88, 88,
+ 0, 88, 88, 88, 88, 88, 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, 286, 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, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 38, 0,
- 39, 40, 41, 0, 0, 0, 0, 42, 43, 44,
- 45, 46, 0, 0, 48, 49, 168, 150, 0, 0,
- 0, 50, 0, 82, 0, 53, 82, 54, 55, 0,
+ 39, 40, 41, 42, 43, 0, 0, 0, 0, 44,
+ 45, 46, 47, 48, 49, 0, 0, 51, 0, 53,
+ 167, 0, 0, 0, 115, 0, 54, 115, 55, 56,
0, 24, 25, 26, 27, 28, 0, 29, 30, 31,
- 82, 82, 0, 32, 0, 82, 0, 0, 150, 0,
- 0, 0, 0, 0, 38, 0, 39, 40, 41, 0,
- 0, 0, 0, 42, 43, 44, 45, 46, 0, 0,
- 48, 49, 0, 0, 0, 82, 0, 50, 0, 0,
- 0, 53, 0, 54, 55, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 24, 25, 26, 27, 28, 0,
- 29, 30, 31, 0, 51, 0, 32, 61, 63, 47,
- 0, 56, 0, 64, 59, 0, 58, 38, 0, 39,
- 40, 41, 0, 0, 0, 0, 42, 43, 44, 45,
- 46, 154, 155, 48, 49, 62, 0, 0, 0, 0,
- 50, 0, 0, 0, 53, 0, 54, 55, 162, 163,
- 0, 0, 164, 0, 0, 165, 166, 167, 0, 0,
- 51, 0, 60, 61, 63, 47, 0, 56, 200, 64,
- 59, 0, 58, 0, 0, 151, 0, 0, 0, 152,
- 153, 154, 155, 0, 0, 0, 0, 0, 0, 0,
- 0, 62, 156, 158, 159, 160, 161, 52, 162, 163,
- 0, 0, 164, 0, 0, 165, 166, 167, 0, 0,
- 152, 0, 154, 155, 0, 0, 51, 0, 60, 61,
- 63, 47, 0, 56, 248, 64, 59, 0, 58, 162,
- 163, 0, 0, 164, 0, 0, 165, 166, 167, 0,
- 0, 0, 0, 0, 0, 0, 0, 62, 0, 0,
- 0, 0, 0, 52, 82, 82, 82, 82, 0, 0,
- 0, 0, 0, 82, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 60, 0, 82, 82, 0, 51,
- 82, 82, 61, 63, 47, 0, 56, 276, 64, 59,
- 0, 58, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 52,
- 62, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 22, 24, 25,
- 26, 27, 28, 0, 29, 30, 31, 60, 0, 0,
- 32, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 38, 0, 39, 40, 41, 0, 0, 0, 0,
- 42, 43, 44, 45, 46, 0, 0, 48, 49, 0,
- 0, 0, 52, 0, 50, 0, 119, 0, 53, 119,
- 54, 55, 0, 0, 24, 25, 26, 27, 28, 0,
- 29, 30, 31, 119, 119, 0, 32, 0, 119, 0,
- 0, 0, 0, 0, 0, 0, 0, 38, 0, 39,
- 40, 41, 0, 0, 0, 0, 42, 43, 44, 45,
- 46, 0, 0, 48, 49, 0, 119, 0, 119, 0,
- 50, 0, 143, 0, 53, 143, 54, 55, 0, 0,
- 24, 25, 26, 27, 28, 0, 29, 30, 31, 143,
- 143, 0, 32, 0, 143, 0, 0, 0, 119, 0,
- 0, 0, 0, 38, 0, 39, 40, 41, 0, 0,
- 0, 0, 42, 43, 44, 45, 46, 0, 0, 48,
- 49, 0, 143, 0, 143, 0, 50, 0, 0, 0,
- 53, 0, 54, 55, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 24, 25, 26, 27, 28, 0, 29,
- 30, 31, 0, 51, 143, 32, 61, 63, 47, 0,
- 56, 278, 64, 59, 0, 58, 38, 0, 39, 40,
- 41, 0, 0, 0, 0, 42, 43, 44, 45, 46,
- 0, 0, 48, 49, 62, 0, 87, 87, 0, 50,
- 0, 0, 0, 53, 0, 54, 55, 0, 103, 0,
- 0, 0, 0, 87, 112, 0, 0, 0, 87, 51,
- 121, 60, 61, 63, 47, 0, 56, 0, 64, 59,
- 0, 58, 87, 87, 87, 87, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 62, 0, 0, 0, 0, 0, 52, 119, 119, 119,
- 119, 0, 0, 0, 0, 0, 119, 0, 0, 0,
- 119, 119, 119, 119, 0, 0, 0, 60, 121, 119,
- 119, 0, 0, 119, 119, 119, 119, 119, 0, 119,
- 119, 0, 130, 119, 0, 130, 119, 119, 119, 0,
- 0, 0, 0, 129, 0, 0, 129, 0, 0, 130,
- 130, 0, 52, 143, 143, 143, 143, 0, 0, 0,
- 129, 129, 143, 0, 0, 129, 143, 143, 143, 143,
- 0, 0, 0, 0, 0, 143, 143, 0, 240, 143,
- 143, 143, 143, 143, 130, 143, 143, 0, 104, 143,
- 0, 104, 143, 143, 143, 129, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 104, 104, 0, 0, 0,
- 104, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 129, 0, 24, 25, 26,
- 27, 28, 0, 29, 30, 31, 0, 0, 104, 32,
- 104, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 38, 0, 39, 40, 41, 0, 0, 0, 0, 42,
- 43, 44, 45, 46, 0, 0, 48, 49, 0, 0,
- 0, 0, 0, 50, 0, 145, 0, 53, 145, 54,
- 55, 0, 0, 24, 25, 26, 27, 28, 0, 29,
- 30, 31, 145, 145, 0, 32, 0, 145, 0, 0,
- 0, 0, 0, 0, 0, 0, 38, 0, 39, 40,
- 41, 0, 0, 0, 0, 42, 43, 44, 45, 46,
- 0, 0, 48, 49, 0, 0, 0, 145, 0, 50,
- 131, 0, 0, 53, 0, 54, 55, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 131, 131, 0,
- 0, 0, 131, 0, 0, 0, 0, 145, 0, 0,
- 0, 0, 0, 130, 130, 130, 130, 0, 0, 0,
- 0, 0, 0, 0, 129, 129, 129, 129, 0, 0,
- 131, 0, 131, 129, 0, 130, 130, 129, 129, 129,
- 129, 0, 0, 0, 0, 0, 129, 129, 0, 0,
- 129, 129, 129, 129, 129, 0, 129, 129, 0, 0,
- 129, 0, 131, 129, 129, 129, 0, 0, 0, 104,
- 104, 104, 104, 0, 0, 0, 0, 0, 104, 0,
- 0, 0, 104, 104, 104, 104, 0, 0, 0, 0,
- 0, 104, 104, 0, 146, 104, 104, 104, 104, 104,
- 0, 104, 104, 0, 0, 104, 0, 0, 104, 104,
- 104, 146, 146, 0, 0, 0, 146, 0, 0, 0,
+ 0, 115, 115, 32, 0, 0, 115, 0, 0, 0,
+ 0, 0, 149, 0, 38, 0, 39, 40, 41, 42,
+ 43, 0, 0, 0, 0, 44, 45, 46, 47, 48,
+ 49, 0, 0, 51, 115, 0, 115, 0, 0, 0,
+ 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, 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, 142, 0, 0, 142,
+ 24, 25, 26, 27, 28, 61, 29, 30, 31, 0,
+ 0, 0, 32, 142, 142, 0, 0, 0, 142, 0,
+ 0, 0, 0, 38, 0, 39, 40, 41, 42, 43,
+ 0, 0, 0, 0, 44, 45, 46, 47, 48, 49,
+ 53, 0, 51, 158, 0, 0, 158, 0, 142, 0,
+ 0, 54, 0, 55, 56, 0, 0, 0, 0, 0,
+ 158, 158, 0, 0, 0, 158, 151, 152, 153, 154,
+ 0, 0, 0, 0, 0, 0, 0, 0, 142, 0,
+ 0, 158, 159, 160, 161, 162, 0, 0, 163, 0,
+ 0, 164, 165, 166, 0, 158, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 115, 115, 115, 115, 0,
+ 159, 0, 0, 0, 115, 0, 0, 0, 0, 0,
+ 115, 115, 115, 115, 0, 158, 0, 159, 159, 0,
+ 115, 115, 159, 115, 115, 115, 115, 115, 115, 115,
+ 0, 0, 115, 0, 0, 115, 115, 115, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 159, 0, 159, 0, 144, 0, 0, 0, 0, 0,
+ 0, 24, 25, 26, 27, 28, 0, 29, 30, 31,
+ 0, 144, 144, 32, 0, 0, 144, 0, 0, 0,
+ 0, 0, 159, 0, 38, 0, 39, 40, 41, 42,
+ 43, 0, 0, 0, 0, 44, 45, 46, 47, 48,
+ 49, 0, 0, 51, 144, 0, 144, 0, 0, 0,
+ 94, 0, 54, 94, 55, 56, 0, 142, 142, 142,
+ 142, 0, 0, 0, 0, 0, 142, 94, 94, 0,
+ 0, 0, 142, 142, 142, 142, 144, 0, 0, 0,
+ 0, 0, 142, 142, 0, 142, 142, 142, 142, 142,
+ 142, 142, 0, 0, 142, 0, 0, 142, 142, 142,
+ 0, 0, 94, 0, 158, 158, 158, 158, 0, 107,
+ 0, 0, 107, 158, 0, 0, 0, 0, 0, 158,
+ 158, 158, 158, 0, 0, 0, 107, 107, 0, 158,
+ 158, 107, 158, 158, 158, 158, 158, 158, 158, 90,
+ 90, 158, 0, 0, 158, 158, 158, 0, 0, 0,
+ 0, 103, 0, 0, 0, 0, 0, 111, 90, 119,
+ 0, 107, 0, 0, 90, 0, 0, 0, 0, 0,
+ 0, 159, 159, 159, 159, 0, 90, 90, 90, 90,
+ 159, 0, 0, 0, 0, 0, 159, 159, 159, 159,
+ 0, 107, 68, 0, 0, 68, 159, 159, 0, 159,
+ 159, 159, 159, 159, 159, 159, 0, 0, 159, 68,
+ 68, 159, 159, 159, 68, 0, 0, 0, 0, 0,
+ 0, 111, 0, 0, 0, 144, 144, 144, 144, 0,
+ 0, 0, 0, 0, 144, 0, 0, 0, 0, 0,
+ 144, 144, 144, 144, 68, 0, 71, 0, 0, 0,
+ 144, 144, 0, 144, 144, 144, 144, 144, 144, 144,
+ 0, 0, 144, 71, 71, 144, 144, 144, 71, 0,
+ 0, 0, 0, 0, 68, 0, 0, 0, 0, 0,
+ 235, 94, 94, 94, 94, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 106, 0, 71, 106, 71, 0,
+ 0, 0, 0, 0, 264, 0, 94, 94, 0, 94,
+ 0, 106, 106, 0, 0, 0, 106, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 71, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 146, 0, 146, 0, 0, 0,
+ 107, 107, 107, 107, 0, 145, 106, 0, 145, 107,
+ 0, 0, 0, 0, 0, 107, 107, 107, 107, 0,
+ 0, 0, 145, 145, 0, 107, 107, 145, 107, 107,
+ 107, 107, 107, 107, 107, 0, 106, 107, 0, 0,
+ 107, 107, 107, 0, 0, 0, 0, 0, 0, 0,
+ 158, 0, 0, 158, 0, 0, 0, 145, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 158, 158, 0,
+ 0, 0, 158, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 68, 68, 68, 68, 0, 0, 0,
+ 0, 0, 68, 0, 0, 0, 0, 0, 68, 68,
+ 68, 68, 158, 0, 113, 0, 0, 113, 68, 68,
+ 0, 68, 68, 68, 68, 68, 68, 68, 0, 0,
+ 68, 113, 113, 68, 68, 68, 113, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 71, 71, 71,
+ 71, 0, 0, 0, 0, 0, 71, 0, 0, 0,
+ 0, 0, 71, 71, 71, 71, 113, 0, 0, 0,
+ 0, 0, 71, 71, 0, 71, 71, 71, 71, 71,
+ 71, 71, 0, 0, 71, 0, 0, 71, 71, 71,
+ 0, 0, 0, 0, 0, 106, 106, 106, 106, 0,
+ 120, 0, 0, 120, 106, 0, 0, 0, 0, 0,
+ 106, 106, 106, 106, 0, 0, 0, 120, 120, 0,
+ 106, 106, 120, 106, 106, 106, 106, 106, 106, 106,
+ 0, 0, 106, 0, 0, 106, 106, 106, 0, 0,
0, 0, 0, 0, 0, 0, 145, 145, 145, 145,
- 0, 0, 0, 0, 0, 145, 0, 0, 0, 145,
- 145, 145, 145, 0, 0, 0, 146, 0, 145, 145,
- 0, 0, 145, 145, 145, 145, 145, 0, 145, 145,
- 59, 0, 145, 59, 0, 145, 145, 145, 0, 0,
- 0, 96, 0, 0, 96, 0, 0, 59, 59, 0,
- 0, 131, 131, 131, 131, 0, 0, 0, 96, 96,
- 131, 0, 0, 96, 131, 131, 131, 131, 0, 0,
- 0, 0, 0, 131, 131, 0, 0, 131, 131, 131,
- 131, 131, 59, 131, 131, 0, 0, 131, 0, 0,
- 131, 131, 131, 96, 58, 0, 0, 58, 0, 0,
+ 0, 103, 120, 0, 103, 145, 0, 0, 0, 0,
+ 0, 145, 145, 145, 145, 0, 0, 0, 103, 103,
+ 0, 145, 145, 103, 145, 145, 145, 145, 145, 145,
+ 145, 0, 0, 145, 0, 0, 145, 145, 145, 0,
+ 0, 158, 158, 158, 158, 0, 0, 0, 0, 0,
+ 158, 0, 0, 103, 0, 0, 158, 158, 158, 158,
+ 0, 0, 104, 0, 0, 104, 158, 158, 0, 158,
+ 158, 158, 158, 158, 158, 158, 0, 0, 158, 104,
+ 104, 158, 158, 158, 104, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 113, 113, 113, 113, 0,
+ 98, 0, 0, 98, 113, 0, 0, 0, 0, 0,
+ 113, 113, 113, 113, 104, 0, 0, 98, 98, 0,
+ 113, 113, 98, 113, 113, 113, 113, 113, 113, 113,
+ 0, 0, 113, 0, 0, 113, 113, 113, 0, 99,
+ 0, 0, 99, 0, 0, 0, 0, 0, 0, 0,
+ 89, 0, 98, 89, 0, 0, 99, 99, 0, 0,
+ 0, 99, 0, 0, 0, 0, 0, 89, 89, 0,
+ 0, 0, 89, 0, 0, 0, 0, 0, 0, 0,
+ 0, 120, 120, 120, 120, 0, 100, 0, 0, 100,
+ 120, 99, 0, 0, 0, 0, 120, 120, 120, 120,
+ 0, 0, 89, 100, 100, 0, 120, 120, 100, 120,
+ 120, 120, 120, 120, 120, 120, 0, 0, 120, 0,
+ 0, 120, 120, 120, 0, 0, 0, 0, 0, 0,
+ 0, 0, 103, 103, 103, 103, 0, 96, 100, 0,
+ 96, 103, 0, 0, 0, 0, 0, 103, 103, 103,
+ 103, 0, 0, 0, 96, 96, 0, 103, 103, 96,
+ 103, 103, 103, 103, 103, 103, 103, 0, 0, 103,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 58, 58, 0, 0, 0, 58, 0, 0, 0,
- 0, 0, 0, 96, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 95, 0, 0,
- 95, 0, 0, 0, 0, 0, 58, 0, 0, 0,
- 0, 0, 0, 0, 95, 95, 0, 0, 0, 95,
- 0, 0, 0, 0, 0, 146, 146, 146, 146, 0,
- 0, 0, 0, 0, 146, 0, 58, 0, 146, 146,
- 146, 146, 0, 0, 0, 61, 0, 146, 146, 95,
- 0, 146, 146, 146, 146, 146, 0, 146, 146, 0,
- 0, 146, 61, 61, 146, 146, 146, 61, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 95,
- 0, 0, 0, 0, 0, 0, 0, 145, 0, 0,
- 145, 0, 0, 0, 0, 61, 0, 61, 0, 0,
- 0, 0, 0, 0, 145, 145, 0, 0, 0, 145,
+ 0, 0, 0, 97, 0, 0, 97, 0, 0, 96,
+ 0, 0, 0, 104, 104, 104, 104, 0, 0, 0,
+ 97, 97, 104, 0, 0, 97, 0, 0, 104, 104,
+ 104, 104, 0, 0, 0, 0, 0, 0, 104, 104,
+ 0, 104, 104, 104, 104, 104, 104, 104, 0, 0,
+ 104, 98, 98, 98, 98, 97, 0, 0, 0, 0,
+ 98, 0, 0, 0, 0, 0, 98, 98, 98, 98,
+ 0, 0, 0, 0, 0, 0, 98, 98, 0, 98,
+ 98, 98, 98, 98, 98, 98, 0, 0, 0, 0,
+ 99, 99, 99, 99, 0, 95, 0, 0, 95, 99,
+ 0, 89, 89, 89, 89, 99, 99, 99, 99, 0,
+ 89, 0, 95, 95, 0, 99, 99, 95, 99, 99,
+ 99, 99, 99, 99, 99, 0, 89, 89, 0, 89,
+ 89, 89, 89, 89, 0, 0, 0, 100, 100, 100,
+ 100, 0, 83, 0, 0, 83, 100, 95, 0, 0,
+ 0, 0, 100, 100, 100, 100, 0, 0, 0, 83,
+ 83, 0, 100, 100, 83, 100, 100, 100, 100, 100,
+ 100, 100, 0, 0, 0, 0, 0, 0, 84, 0,
+ 0, 84, 0, 0, 0, 0, 0, 0, 96, 96,
+ 96, 96, 0, 0, 83, 84, 84, 96, 0, 0,
+ 84, 0, 0, 96, 96, 96, 96, 0, 0, 0,
+ 0, 0, 0, 96, 96, 0, 96, 96, 96, 96,
+ 96, 96, 96, 85, 0, 0, 85, 0, 0, 0,
+ 84, 0, 0, 0, 97, 97, 97, 97, 0, 0,
+ 85, 85, 0, 97, 0, 85, 0, 0, 0, 97,
+ 97, 97, 97, 0, 0, 0, 0, 0, 0, 97,
+ 97, 0, 97, 97, 97, 97, 97, 97, 97, 86,
+ 0, 0, 86, 0, 0, 85, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 86, 86, 0, 0,
+ 0, 86, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 59, 59, 59, 59, 0, 0, 61, 0, 0,
- 0, 0, 96, 96, 96, 96, 0, 0, 0, 145,
- 0, 96, 0, 59, 59, 96, 96, 96, 96, 0,
- 0, 0, 0, 0, 96, 96, 0, 0, 96, 96,
- 96, 96, 96, 0, 96, 96, 0, 0, 96, 0,
- 0, 96, 96, 96, 0, 132, 0, 0, 132, 0,
- 0, 0, 0, 0, 0, 58, 58, 58, 58, 0,
- 0, 0, 132, 132, 58, 0, 0, 132, 58, 58,
- 58, 58, 0, 0, 0, 0, 0, 58, 58, 0,
- 0, 58, 58, 58, 58, 58, 0, 58, 58, 0,
- 0, 58, 0, 0, 58, 58, 58, 132, 95, 95,
- 95, 95, 0, 0, 0, 71, 0, 95, 71, 0,
+ 0, 0, 0, 0, 148, 0, 0, 148, 0, 0,
+ 0, 86, 0, 0, 0, 0, 95, 95, 95, 95,
+ 0, 148, 148, 0, 0, 95, 148, 0, 0, 0,
0, 95, 95, 95, 95, 0, 0, 0, 0, 0,
- 95, 95, 71, 71, 95, 95, 95, 95, 95, 0,
- 95, 95, 0, 0, 95, 0, 0, 95, 95, 95,
- 0, 0, 0, 0, 0, 0, 61, 61, 61, 61,
- 0, 0, 0, 0, 0, 61, 0, 71, 0, 61,
- 61, 61, 61, 0, 0, 0, 0, 0, 61, 61,
- 0, 157, 61, 61, 61, 61, 61, 0, 61, 61,
- 0, 0, 61, 0, 0, 61, 61, 61, 145, 145,
- 145, 145, 0, 0, 0, 0, 0, 145, 0, 168,
- 0, 145, 145, 145, 145, 0, 0, 0, 0, 0,
- 145, 145, 0, 0, 145, 145, 145, 145, 145, 102,
- 145, 145, 102, 0, 145, 0, 0, 145, 145, 145,
- 0, 150, 0, 0, 0, 0, 102, 102, 0, 0,
- 0, 102, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 109, 0, 0, 109,
- 0, 102, 0, 0, 0, 0, 132, 132, 132, 132,
- 0, 0, 0, 109, 109, 132, 0, 0, 109, 132,
- 132, 132, 132, 0, 0, 0, 0, 0, 132, 132,
- 0, 0, 132, 132, 132, 132, 132, 0, 132, 132,
- 92, 0, 132, 92, 0, 132, 132, 132, 109, 0,
- 0, 0, 0, 0, 0, 0, 0, 92, 92, 0,
- 0, 0, 92, 0, 0, 0, 71, 71, 71, 71,
- 0, 0, 0, 0, 0, 0, 0, 93, 0, 0,
- 93, 0, 0, 0, 0, 0, 0, 0, 71, 71,
- 0, 0, 92, 0, 93, 93, 0, 0, 0, 93,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 87, 0, 0, 87, 0, 151,
- 0, 0, 0, 152, 153, 154, 155, 0, 0, 93,
- 0, 87, 87, 0, 0, 0, 87, 158, 159, 160,
- 161, 0, 162, 163, 0, 0, 164, 0, 0, 165,
- 166, 167, 88, 0, 0, 88, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 87, 0, 0, 88,
- 88, 0, 0, 0, 88, 0, 0, 0, 0, 0,
- 102, 102, 102, 102, 0, 0, 0, 0, 0, 102,
- 0, 0, 0, 102, 102, 102, 102, 0, 0, 0,
- 0, 0, 102, 102, 88, 0, 102, 102, 102, 102,
- 102, 0, 102, 102, 0, 0, 102, 0, 0, 102,
- 102, 102, 0, 0, 0, 0, 0, 109, 109, 109,
- 109, 0, 0, 0, 0, 0, 109, 0, 0, 0,
- 109, 109, 109, 109, 0, 0, 0, 0, 0, 109,
- 109, 0, 0, 109, 109, 109, 109, 109, 0, 109,
- 109, 89, 0, 109, 89, 0, 109, 109, 109, 0,
- 0, 92, 92, 92, 92, 0, 0, 0, 89, 89,
- 92, 0, 0, 89, 92, 92, 92, 92, 0, 0,
- 0, 0, 0, 92, 92, 0, 0, 92, 92, 92,
- 92, 92, 0, 92, 92, 0, 0, 92, 93, 93,
- 93, 93, 0, 89, 0, 0, 0, 93, 0, 0,
- 0, 93, 93, 93, 93, 0, 0, 0, 0, 0,
- 93, 93, 0, 0, 93, 93, 93, 93, 93, 0,
- 93, 93, 0, 0, 93, 87, 87, 87, 87, 0,
- 0, 0, 0, 0, 87, 0, 0, 0, 87, 87,
- 87, 87, 0, 0, 0, 0, 0, 87, 87, 0,
- 0, 87, 87, 87, 87, 87, 0, 87, 87, 0,
- 0, 0, 0, 88, 88, 88, 88, 0, 0, 0,
- 0, 0, 88, 0, 0, 0, 88, 88, 88, 88,
- 85, 0, 0, 85, 0, 88, 88, 0, 0, 88,
- 88, 88, 88, 88, 0, 88, 88, 85, 85, 0,
- 0, 0, 85, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 86, 0, 0, 86,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 85, 86, 86, 0, 0, 0, 86, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 84, 0, 0, 84, 0, 0, 0, 0, 86, 0,
- 0, 0, 89, 89, 89, 89, 0, 84, 84, 0,
- 0, 89, 84, 0, 0, 89, 89, 89, 89, 0,
- 0, 0, 0, 0, 89, 89, 0, 0, 89, 89,
- 89, 89, 89, 72, 89, 89, 72, 0, 0, 0,
- 0, 0, 84, 0, 0, 0, 0, 0, 0, 0,
- 72, 72, 0, 0, 0, 72, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 73,
- 0, 0, 73, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 72, 73, 73, 0, 0,
- 0, 73, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 75, 0, 0, 75,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 73, 0, 75, 75, 0, 0, 0, 75, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 85, 85, 85, 85, 0, 0, 0, 0, 0,
- 85, 0, 0, 0, 85, 85, 85, 85, 75, 0,
- 0, 0, 0, 85, 85, 0, 0, 85, 85, 85,
- 85, 85, 0, 85, 85, 0, 0, 86, 86, 86,
- 86, 0, 0, 0, 0, 0, 86, 0, 0, 0,
- 86, 86, 86, 86, 123, 0, 0, 123, 0, 86,
- 86, 0, 0, 86, 86, 86, 86, 86, 0, 86,
- 86, 123, 123, 0, 0, 0, 123, 0, 0, 0,
- 0, 84, 84, 84, 84, 0, 0, 0, 0, 0,
- 84, 0, 0, 0, 84, 84, 84, 84, 0, 0,
- 0, 0, 0, 84, 84, 0, 123, 84, 84, 84,
- 84, 84, 94, 84, 84, 94, 0, 0, 0, 0,
- 0, 0, 0, 0, 72, 72, 72, 72, 0, 94,
- 94, 0, 0, 72, 94, 0, 0, 72, 72, 72,
- 72, 0, 0, 0, 0, 0, 72, 72, 0, 0,
- 72, 72, 72, 72, 72, 0, 72, 72, 0, 0,
- 73, 73, 73, 73, 94, 0, 0, 0, 0, 73,
- 0, 0, 0, 73, 73, 73, 73, 0, 0, 0,
- 0, 0, 73, 73, 0, 0, 73, 73, 73, 73,
- 73, 134, 73, 0, 134, 0, 0, 75, 75, 75,
- 75, 0, 0, 0, 0, 0, 75, 0, 134, 134,
- 75, 75, 0, 134, 0, 0, 0, 0, 0, 75,
- 75, 0, 0, 75, 75, 75, 75, 75, 76, 75,
- 0, 76, 0, 0, 0, 0, 0, 0, 77, 0,
- 0, 77, 0, 134, 0, 76, 76, 0, 0, 0,
- 76, 0, 0, 0, 0, 77, 77, 0, 0, 0,
- 77, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 78, 0, 0, 78, 0, 0,
- 76, 0, 0, 0, 0, 123, 123, 123, 123, 0,
- 77, 78, 78, 0, 123, 0, 78, 0, 123, 123,
- 0, 0, 0, 0, 0, 0, 79, 123, 123, 79,
- 0, 123, 123, 123, 123, 123, 81, 0, 0, 81,
- 0, 0, 0, 79, 79, 0, 78, 0, 79, 0,
- 0, 0, 0, 81, 81, 0, 0, 0, 81, 0,
- 0, 0, 0, 94, 94, 94, 94, 0, 0, 284,
- 0, 0, 94, 0, 157, 0, 94, 94, 79, 0,
- 0, 0, 0, 0, 0, 94, 94, 0, 81, 94,
- 94, 94, 94, 94, 0, 0, 0, 0, 0, 0,
- 0, 0, 168, 0, 0, 0, 0, 0, 0, 0,
+ 0, 95, 95, 0, 95, 95, 95, 95, 95, 95,
+ 95, 147, 0, 0, 147, 0, 148, 0, 0, 0,
+ 0, 0, 0, 83, 83, 83, 83, 0, 147, 147,
+ 0, 0, 83, 147, 0, 0, 0, 0, 83, 83,
+ 83, 83, 0, 0, 0, 0, 0, 134, 83, 83,
+ 134, 83, 83, 83, 83, 83, 83, 83, 0, 84,
+ 84, 84, 84, 147, 134, 134, 0, 0, 84, 134,
+ 0, 0, 0, 0, 84, 84, 84, 84, 0, 0,
+ 0, 0, 0, 0, 84, 84, 0, 84, 84, 84,
+ 84, 84, 84, 105, 0, 0, 105, 0, 0, 134,
+ 0, 0, 0, 0, 85, 85, 85, 85, 0, 0,
+ 105, 105, 0, 85, 0, 105, 0, 0, 0, 85,
+ 85, 0, 85, 0, 0, 0, 0, 0, 0, 85,
+ 85, 0, 85, 85, 85, 85, 85, 85, 90, 0,
+ 0, 90, 0, 0, 0, 105, 0, 0, 0, 0,
+ 86, 86, 86, 86, 0, 90, 90, 0, 0, 86,
+ 90, 0, 167, 0, 0, 86, 86, 0, 0, 0,
+ 92, 0, 0, 92, 0, 86, 86, 0, 86, 86,
+ 86, 86, 86, 86, 0, 0, 0, 92, 92, 0,
+ 90, 0, 92, 0, 149, 148, 148, 148, 148, 0,
+ 0, 0, 0, 0, 148, 0, 0, 0, 0, 0,
+ 148, 148, 91, 0, 0, 91, 0, 0, 0, 0,
+ 148, 148, 92, 148, 148, 148, 148, 148, 0, 91,
+ 91, 0, 143, 0, 91, 143, 0, 0, 0, 0,
+ 0, 0, 147, 147, 147, 147, 0, 0, 0, 143,
+ 143, 147, 0, 0, 0, 284, 0, 147, 147, 82,
+ 156, 0, 82, 0, 91, 0, 0, 147, 147, 0,
+ 147, 147, 147, 147, 147, 0, 82, 82, 134, 134,
+ 134, 134, 0, 0, 143, 0, 0, 134, 167, 0,
+ 0, 0, 0, 134, 134, 69, 0, 0, 69, 0,
+ 0, 0, 0, 134, 134, 0, 134, 134, 134, 134,
+ 134, 82, 69, 69, 0, 0, 0, 0, 0, 0,
+ 149, 0, 0, 0, 105, 105, 105, 105, 0, 0,
+ 0, 0, 0, 105, 0, 0, 0, 0, 0, 105,
+ 105, 0, 0, 0, 0, 0, 0, 69, 0, 105,
+ 105, 156, 105, 105, 105, 105, 105, 0, 151, 152,
+ 153, 154, 0, 0, 0, 0, 0, 0, 0, 90,
+ 90, 90, 90, 0, 159, 160, 161, 162, 90, 167,
+ 163, 0, 0, 164, 165, 166, 0, 0, 0, 0,
+ 0, 0, 0, 0, 90, 90, 0, 90, 90, 90,
+ 90, 92, 92, 92, 92, 0, 0, 0, 0, 0,
+ 92, 149, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 92, 92, 0, 92,
+ 92, 92, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 91, 91, 91, 91, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 143, 143, 143, 143, 0, 91, 91,
+ 0, 91, 0, 0, 0, 0, 0, 0, 150, 0,
+ 0, 0, 0, 0, 151, 152, 153, 154, 143, 143,
+ 82, 82, 82, 82, 0, 0, 0, 155, 157, 158,
+ 159, 160, 161, 162, 0, 0, 163, 0, 0, 164,
+ 165, 166, 0, 0, 0, 82, 82, 0, 0, 0,
+ 0, 0, 0, 0, 94, 0, 69, 69, 69, 69,
+ 0, 0, 104, 0, 0, 0, 109, 0, 0, 118,
+ 0, 0, 0, 0, 0, 0, 125, 126, 127, 128,
+ 129, 69, 69, 132, 133, 0, 0, 0, 0, 0,
+ 140, 0, 0, 0, 0, 0, 0, 0, 0, 150,
+ 0, 0, 0, 0, 0, 151, 152, 153, 154, 0,
+ 0, 0, 0, 0, 0, 0, 0, 183, 0, 157,
+ 158, 159, 160, 161, 162, 0, 0, 163, 0, 0,
+ 164, 165, 166, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 150, 0, 0, 0, 0, 0,
- 0, 0, 134, 134, 134, 134, 0, 0, 0, 0,
- 0, 134, 0, 0, 0, 134, 134, 0, 0, 0,
- 0, 0, 0, 0, 134, 134, 0, 0, 134, 134,
- 134, 134, 134, 0, 0, 0, 0, 0, 0, 76,
- 76, 76, 76, 0, 0, 0, 0, 0, 76, 77,
- 77, 77, 77, 76, 0, 0, 0, 0, 77, 0,
- 0, 76, 76, 0, 0, 76, 76, 76, 76, 76,
- 0, 77, 77, 0, 0, 77, 77, 77, 77, 77,
- 0, 0, 0, 0, 0, 78, 78, 78, 78, 0,
- 0, 0, 0, 0, 78, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 78, 78, 0,
- 0, 78, 78, 78, 78, 78, 0, 79, 79, 79,
- 79, 0, 0, 0, 0, 0, 79, 81, 81, 81,
- 81, 0, 0, 0, 0, 0, 81, 0, 0, 79,
- 79, 0, 0, 79, 79, 79, 79, 0, 0, 81,
- 81, 0, 151, 81, 81, 81, 152, 153, 154, 155,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 156,
- 158, 159, 160, 161, 0, 162, 163, 91, 0, 164,
- 0, 0, 165, 166, 167, 104, 0, 0, 0, 0,
- 111, 113, 0, 0, 0, 0, 0, 125, 126, 127,
- 128, 129, 130, 0, 0, 133, 134, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 183, 0, 0,
+ 0, 0, 0, 0, 217, 218, 219, 220, 221, 222,
+ 223, 224, 225, 226, 227, 228, 229, 230, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 245,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 215, 0, 0, 0, 0, 0, 0, 0, 223, 224,
- 225, 226, 227, 228, 229, 230, 231, 232, 233, 234,
- 235, 236, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 299, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 296, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 312,
+ 0, 0, 0, 0, 0, 0, 0, 0, 315,
};
short yycheck[] = { 13,
- 257, 13, 91, 17, 44, 41, 59, 182, 36, 41,
- 59, 257, 44, 194, 41, 188, 59, 190, 41, 33,
- 34, 35, 36, 59, 82, 40, 58, 59, 41, 43,
- 88, 63, 125, 45, 123, 59, 50, 40, 59, 59,
- 40, 91, 123, 91, 56, 41, 257, 41, 60, 41,
- 41, 41, 278, 41, 36, 41, 44, 93, 116, 40,
- 91, 93, 41, 91, 78, 41, 40, 40, 59, 41,
- 58, 59, 40, 123, 123, 123, 91, 41, 92, 41,
- 40, 95, 94, 97, 96, 99, 98, 101, 100, 41,
- 102, 40, 123, 41, 106, 123, 44, 59, 41, 123,
- 59, 41, 294, 295, 41, 93, 0, 59, 123, 59,
- 58, 59, 287, 59, 44, 59, 59, 59, 299, 59,
- 123, 302, 59, 123, 297, 298, 184, 141, 276, 277,
- 123, 304, 144, 145, 146, 147, 148, 149, 150, 33,
- 40, 123, 36, 37, 38, 93, 40, 260, 42, 43,
- 123, 45, 123, 334, 327, 93, 168, 169, 170, 171,
- 172, 173, 174, 123, 178, 59, 40, 40, 36, 0,
- 64, 185, 40, 266, 267, 268, 257, 270, 271, 41,
- 40, 93, 91, 266, 267, 268, 198, 270, 271, 125,
- 93, 41, 204, 205, 206, 59, 59, 91, 287, 211,
- 41, 125, 33, 91, 257, 36, 37, 38, 295, 40,
- 93, 42, 43, 40, 45, 41, 305, 40, 125, 308,
- 125, 125, 311, 312, 313, 237, 125, 239, 59, 123,
- 258, 125, 126, 64, 59, 125, 272, 273, 274, 275,
- 272, 273, 274, 275, 93, 259, 41, 261, 41, 263,
- 264, 294, 295, 267, 294, 295, 270, 269, 294, 295,
- 91, 41, 294, 295, 44, 313, 298, 294, 295, 93,
- 282, 294, 295, 294, 295, 257, 272, 273, 274, 275,
- 262, 294, 295, 63, 272, 273, 274, 275, 59, 301,
- 123, 305, 123, 41, 125, 126, 0, 93, 294, 295,
- 294, 295, 294, 295, 294, 295, 294, 295, 294, 295,
- 298, 91, 59, 325, 41, 294, 295, 331, 294, 295,
- 59, 335, 294, 295, 272, 273, 274, 275, 41, 33,
- 294, 295, 36, 37, 38, 59, 40, 83, 42, 43,
- 41, 45, 325, 123, 294, 295, 294, 295, 294, 295,
- 294, 295, 294, 295, 13, 59, 294, 295, 269, 93,
- 64, -1, 256, 257, 258, 259, 260, 261, -1, 263,
- 264, 265, 266, 267, 268, 269, 270, 271, 272, 273,
- 274, 275, 294, 295, -1, 279, 280, 91, 282, 283,
- 284, 294, 295, -1, -1, 289, 290, 291, 292, 293,
- -1, -1, 296, 297, -1, 41, -1, -1, 44, 303,
- -1, 294, 295, 307, -1, 309, 310, -1, -1, 123,
- -1, -1, 126, 59, 91, 256, 257, 258, 259, 260,
- 261, -1, 263, 264, 265, 266, 267, 268, 269, 270,
- 271, 272, 273, 274, 275, 294, 295, -1, 279, 280,
- -1, 282, 283, 284, 91, -1, 123, 93, 289, 290,
- 291, 292, 293, -1, -1, 296, 297, -1, -1, -1,
- 294, 295, 303, -1, -1, -1, 307, -1, 309, 310,
- 272, 273, 274, 275, 33, 91, 123, 36, 37, 38,
- -1, 40, 41, 42, 43, 44, 45, -1, 294, 295,
- -1, 281, 294, 295, -1, 285, 286, 287, 288, 58,
- 59, 6, -1, 8, 63, 64, -1, 123, 298, 299,
- 300, 301, 302, -1, 304, 305, -1, -1, 308, -1,
- -1, 311, 312, 313, -1, -1, 31, 32, -1, -1,
- -1, -1, 91, -1, 93, 41, -1, -1, 44, -1,
- -1, 91, 256, 257, 258, 259, 260, 261, -1, 263,
- 264, 265, 58, 59, -1, 269, -1, 63, 272, 273,
- 274, 275, -1, -1, 123, 279, 280, 126, 282, 283,
- 284, -1, -1, 123, -1, 289, 290, 291, 292, 293,
- -1, -1, 296, 297, -1, 91, -1, 93, -1, 303,
- -1, -1, -1, 307, 33, 309, 310, 36, 37, 38,
- -1, 40, 41, 42, 43, 44, 45, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 123, -1, 58,
- 59, -1, -1, -1, 63, 64, 272, 273, 274, 275,
- -1, 308, -1, -1, 311, 312, 313, -1, 285, 286,
- 287, 288, -1, -1, -1, -1, -1, -1, 294, -1,
- -1, -1, -1, -1, 93, 302, -1, 304, 305, -1,
- 41, 308, -1, 44, 311, 312, 313, -1, -1, 285,
- 286, 287, 288, -1, -1, -1, -1, 58, 59, -1,
- -1, -1, 63, 299, 300, 301, 302, 126, 304, 305,
- -1, -1, 308, -1, -1, 311, 312, 313, 257, 258,
- 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
- 269, -1, 93, 272, 273, 274, 275, -1, -1, -1,
- -1, 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, -1, 307, 308,
- 309, 310, 311, 312, 313, 305, -1, -1, 308, 91,
- -1, 311, 312, 313, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, -1, -1, 281, -1, -1, -1, 285,
- 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
- -1, 123, 298, 299, 300, 301, 302, -1, 304, 305,
- -1, -1, 308, -1, -1, 311, 312, 313, 91, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 257, 258,
- 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
+ 36, 86, 41, 36, 40, 44, 182, 59, 59, 41,
+ 93, 40, 59, 91, 91, 59, 257, 41, 257, 58,
+ 59, 41, 191, 41, 63, 59, 44, 91, 91, 59,
+ 329, 40, 46, 41, 93, 40, 93, 41, 257, 41,
+ 58, 59, 41, 57, 122, 63, 123, 61, 97, 98,
+ 99, 100, 101, 102, 93, 59, 41, 59, 41, 123,
+ 123, 360, 91, 44, 297, 298, 41, 41, 276, 277,
+ 40, 40, 278, 91, 40, 93, 326, 327, 0, 123,
+ 59, 331, 59, 36, 59, 59, 59, 40, 59, 123,
+ 123, 41, 106, 107, 123, 40, 40, 347, 123, 41,
+ 40, 351, 271, 59, 41, 123, 40, 123, 44, 59,
+ 260, 33, 257, 289, 36, 37, 38, 59, 40, 40,
+ 42, 43, 59, 45, 40, 93, 41, 40, 125, 143,
+ 144, 145, 146, 147, 148, 149, 305, 59, 91, 91,
+ 257, 36, 64, 192, 41, 266, 267, 268, 41, 270,
+ 271, 44, 91, 167, 168, 169, 170, 171, 172, 173,
+ 125, 41, 93, 298, 44, 58, 59, 40, 182, 91,
+ 123, 249, 186, 187, 41, 189, 254, 191, 58, 59,
+ 41, 350, 41, 63, 198, 0, 200, 201, 41, 41,
+ 41, 205, 40, 93, 41, 93, 59, 125, 59, 125,
+ 93, 123, 125, 125, 126, 125, 257, 41, 125, 59,
+ 41, 91, 123, 93, 297, 298, 41, 231, 33, 233,
+ 234, 36, 37, 38, 257, 40, 59, 42, 43, 262,
+ 45, 40, 93, 272, 273, 274, 275, 314, 297, 298,
+ 297, 298, 281, 123, 59, 297, 298, 41, 41, 64,
+ 297, 298, 337, 123, 272, 273, 274, 275, 297, 298,
+ 296, 300, 301, 281, 0, 297, 298, 123, 282, 287,
+ 288, 289, 290, 297, 298, 289, 91, 297, 298, 297,
+ 298, 59, 300, 301, 302, 303, 304, 305, 306, 297,
+ 298, 309, 41, 307, 312, 313, 314, 33, 297, 298,
+ 36, 37, 38, 41, 40, 258, 42, 43, 123, 45,
+ 125, 126, 297, 298, 297, 298, 297, 298, 297, 298,
+ 297, 298, 41, 59, 297, 298, 297, 298, 64, 297,
+ 298, 59, 346, 41, 256, 257, 258, 259, 260, 261,
+ 41, 263, 264, 265, 266, 267, 268, 269, 270, 271,
+ 272, 273, 274, 275, 59, 91, 8, 279, 280, 32,
+ 282, 283, 284, 285, 286, 125, 297, 298, 63, 291,
+ 292, 293, 294, 295, 296, 13, 144, 299, 307, 272,
+ 273, 274, 275, 346, 189, 96, 308, 123, 310, 311,
+ 126, -1, 272, 273, 274, 275, 91, 297, 298, 297,
+ 298, 281, -1, -1, 297, 298, 91, 287, 288, 289,
+ 290, 272, 273, 274, 275, -1, -1, 297, 298, -1,
+ 300, 301, 302, 303, 304, 305, 306, -1, 123, 309,
+ 91, -1, 312, 313, 314, -1, 297, 298, 123, -1,
+ -1, 256, 257, 258, 259, 260, 261, -1, 263, 264,
+ 265, 266, 267, 268, 269, 270, 271, 272, 273, 274,
+ 275, -1, 123, -1, 279, 280, -1, 282, 283, 284,
+ 285, 286, 272, 273, 274, 275, 291, 292, 293, 294,
+ 295, 296, 41, -1, 299, 44, 91, -1, -1, -1,
+ -1, -1, -1, 308, -1, 310, 311, 297, 298, 58,
+ 59, -1, -1, -1, 63, -1, 266, 267, 268, -1,
+ 270, 271, -1, -1, -1, -1, -1, -1, 123, -1,
+ 256, 257, 258, 259, 260, 261, 125, 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, -1, -1,
+ 91, -1, 308, 33, 310, 311, 36, 37, 38, -1,
+ 40, 41, 42, 43, 44, 45, 281, -1, -1, -1,
+ -1, -1, 287, 288, 289, 290, -1, -1, 58, 59,
+ -1, -1, 123, 63, 64, 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,
+ -1, 91, -1, 93, 33, -1, -1, 36, 37, 38,
+ -1, 40, 41, 42, 43, 44, 45, -1, 309, -1,
+ -1, 312, 313, 314, -1, -1, -1, -1, -1, 58,
+ 59, -1, -1, 123, 63, 64, 126, 266, 267, 268,
+ -1, 270, 271, -1, -1, -1, -1, -1, -1, 302,
+ 303, 304, -1, 306, 289, 290, -1, -1, -1, -1,
+ -1, 13, -1, 33, 93, -1, 36, 37, 38, -1,
+ 40, 306, 42, 43, 309, 45, -1, 312, 313, 314,
+ 333, -1, -1, 272, 273, 274, 275, 340, -1, 59,
+ 42, 344, 281, 45, 64, -1, -1, 126, 287, 288,
+ 289, 290, -1, -1, 357, 358, -1, -1, 297, 298,
+ -1, 300, 301, 302, 303, 304, 305, 306, -1, -1,
+ 309, 91, -1, 312, 313, 314, -1, -1, 41, 81,
+ -1, 44, -1, -1, -1, -1, 287, 288, 289, 290,
+ -1, -1, -1, 95, -1, -1, 59, -1, -1, 91,
+ -1, -1, -1, 123, 305, 306, 126, -1, 309, -1,
+ -1, 312, 313, 314, -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, 141,
+ 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, 178, -1, 257, 258,
+ 259, 260, 261, 185, 263, 264, 265, -1, -1, -1,
269, -1, -1, 272, 273, 274, 275, -1, -1, -1,
- 123, 280, 281, 282, 283, 284, 285, 286, 287, 288,
+ -1, 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, -1, 307, 308,
- 309, 310, 311, 312, 313, 33, 48, 49, 36, 37,
- 38, -1, 40, -1, 42, 43, -1, 45, -1, -1,
- -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
- 281, 59, -1, -1, 285, 286, 64, 288, -1, -1,
- 82, -1, -1, 294, 295, -1, 88, 298, 299, 300,
- 301, 302, -1, 304, -1, -1, -1, -1, -1, -1,
- -1, 33, -1, 91, 36, 37, 38, -1, 40, -1,
- 42, 43, -1, 45, 116, -1, -1, -1, -1, -1,
- -1, 123, -1, 285, 286, 287, 288, 59, -1, -1,
- -1, -1, 64, -1, -1, 123, -1, -1, 126, 301,
- 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
- 312, 313, -1, -1, -1, -1, -1, 33, -1, 91,
- 36, 37, 38, -1, 40, -1, 42, 43, -1, 45,
- -1, -1, -1, -1, 287, 288, -1, -1, -1, -1,
- -1, -1, 184, -1, -1, -1, -1, -1, 64, -1,
- -1, 123, 305, -1, 126, 308, -1, -1, 311, 312,
- 313, -1, -1, -1, 41, -1, -1, 44, -1, -1,
- -1, -1, -1, -1, -1, 91, -1, 26, -1, -1,
- 33, 58, 59, 36, 37, 38, -1, 40, -1, 42,
- 43, -1, 45, 42, -1, -1, -1, -1, 47, -1,
- 49, -1, -1, -1, -1, -1, -1, 123, -1, -1,
- 126, 64, 61, 62, 63, 64, 93, -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, -1, 107, -1,
- -1, 289, 290, 291, 292, 293, -1, -1, 296, 297,
- 123, -1, -1, 126, 91, 303, -1, -1, -1, 307,
- -1, 309, 310, -1, 256, 257, 258, 259, 260, 261,
- -1, 263, 264, 265, -1, -1, -1, 269, -1, -1,
- 272, 273, 274, 275, -1, -1, 123, 279, 280, -1,
- 282, 283, 284, -1, -1, -1, -1, 289, 290, 291,
- 292, 293, -1, -1, 296, 297, -1, -1, -1, -1,
- 91, 303, -1, -1, -1, 307, -1, 309, 310, -1,
- -1, 257, 258, 259, 260, 261, 262, 263, 264, 265,
- 41, -1, -1, 269, -1, -1, -1, -1, -1, -1,
- -1, -1, 123, -1, 280, -1, 282, 283, 284, -1,
- -1, -1, 63, 289, 290, 291, 292, 293, -1, -1,
- 296, 297, -1, -1, -1, -1, -1, 303, -1, -1,
- -1, 307, -1, 309, 310, 272, 273, 274, 275, -1,
- 91, -1, -1, -1, 257, 258, 259, 260, 261, -1,
- 263, 264, 265, -1, -1, -1, 269, 294, 295, -1,
- -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
- 283, 284, 123, -1, -1, -1, 289, 290, 291, 292,
- 293, -1, -1, 296, 297, -1, -1, -1, -1, -1,
- 303, -1, -1, -1, 307, 33, 309, 310, 36, 37,
- 38, -1, 40, -1, 42, 43, -1, 45, 285, 286,
- 287, 288, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 59, -1, 300, 301, 302, 64, 304, 305, -1,
- -1, 308, -1, -1, 311, 312, 313, -1, -1, -1,
+ 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, 91,
+ 43, 291, 292, 293, 294, 295, 296, 33, 51, 299,
+ 36, 37, 38, 123, 40, -1, 42, 43, 308, 45,
+ 310, 311, -1, -1, -1, 287, -1, 289, 290, -1,
+ -1, 123, -1, 59, -1, -1, -1, -1, 64, 272,
+ 273, 274, 275, 305, 306, -1, -1, 309, 91, -1,
+ 312, 313, 314, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 33, 297, 91, 36, 37, 38, -1,
+ 40, 114, 42, 43, 26, 45, -1, -1, -1, 122,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 33, -1, 91, 36, 37, 38, -1, 40, -1,
- 42, 43, -1, 45, 285, 286, 287, 288, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 64, 304, 305, -1, -1, 308, 126, -1,
- 311, 312, 313, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 33, -1, 91,
- 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
+ -1, 43, 44, -1, 64, -1, -1, 123, 50, -1,
+ 126, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 62, 63, 64, 65, -1, -1, -1, -1, -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,
- 281, -1, -1, -1, 285, 286, 287, 288, 64, -1,
- -1, 123, -1, -1, 126, -1, -1, 298, 299, 300,
- 301, 302, -1, 304, 305, -1, -1, 308, -1, -1,
- 311, 312, 313, -1, -1, 91, -1, -1, -1, -1,
- 33, -1, -1, 36, 37, 38, -1, 40, -1, 42,
- 43, -1, 45, -1, -1, -1, -1, -1, -1, -1,
+ 64, -1, -1, 123, -1, 107, 126, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 126, 64, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 257,
- 258, 259, 260, 261, -1, 263, 264, 265, 91, -1,
- 93, 269, -1, -1, -1, 91, -1, -1, -1, -1,
- -1, -1, 280, -1, 282, 283, 284, -1, -1, -1,
- -1, 289, 290, 291, 292, 293, -1, 63, 296, 297,
- -1, -1, -1, 126, -1, 303, -1, 123, -1, 307,
- -1, 309, 310, -1, -1, 257, 258, 259, 260, 261,
- -1, 263, 264, 265, -1, 91, -1, 269, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 280, -1,
- 282, 283, 284, -1, -1, -1, -1, 289, 290, 291,
- 292, 293, -1, -1, 296, 297, 91, 123, -1, -1,
- -1, 303, -1, 41, -1, 307, 44, 309, 310, -1,
+ -1, -1, -1, -1, -1, -1, -1, 91, -1, 289,
+ 290, -1, 33, -1, -1, 36, 37, 38, -1, 40,
+ -1, 42, 43, -1, 45, 305, 306, 289, -1, 309,
+ -1, -1, 312, 313, 314, -1, 249, -1, -1, 123,
+ -1, 254, 126, 64, 306, -1, -1, 309, -1, -1,
+ 312, 313, 314, -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, 91, 123, 299, -1, 126, -1, -1, -1, -1,
+ -1, -1, 308, 41, 310, 311, 44, 257, 258, 259,
+ 260, 261, 262, 263, 264, 265, -1, -1, -1, 269,
+ -1, -1, -1, 123, -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, 91, -1, -1, -1, 41, 308, -1,
+ 310, 311, -1, 257, 258, 259, 260, 261, -1, 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, -1,
+ -1, -1, -1, -1, -1, -1, 257, 258, 259, 260,
+ 261, -1, 263, 264, 265, -1, -1, -1, 269, 123,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 280,
+ -1, 282, 283, 284, 285, 286, -1, -1, -1, 91,
+ 291, 292, 293, 294, 295, 296, 33, -1, 299, 36,
+ 37, 38, -1, 40, -1, 42, 43, 308, 45, 310,
+ 311, -1, -1, -1, -1, -1, -1, 287, 288, 289,
+ 290, 123, 59, -1, -1, -1, -1, 64, -1, -1,
+ -1, 301, 302, 303, 304, 305, 306, -1, -1, 309,
+ -1, -1, 312, 313, 314, -1, -1, -1, -1, -1,
+ -1, -1, 33, -1, 91, 36, 37, 38, -1, 40,
+ 41, 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, 33, -1,
+ 91, 36, 37, 38, -1, 40, -1, 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, -1, -1, 91, 33, 93, -1,
+ 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 64, -1,
+ -1, 126, 304, 305, 306, -1, -1, 309, -1, -1,
+ 312, 313, 314, -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, -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,
- 58, 59, -1, 269, -1, 63, -1, -1, 123, -1,
- -1, -1, -1, -1, 280, -1, 282, 283, 284, -1,
- -1, -1, -1, 289, 290, 291, 292, 293, -1, -1,
- 296, 297, -1, -1, -1, 93, -1, 303, -1, -1,
- -1, 307, -1, 309, 310, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 257, 258, 259, 260, 261, -1,
- 263, 264, 265, -1, 33, -1, 269, 36, 37, 38,
- -1, 40, -1, 42, 43, -1, 45, 280, -1, 282,
- 283, 284, -1, -1, -1, -1, 289, 290, 291, 292,
- 293, 287, 288, 296, 297, 64, -1, -1, -1, -1,
- 303, -1, -1, -1, 307, -1, 309, 310, 304, 305,
- -1, -1, 308, -1, -1, 311, 312, 313, -1, -1,
- 33, -1, 91, 36, 37, 38, -1, 40, 41, 42,
- 43, -1, 45, -1, -1, 281, -1, -1, -1, 285,
- 286, 287, 288, -1, -1, -1, -1, -1, -1, -1,
- -1, 64, 298, 299, 300, 301, 302, 126, 304, 305,
- -1, -1, 308, -1, -1, 311, 312, 313, -1, -1,
- 285, -1, 287, 288, -1, -1, 33, -1, 91, 36,
- 37, 38, -1, 40, 41, 42, 43, -1, 45, 304,
- 305, -1, -1, 308, -1, -1, 311, 312, 313, -1,
- -1, -1, -1, -1, -1, -1, -1, 64, -1, -1,
- -1, -1, -1, 126, 272, 273, 274, 275, -1, -1,
- -1, -1, -1, 281, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 91, -1, 294, 295, -1, 33,
- 298, 299, 36, 37, 38, -1, 40, 41, 42, 43,
- -1, 45, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 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, -1, -1, -1, -1, -1, -1, -1,
- -1, 280, -1, 282, 283, 284, -1, -1, -1, -1,
- 289, 290, 291, 292, 293, -1, -1, 296, 297, -1,
- -1, -1, 126, -1, 303, -1, 41, -1, 307, 44,
- 309, 310, -1, -1, 257, 258, 259, 260, 261, -1,
- 263, 264, 265, 58, 59, -1, 269, -1, 63, -1,
- -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
- 283, 284, -1, -1, -1, -1, 289, 290, 291, 292,
- 293, -1, -1, 296, 297, -1, 91, -1, 93, -1,
- 303, -1, 41, -1, 307, 44, 309, 310, -1, -1,
- 257, 258, 259, 260, 261, -1, 263, 264, 265, 58,
- 59, -1, 269, -1, 63, -1, -1, -1, 123, -1,
- -1, -1, -1, 280, -1, 282, 283, 284, -1, -1,
- -1, -1, 289, 290, 291, 292, 293, -1, -1, 296,
- 297, -1, 91, -1, 93, -1, 303, -1, -1, -1,
- 307, -1, 309, 310, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 257, 258, 259, 260, 261, -1, 263,
- 264, 265, -1, 33, 123, 269, 36, 37, 38, -1,
- 40, 41, 42, 43, -1, 45, 280, -1, 282, 283,
- 284, -1, -1, -1, -1, 289, 290, 291, 292, 293,
- -1, -1, 296, 297, 64, -1, 25, 26, -1, 303,
- -1, -1, -1, 307, -1, 309, 310, -1, 37, -1,
- -1, -1, -1, 42, 43, -1, -1, -1, 47, 33,
- 49, 91, 36, 37, 38, -1, 40, -1, 42, 43,
- -1, 45, 61, 62, 63, 64, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 64, -1, -1, -1, -1, -1, 126, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
- 285, 286, 287, 288, -1, -1, -1, 91, 107, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
- 305, -1, 41, 308, -1, 44, 311, 312, 313, -1,
- -1, -1, -1, 41, -1, -1, 44, -1, -1, 58,
- 59, -1, 126, 272, 273, 274, 275, -1, -1, -1,
- 58, 59, 281, -1, -1, 63, 285, 286, 287, 288,
- -1, -1, -1, -1, -1, 294, 295, -1, 167, 298,
- 299, 300, 301, 302, 93, 304, 305, -1, 41, 308,
- -1, 44, 311, 312, 313, 93, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 58, 59, -1, -1, -1,
- 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 123, -1, 257, 258, 259,
- 260, 261, -1, 263, 264, 265, -1, -1, 91, 269,
- 93, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 280, -1, 282, 283, 284, -1, -1, -1, -1, 289,
- 290, 291, 292, 293, -1, -1, 296, 297, -1, -1,
- -1, -1, -1, 303, -1, 41, -1, 307, 44, 309,
- 310, -1, -1, 257, 258, 259, 260, 261, -1, 263,
- 264, 265, 58, 59, -1, 269, -1, 63, -1, -1,
- -1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
- 284, -1, -1, -1, -1, 289, 290, 291, 292, 293,
- -1, -1, 296, 297, -1, -1, -1, 93, -1, 303,
- 41, -1, -1, 307, -1, 309, 310, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 58, 59, -1,
- -1, -1, 63, -1, -1, -1, -1, 123, -1, -1,
+ 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, -1, -1, 281, 33, -1, 91,
+ 36, 37, 38, 288, 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,
- -1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
- 91, -1, 93, 281, -1, 294, 295, 285, 286, 287,
- 288, -1, -1, -1, -1, -1, 294, 295, -1, -1,
- 298, 299, 300, 301, 302, -1, 304, 305, -1, -1,
- 308, -1, 123, 311, 312, 313, -1, -1, -1, 272,
- 273, 274, 275, -1, -1, -1, -1, -1, 281, -1,
- -1, -1, 285, 286, 287, 288, -1, -1, -1, -1,
- -1, 294, 295, -1, 41, 298, 299, 300, 301, 302,
- -1, 304, 305, -1, -1, 308, -1, -1, 311, 312,
- 313, 58, 59, -1, -1, -1, 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, 91, -1, 93, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, -1, -1, 281, -1, -1, -1, 285,
- 286, 287, 288, -1, -1, -1, 123, -1, 294, 295,
- -1, -1, 298, 299, 300, 301, 302, -1, 304, 305,
- 41, -1, 308, 44, -1, 311, 312, 313, -1, -1,
- -1, 41, -1, -1, 44, -1, -1, 58, 59, -1,
- -1, 272, 273, 274, 275, -1, -1, -1, 58, 59,
- 281, -1, -1, 63, 285, 286, 287, 288, -1, -1,
- -1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
- 301, 302, 93, 304, 305, -1, -1, 308, -1, -1,
- 311, 312, 313, 93, 41, -1, -1, 44, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 58, 59, -1, -1, -1, 63, -1, -1, -1,
- -1, -1, -1, 123, -1, -1, -1, -1, -1, -1,
- -1, -1, -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, -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, -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, 126,
+ 91, -1, -1, -1, 41, -1, 308, 44, 310, 311,
+ -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
+ -1, 58, 59, 269, -1, -1, 63, -1, -1, -1,
+ -1, -1, 123, -1, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
+ 296, -1, -1, 299, 91, -1, 93, -1, -1, -1,
+ -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, -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, -1, 299, 41, -1, -1, 44, -1, 93, -1,
+ -1, 308, -1, 310, 311, -1, -1, -1, -1, -1,
+ 58, 59, -1, -1, -1, 63, 287, 288, 289, 290,
+ -1, -1, -1, -1, -1, -1, -1, -1, 123, -1,
+ -1, 302, 303, 304, 305, 306, -1, -1, 309, -1,
+ -1, 312, 313, 314, -1, 93, -1, -1, -1, -1,
-1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- -1, -1, -1, -1, 281, -1, 123, -1, 285, 286,
- 287, 288, -1, -1, -1, 41, -1, 294, 295, 93,
- -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
- -1, 308, 58, 59, 311, 312, 313, 63, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 123,
- -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
- 44, -1, -1, -1, -1, 91, -1, 93, -1, -1,
- -1, -1, -1, -1, 58, 59, -1, -1, -1, 63,
+ 41, -1, -1, -1, 281, -1, -1, -1, -1, -1,
+ 287, 288, 289, 290, -1, 123, -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, -1, -1, -1, -1, -1, -1, -1,
- -1, 272, 273, 274, 275, -1, -1, 123, -1, -1,
- -1, -1, 272, 273, 274, 275, -1, -1, -1, 93,
- -1, 281, -1, 294, 295, 285, 286, 287, 288, -1,
- -1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
- 300, 301, 302, -1, 304, 305, -1, -1, 308, -1,
- -1, 311, 312, 313, -1, 41, -1, -1, 44, -1,
- -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- -1, -1, 58, 59, 281, -1, -1, 63, 285, 286,
- 287, 288, -1, -1, -1, -1, -1, 294, 295, -1,
- -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
- -1, 308, -1, -1, 311, 312, 313, 93, 272, 273,
- 274, 275, -1, -1, -1, 41, -1, 281, 44, -1,
- -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
- 294, 295, 58, 59, 298, 299, 300, 301, 302, -1,
- 304, 305, -1, -1, 308, -1, -1, 311, 312, 313,
- -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, -1, -1, 281, -1, 93, -1, 285,
- 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
- -1, 63, 298, 299, 300, 301, 302, -1, 304, 305,
- -1, -1, 308, -1, -1, 311, 312, 313, 272, 273,
- 274, 275, -1, -1, -1, -1, -1, 281, -1, 91,
- -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
- 294, 295, -1, -1, 298, 299, 300, 301, 302, 41,
- 304, 305, 44, -1, 308, -1, -1, 311, 312, 313,
- -1, 123, -1, -1, -1, -1, 58, 59, -1, -1,
- -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
+ 91, -1, 93, -1, 41, -1, -1, -1, -1, -1,
+ -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
+ -1, 58, 59, 269, -1, -1, 63, -1, -1, -1,
+ -1, -1, 123, -1, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
+ 296, -1, -1, 299, 91, -1, 93, -1, -1, -1,
+ 41, -1, 308, 44, 310, 311, -1, 272, 273, 274,
+ 275, -1, -1, -1, -1, -1, 281, 58, 59, -1,
+ -1, -1, 287, 288, 289, 290, 123, -1, -1, -1,
+ -1, -1, 297, 298, -1, 300, 301, 302, 303, 304,
+ 305, 306, -1, -1, 309, -1, -1, 312, 313, 314,
+ -1, -1, 93, -1, 272, 273, 274, 275, -1, 41,
+ -1, -1, 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, 25,
+ 26, 309, -1, -1, 312, 313, 314, -1, -1, -1,
+ -1, 37, -1, -1, -1, -1, -1, 43, 44, 45,
+ -1, 93, -1, -1, 50, -1, -1, -1, -1, -1,
+ -1, 272, 273, 274, 275, -1, 62, 63, 64, 65,
+ 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
+ -1, 123, 41, -1, -1, 44, 297, 298, -1, 300,
+ 301, 302, 303, 304, 305, 306, -1, -1, 309, 58,
+ 59, 312, 313, 314, 63, -1, -1, -1, -1, -1,
+ -1, 107, -1, -1, -1, 272, 273, 274, 275, -1,
+ -1, -1, -1, -1, 281, -1, -1, -1, -1, -1,
+ 287, 288, 289, 290, 93, -1, 41, -1, -1, -1,
+ 297, 298, -1, 300, 301, 302, 303, 304, 305, 306,
+ -1, -1, 309, 58, 59, 312, 313, 314, 63, -1,
+ -1, -1, -1, -1, 123, -1, -1, -1, -1, -1,
+ 166, 272, 273, 274, 275, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 41, -1, 91, 44, 93, -1,
+ -1, -1, -1, -1, 190, -1, 297, 298, -1, 300,
+ -1, 58, 59, -1, -1, -1, 63, -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, -1, -1, -1, -1, 41, -1, -1, 44,
- -1, 93, -1, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, 58, 59, 281, -1, -1, 63, 285,
- 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
- -1, -1, 298, 299, 300, 301, 302, -1, 304, 305,
- 41, -1, 308, 44, -1, 311, 312, 313, 93, -1,
+ 272, 273, 274, 275, -1, 41, 93, -1, 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, 123, 309, -1, -1,
+ 312, 313, 314, -1, -1, -1, -1, -1, -1, -1,
+ 41, -1, -1, 44, -1, -1, -1, 93, -1, -1,
-1, -1, -1, -1, -1, -1, -1, 58, 59, -1,
- -1, -1, 63, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
- 44, -1, -1, -1, -1, -1, -1, -1, 294, 295,
- -1, -1, 93, -1, 58, 59, -1, -1, -1, 63,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 41, -1, -1, 44, -1, 281,
- -1, -1, -1, 285, 286, 287, 288, -1, -1, 93,
- -1, 58, 59, -1, -1, -1, 63, 299, 300, 301,
- 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
- 312, 313, 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,
- 272, 273, 274, 275, -1, -1, -1, -1, -1, 281,
- -1, -1, -1, 285, 286, 287, 288, -1, -1, -1,
- -1, -1, 294, 295, 93, -1, 298, 299, 300, 301,
- 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
- 312, 313, -1, -1, -1, -1, -1, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
- 285, 286, 287, 288, -1, -1, -1, -1, -1, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
- 305, 41, -1, 308, 44, -1, 311, 312, 313, -1,
- -1, 272, 273, 274, 275, -1, -1, -1, 58, 59,
- 281, -1, -1, 63, 285, 286, 287, 288, -1, -1,
- -1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
- 301, 302, -1, 304, 305, -1, -1, 308, 272, 273,
- 274, 275, -1, 93, -1, -1, -1, 281, -1, -1,
- -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
- 294, 295, -1, -1, 298, 299, 300, 301, 302, -1,
- 304, 305, -1, -1, 308, 272, 273, 274, 275, -1,
- -1, -1, -1, -1, 281, -1, -1, -1, 285, 286,
- 287, 288, -1, -1, -1, -1, -1, 294, 295, -1,
- -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
+ -1, -1, 63, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
- -1, -1, 281, -1, -1, -1, 285, 286, 287, 288,
- 41, -1, -1, 44, -1, 294, 295, -1, -1, 298,
- 299, 300, 301, 302, -1, 304, 305, 58, 59, -1,
+ -1, -1, 281, -1, -1, -1, -1, -1, 287, 288,
+ 289, 290, 93, -1, 41, -1, -1, 44, 297, 298,
+ -1, 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, -1, 272, 273, 274,
+ 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
+ -1, -1, 287, 288, 289, 290, 93, -1, -1, -1,
+ -1, -1, 297, 298, -1, 300, 301, 302, 303, 304,
+ 305, 306, -1, -1, 309, -1, -1, 312, 313, 314,
+ -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
+ 41, -1, -1, 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, -1, -1,
+ -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
+ -1, 41, 93, -1, 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, -1,
+ -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
+ 281, -1, -1, 93, -1, -1, 287, 288, 289, 290,
+ -1, -1, 41, -1, -1, 44, 297, 298, -1, 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, -1, 272, 273, 274, 275, -1,
+ 41, -1, -1, 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, -1, 41,
+ -1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
+ 41, -1, 93, 44, -1, -1, 58, 59, -1, -1,
+ -1, 63, -1, -1, -1, -1, -1, 58, 59, -1,
-1, -1, 63, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 41, -1, -1, 44,
+ -1, 272, 273, 274, 275, -1, 41, -1, -1, 44,
+ 281, 93, -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, 312, 313, 314, -1, -1, -1, -1, -1, -1,
+ -1, -1, 272, 273, 274, 275, -1, 41, 93, -1,
+ 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, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 93, 58, 59, -1, -1, -1, 63, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 41, -1, -1, 44, -1, -1, -1, -1, 93, -1,
- -1, -1, 272, 273, 274, 275, -1, 58, 59, -1,
- -1, 281, 63, -1, -1, 285, 286, 287, 288, -1,
- -1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
- 300, 301, 302, 41, 304, 305, 44, -1, -1, -1,
- -1, -1, 93, -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, 41,
- -1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 93, 58, 59, -1, -1,
+ -1, -1, -1, 41, -1, -1, 44, -1, -1, 93,
+ -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
+ 58, 59, 281, -1, -1, 63, -1, -1, 287, 288,
+ 289, 290, -1, -1, -1, -1, -1, -1, 297, 298,
+ -1, 300, 301, 302, 303, 304, 305, 306, -1, -1,
+ 309, 272, 273, 274, 275, 93, -1, -1, -1, -1,
+ 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
+ -1, -1, -1, -1, -1, -1, 297, 298, -1, 300,
+ 301, 302, 303, 304, 305, 306, -1, -1, -1, -1,
+ 272, 273, 274, 275, -1, 41, -1, -1, 44, 281,
+ -1, 272, 273, 274, 275, 287, 288, 289, 290, -1,
+ 281, -1, 58, 59, -1, 297, 298, 63, 300, 301,
+ 302, 303, 304, 305, 306, -1, 297, 298, -1, 300,
+ 301, 302, 303, 304, -1, -1, -1, 272, 273, 274,
+ 275, -1, 41, -1, -1, 44, 281, 93, -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, -1, -1, -1, -1, 41, -1,
+ -1, 44, -1, -1, -1, -1, -1, -1, 272, 273,
+ 274, 275, -1, -1, 93, 58, 59, 281, -1, -1,
+ 63, -1, -1, 287, 288, 289, 290, -1, -1, -1,
+ -1, -1, -1, 297, 298, -1, 300, 301, 302, 303,
+ 304, 305, 306, 41, -1, -1, 44, -1, -1, -1,
+ 93, -1, -1, -1, 272, 273, 274, 275, -1, -1,
+ 58, 59, -1, 281, -1, 63, -1, -1, -1, 287,
+ 288, 289, 290, -1, -1, -1, -1, -1, -1, 297,
+ 298, -1, 300, 301, 302, 303, 304, 305, 306, 41,
+ -1, -1, 44, -1, -1, 93, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 58, 59, -1, -1,
-1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 41, -1, -1, 44,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 93, -1, 58, 59, -1, -1, -1, 63, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
- 281, -1, -1, -1, 285, 286, 287, 288, 93, -1,
- -1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
- 301, 302, -1, 304, 305, -1, -1, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
- 285, 286, 287, 288, 41, -1, -1, 44, -1, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
- 305, 58, 59, -1, -1, -1, 63, -1, -1, -1,
- -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
- 281, -1, -1, -1, 285, 286, 287, 288, -1, -1,
- -1, -1, -1, 294, 295, -1, 93, 298, 299, 300,
- 301, 302, 41, 304, 305, 44, -1, -1, -1, -1,
- -1, -1, -1, -1, 272, 273, 274, 275, -1, 58,
- 59, -1, -1, 281, 63, -1, -1, 285, 286, 287,
- 288, -1, -1, -1, -1, -1, 294, 295, -1, -1,
- 298, 299, 300, 301, 302, -1, 304, 305, -1, -1,
- 272, 273, 274, 275, 93, -1, -1, -1, -1, 281,
- -1, -1, -1, 285, 286, 287, 288, -1, -1, -1,
- -1, -1, 294, 295, -1, -1, 298, 299, 300, 301,
- 302, 41, 304, -1, 44, -1, -1, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, 58, 59,
- 285, 286, -1, 63, -1, -1, -1, -1, -1, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, 41, 304,
- -1, 44, -1, -1, -1, -1, -1, -1, 41, -1,
- -1, 44, -1, 93, -1, 58, 59, -1, -1, -1,
- 63, -1, -1, -1, -1, 58, 59, -1, -1, -1,
- 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, 41, -1, -1, 44, -1, -1,
- 93, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- 93, 58, 59, -1, 281, -1, 63, -1, 285, 286,
- -1, -1, -1, -1, -1, -1, 41, 294, 295, 44,
- -1, 298, 299, 300, 301, 302, 41, -1, -1, 44,
- -1, -1, -1, 58, 59, -1, 93, -1, 63, -1,
- -1, -1, -1, 58, 59, -1, -1, -1, 63, -1,
- -1, -1, -1, 272, 273, 274, 275, -1, -1, 58,
- -1, -1, 281, -1, 63, -1, 285, 286, 93, -1,
- -1, -1, -1, -1, -1, 294, 295, -1, 93, 298,
- 299, 300, 301, 302, -1, -1, -1, -1, -1, -1,
- -1, -1, 91, -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, 123, -1, -1, -1, -1, -1,
- -1, -1, 272, 273, 274, 275, -1, -1, -1, -1,
- -1, 281, -1, -1, -1, 285, 286, -1, -1, -1,
- -1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
- 300, 301, 302, -1, -1, -1, -1, -1, -1, 272,
- 273, 274, 275, -1, -1, -1, -1, -1, 281, 272,
- 273, 274, 275, 286, -1, -1, -1, -1, 281, -1,
- -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
- -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
- -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
+ -1, 93, -1, -1, -1, -1, 272, 273, 274, 275,
+ -1, 58, 59, -1, -1, 281, 63, -1, -1, -1,
+ -1, 287, 288, 289, 290, -1, -1, -1, -1, -1,
+ -1, 297, 298, -1, 300, 301, 302, 303, 304, 305,
+ 306, 41, -1, -1, 44, -1, 93, -1, -1, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, 58, 59,
+ -1, -1, 281, 63, -1, -1, -1, -1, 287, 288,
+ 289, 290, -1, -1, -1, -1, -1, 41, 297, 298,
+ 44, 300, 301, 302, 303, 304, 305, 306, -1, 272,
+ 273, 274, 275, 93, 58, 59, -1, -1, 281, 63,
+ -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
+ -1, -1, -1, -1, 297, 298, -1, 300, 301, 302,
+ 303, 304, 305, 41, -1, -1, 44, -1, -1, 93,
+ -1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
+ 58, 59, -1, 281, -1, 63, -1, -1, -1, 287,
+ 288, -1, 290, -1, -1, -1, -1, -1, -1, 297,
+ 298, -1, 300, 301, 302, 303, 304, 305, 41, -1,
+ -1, 44, -1, -1, -1, 93, -1, -1, -1, -1,
+ 272, 273, 274, 275, -1, 58, 59, -1, -1, 281,
+ 63, -1, 91, -1, -1, 287, 288, -1, -1, -1,
+ 41, -1, -1, 44, -1, 297, 298, -1, 300, 301,
+ 302, 303, 304, 305, -1, -1, -1, 58, 59, -1,
+ 93, -1, 63, -1, 123, 272, 273, 274, 275, -1,
-1, -1, -1, -1, 281, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 294, 295, -1,
- -1, 298, 299, 300, 301, 302, -1, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, 294,
- 295, -1, -1, 298, 299, 300, 301, -1, -1, 294,
- 295, -1, 281, 298, 299, 300, 285, 286, 287, 288,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 298,
- 299, 300, 301, 302, -1, 304, 305, 30, -1, 308,
- -1, -1, 311, 312, 313, 38, -1, -1, -1, -1,
- 43, 44, -1, -1, -1, -1, -1, 50, 51, 52,
- 53, 54, 55, -1, -1, 58, 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, -1, -1, -1, -1, -1, 90, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 287, 288, 41, -1, -1, 44, -1, -1, -1, -1,
+ 297, 298, 93, 300, 301, 302, 303, 304, -1, 58,
+ 59, -1, 41, -1, 63, 44, -1, -1, -1, -1,
+ -1, -1, 272, 273, 274, 275, -1, -1, -1, 58,
+ 59, 281, -1, -1, -1, 58, -1, 287, 288, 41,
+ 63, -1, 44, -1, 93, -1, -1, 297, 298, -1,
+ 300, 301, 302, 303, 304, -1, 58, 59, 272, 273,
+ 274, 275, -1, -1, 93, -1, -1, 281, 91, -1,
+ -1, -1, -1, 287, 288, 41, -1, -1, 44, -1,
+ -1, -1, -1, 297, 298, -1, 300, 301, 302, 303,
+ 304, 93, 58, 59, -1, -1, -1, -1, -1, -1,
+ 123, -1, -1, -1, 272, 273, 274, 275, -1, -1,
+ -1, -1, -1, 281, -1, -1, -1, -1, -1, 287,
+ 288, -1, -1, -1, -1, -1, -1, 93, -1, 297,
+ 298, 63, 300, 301, 302, 303, 304, -1, 287, 288,
+ 289, 290, -1, -1, -1, -1, -1, -1, -1, 272,
+ 273, 274, 275, -1, 303, 304, 305, 306, 281, 91,
+ 309, -1, -1, 312, 313, 314, -1, -1, -1, -1,
+ -1, -1, -1, -1, 297, 298, -1, 300, 301, 302,
+ 303, 272, 273, 274, 275, -1, -1, -1, -1, -1,
+ 281, 123, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 297, 298, -1, 300,
+ 301, 302, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, 297, 298,
+ -1, 300, -1, -1, -1, -1, -1, -1, 281, -1,
+ -1, -1, -1, -1, 287, 288, 289, 290, 297, 298,
+ 272, 273, 274, 275, -1, -1, -1, 300, 301, 302,
+ 303, 304, 305, 306, -1, -1, 309, -1, -1, 312,
+ 313, 314, -1, -1, -1, 297, 298, -1, -1, -1,
+ -1, -1, -1, -1, 30, -1, 272, 273, 274, 275,
+ -1, -1, 38, -1, -1, -1, 42, -1, -1, 45,
+ -1, -1, -1, -1, -1, -1, 52, 53, 54, 55,
+ 56, 297, 298, 59, 60, -1, -1, -1, -1, -1,
+ 66, -1, -1, -1, -1, -1, -1, -1, -1, 281,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
+ -1, -1, -1, -1, -1, -1, -1, 93, -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,
- 143, -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, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 150, 151, 152, 153, 154, 155,
+ 156, 157, 158, 159, 160, 161, 162, 163, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 175,
-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,
@@ -1107,16 +1057,16 @@ short yycheck[] = { 13,
-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, 256, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 253, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 284,
+ -1, -1, -1, -1, -1, -1, -1, -1, 284,
};
#define YYFINAL 1
#ifndef YYDEBUG
#define YYDEBUG 0
#endif
-#define YYMAXTOKEN 313
+#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,
@@ -1129,9 +1079,9 @@ char *yyname[] = {
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","RELOP","EQOP",
-"MULOP","ADDOP","DOLSHARP","DO","LOCAL","HASHBRACK","NOAMP","OROP","ANDOP",
-"NOTOP","LSTOP","ASSIGNOP","OROR","ANDAND","BITOROP","BITANDOP","UNIOP",
+"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",
};
@@ -1141,6 +1091,8 @@ char *yyrule[] = {
"prog : $$1 lineseq",
"block : '{' remember lineseq '}'",
"remember :",
+"mblock : '{' mremember lineseq '}'",
+"mremember :",
"lineseq :",
"lineseq : lineseq decl",
"lineseq : lineseq line",
@@ -1153,44 +1105,52 @@ char *yyrule[] = {
"sideff : expr IF expr",
"sideff : expr UNLESS expr",
"sideff : expr WHILE expr",
-"sideff : expr UNTIL expr",
+"sideff : expr UNTIL iexpr",
"else :",
-"else : ELSE block",
-"else : ELSIF '(' expr ')' block else",
-"cond : IF '(' expr ')' block else",
-"cond : UNLESS '(' expr ')' block else",
-"cond : IF block block else",
-"cond : UNLESS block block 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 '(' texpr ')' block cont",
-"loop : label UNTIL '(' expr ')' block cont",
-"loop : label WHILE block block cont",
-"loop : label UNTIL block block cont",
-"loop : label FOR scalar '(' expr ')' block cont",
-"loop : label FOR '(' expr ')' block cont",
-"loop : label FOR '(' nexpr ';' texpr ';' nexpr ')' 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 startsub WORD block",
-"format : FORMAT startsub block",
-"subrout : SUB startsub WORD proto block",
-"subrout : SUB startsub WORD proto ';'",
+"format : FORMAT startformsub formname block",
+"formname : WORD",
+"formname :",
+"subrout : SUB startsub subname proto subbody",
+"startsub :",
+"startanonsub :",
+"startformsub :",
+"subname : WORD",
"proto :",
"proto : THING",
-"startsub :",
+"subbody : block",
+"subbody : ';'",
"package : PACKAGE WORD ';'",
"package : PACKAGE ';'",
-"use : USE startsub WORD listexpr ';'",
+"$$2 :",
+"use : USE startsub $$2 WORD WORD listexpr ';'",
"expr : expr ANDOP expr",
"expr : expr OROP expr",
"expr : argexpr",
@@ -1204,7 +1164,8 @@ char *yyrule[] = {
"listop : FUNCMETH indirob '(' listexprcom ')'",
"listop : LSTOP listexpr",
"listop : FUNC '(' listexprcom ')'",
-"listop : LSTOPSUB startsub block listexpr",
+"$$3 :",
+"listop : LSTOPSUB startanonsub block $$3 listexpr",
"method : METHOD",
"method : scalar",
"term : term ASSIGNOP term",
@@ -1230,14 +1191,14 @@ char *yyrule[] = {
"term : term POSTDEC",
"term : PREINC term",
"term : PREDEC term",
-"term : LOCAL term",
+"term : local term",
"term : '(' expr ')'",
"term : '(' ')'",
"term : '[' expr ']'",
"term : '[' ']'",
"term : HASHBRACK expr ';' '}'",
"term : HASHBRACK ';' '}'",
-"term : ANONSUB startsub proto block",
+"term : ANONSUB startanonsub proto block",
"term : scalar",
"term : star '{' expr ';' '}'",
"term : star",
@@ -1265,6 +1226,8 @@ char *yyrule[] = {
"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",
@@ -1286,6 +1249,9 @@ char *yyrule[] = {
"listexprcom :",
"listexprcom : expr",
"listexprcom : expr ','",
+"local : LOCAL",
+"local : MY",
+"my_scalar : scalar",
"amper : '&' indirob",
"scalar : '$' indirob",
"ary : '@' indirob",
@@ -1318,9 +1284,9 @@ int yyerrflag;
int yychar;
YYSTYPE yyval;
YYSTYPE yylval;
-#line 571 "perly.y"
+#line 631 "perly.y"
/* PROGRAM */
-#line 1394 "y.tab.c"
+#line 1360 "perly.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
@@ -1412,7 +1378,7 @@ yyloop:
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate,
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
#endif
@@ -1422,7 +1388,7 @@ yyloop:
{
#if YYDEBUG
if (yydebug)
- fprintf(stderr, "yydebug: state %d, shifting to state %d\n",
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n",
yystate, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
@@ -1477,7 +1443,7 @@ yyinrecovery:
{
#if YYDEBUG
if (yydebug)
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: state %d, error recovery shifting to state %d\n",
*yyssp, yytable[yyn]);
#endif
@@ -1507,7 +1473,7 @@ yyinrecovery:
{
#if YYDEBUG
if (yydebug)
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: error recovery discarding state %d\n",
*yyssp);
#endif
@@ -1526,7 +1492,7 @@ yyinrecovery:
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: state %d, error recovery discards token %d (%s)\n",
yystate, yychar, yys);
}
@@ -1537,7 +1503,7 @@ yyinrecovery:
yyreduce:
#if YYDEBUG
if (yydebug)
- fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n",
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
yym = yylen[yyn];
@@ -1545,7 +1511,7 @@ yyreduce:
switch (yyn)
{
case 1:
-#line 84 "perly.y"
+#line 86 "perly.y"
{
#if defined(YYDEBUG) && defined(DEBUGGING)
yydebug = (debug & 1);
@@ -1554,38 +1520,50 @@ case 1:
}
break;
case 2:
-#line 91 "perly.y"
+#line 93 "perly.y"
{ newPROG(yyvsp[0].opval); }
break;
case 3:
-#line 95 "perly.y"
-{ yyval.opval = block_end(yyvsp[-3].ival,yyvsp[-2].ival,yyvsp[-1].opval); }
+#line 97 "perly.y"
+{ if (copline > (line_t)yyvsp[-3].ival)
+ copline = yyvsp[-3].ival;
+ yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
case 4:
-#line 99 "perly.y"
-{ yyval.ival = block_start(); }
+#line 103 "perly.y"
+{ yyval.ival = block_start(TRUE); }
break;
case 5:
-#line 103 "perly.y"
-{ yyval.opval = Nullop; }
+#line 107 "perly.y"
+{ if (copline > (line_t)yyvsp[-3].ival)
+ copline = yyvsp[-3].ival;
+ yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
case 6:
-#line 105 "perly.y"
-{ yyval.opval = yyvsp[-1].opval; }
+#line 113 "perly.y"
+{ yyval.ival = block_start(FALSE); }
break;
case 7:
-#line 107 "perly.y"
+#line 117 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 8:
+#line 119 "perly.y"
+{ yyval.opval = yyvsp[-1].opval; }
+break;
+case 9:
+#line 121 "perly.y"
{ yyval.opval = append_list(OP_LINESEQ,
(LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval);
pad_reset_pending = TRUE;
if (yyvsp[-1].opval && yyvsp[0].opval) hints |= HINT_BLOCK_SCOPE; }
break;
-case 8:
-#line 114 "perly.y"
+case 10:
+#line 128 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); }
break;
-case 10:
-#line 117 "perly.y"
+case 12:
+#line 131 "perly.y"
{ if (yyvsp[-1].pval != Nullch) {
yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0));
}
@@ -1595,467 +1573,501 @@ case 10:
}
expect = XSTATE; }
break;
-case 11:
-#line 126 "perly.y"
+case 13:
+#line 140 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval);
expect = XSTATE; }
break;
-case 12:
-#line 131 "perly.y"
-{ yyval.opval = Nullop; }
-break;
-case 13:
-#line 133 "perly.y"
-{ yyval.opval = yyvsp[0].opval; }
-break;
case 14:
-#line 135 "perly.y"
-{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); }
+#line 145 "perly.y"
+{ yyval.opval = Nullop; }
break;
case 15:
-#line 137 "perly.y"
-{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); }
+#line 147 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
break;
case 16:
-#line 139 "perly.y"
-{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); }
+#line 149 "perly.y"
+{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 17:
-#line 141 "perly.y"
-{ yyval.opval = newLOOPOP(OPf_PARENS, 1, invert(scalar(yyvsp[0].opval)), yyvsp[-2].opval);}
+#line 151 "perly.y"
+{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 18:
-#line 145 "perly.y"
-{ yyval.opval = Nullop; }
+#line 153 "perly.y"
+{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); }
break;
case 19:
-#line 147 "perly.y"
-{ yyval.opval = scope(yyvsp[0].opval); }
+#line 155 "perly.y"
+{ yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);}
break;
case 20:
-#line 149 "perly.y"
-{ copline = yyvsp[-5].ival;
- yyval.opval = newSTATEOP(0, 0,
- newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval));
- hints |= HINT_BLOCK_SCOPE; }
+#line 159 "perly.y"
+{ yyval.opval = Nullop; }
break;
case 21:
-#line 156 "perly.y"
-{ copline = yyvsp[-5].ival;
- yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); }
+#line 161 "perly.y"
+{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 22:
-#line 159 "perly.y"
+#line 163 "perly.y"
{ copline = yyvsp[-5].ival;
- yyval.opval = newCONDOP(0,
- invert(scalar(yyvsp[-3].opval)), scope(yyvsp[-1].opval), yyvsp[0].opval); }
+ yyval.opval = newSTATEOP(0, Nullch,
+ newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval));
+ hints |= HINT_BLOCK_SCOPE; }
break;
case 23:
-#line 163 "perly.y"
-{ copline = yyvsp[-3].ival;
- deprecate("if BLOCK BLOCK");
- yyval.opval = newCONDOP(0, scope(yyvsp[-2].opval), scope(yyvsp[-1].opval), yyvsp[0].opval); }
+#line 170 "perly.y"
+{ 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 24:
-#line 167 "perly.y"
-{ copline = yyvsp[-3].ival;
- deprecate("unless BLOCK BLOCK");
- yyval.opval = newCONDOP(0, invert(scalar(scope(yyvsp[-2].opval))),
- scope(yyvsp[-1].opval), yyvsp[0].opval); }
+#line 174 "perly.y"
+{ 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 174 "perly.y"
+#line 180 "perly.y"
{ yyval.opval = Nullop; }
break;
case 26:
-#line 176 "perly.y"
+#line 182 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 27:
-#line 180 "perly.y"
-{ copline = yyvsp[-5].ival;
- yyval.opval = newSTATEOP(0, yyvsp[-6].pval,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval) ); }
+#line 186 "perly.y"
+{ 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 28:
-#line 185 "perly.y"
-{ copline = yyvsp[-5].ival;
- yyval.opval = newSTATEOP(0, yyvsp[-6].pval,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- invert(scalar(yyvsp[-3].opval)), yyvsp[-1].opval, yyvsp[0].opval) ); }
+#line 192 "perly.y"
+{ 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 190 "perly.y"
-{ copline = yyvsp[-3].ival;
- yyval.opval = newSTATEOP(0, yyvsp[-4].pval,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- scope(yyvsp[-2].opval), yyvsp[-1].opval, yyvsp[0].opval) ); }
+#line 198 "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 30:
-#line 195 "perly.y"
-{ copline = yyvsp[-3].ival;
- yyval.opval = newSTATEOP(0, yyvsp[-4].pval,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- invert(scalar(scope(yyvsp[-2].opval))), yyvsp[-1].opval, yyvsp[0].opval)); }
+#line 201 "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 31:
-#line 200 "perly.y"
-{ yyval.opval = newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, mod(yyvsp[-5].opval, OP_ENTERLOOP),
- yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); }
+#line 205 "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 32:
-#line 203 "perly.y"
-{ yyval.opval = newFOROP(0, yyvsp[-6].pval, yyvsp[-5].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); }
+#line 209 "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)));
+ copline = yyvsp[-9].ival;
+ yyval.opval = block_end(yyvsp[-7].ival, newSTATEOP(0, yyvsp[-10].pval, forop)); }
break;
case 33:
-#line 206 "perly.y"
-{ copline = yyvsp[-8].ival;
- yyval.opval = append_elem(OP_LINESEQ,
- newSTATEOP(0, yyvsp[-9].pval, scalar(yyvsp[-6].opval)),
- newSTATEOP(0, yyvsp[-9].pval,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- scalar(yyvsp[-4].opval), yyvsp[0].opval, scalar(yyvsp[-2].opval)) )); }
+#line 217 "perly.y"
+{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ NOLINE, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 34:
-#line 213 "perly.y"
-{ yyval.opval = newSTATEOP(0,
- yyvsp[-2].pval, newWHILEOP(0, 1, (LOOP*)Nullop,
- Nullop, yyvsp[-1].opval, yyvsp[0].opval)); }
-break;
-case 35:
-#line 219 "perly.y"
+#line 223 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 37:
-#line 224 "perly.y"
+case 36:
+#line 228 "perly.y"
{ (void)scan_num("1"); yyval.opval = yylval.opval; }
break;
+case 38:
+#line 233 "perly.y"
+{ yyval.opval = invert(scalar(yyvsp[0].opval)); }
+break;
case 39:
-#line 229 "perly.y"
-{ yyval.pval = Nullch; }
+#line 237 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 40:
+#line 241 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 41:
-#line 234 "perly.y"
-{ yyval.ival = 0; }
+#line 245 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 42:
-#line 236 "perly.y"
-{ yyval.ival = 0; }
+#line 249 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 43:
-#line 238 "perly.y"
-{ yyval.ival = 0; }
-break;
-case 44:
-#line 240 "perly.y"
-{ yyval.ival = 0; }
+#line 253 "perly.y"
+{ yyval.pval = Nullch; }
break;
case 45:
-#line 244 "perly.y"
-{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
+#line 258 "perly.y"
+{ yyval.ival = 0; }
break;
case 46:
-#line 246 "perly.y"
-{ newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); }
+#line 260 "perly.y"
+{ yyval.ival = 0; }
break;
case 47:
-#line 250 "perly.y"
-{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
+#line 262 "perly.y"
+{ yyval.ival = 0; }
break;
case 48:
-#line 252 "perly.y"
-{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, Nullop); expect = XSTATE; }
+#line 264 "perly.y"
+{ yyval.ival = 0; }
break;
case 49:
-#line 256 "perly.y"
-{ yyval.opval = Nullop; }
+#line 268 "perly.y"
+{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
+break;
+case 50:
+#line 271 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
break;
case 51:
-#line 261 "perly.y"
-{ yyval.ival = start_subparse(); }
+#line 272 "perly.y"
+{ yyval.opval = Nullop; }
break;
case 52:
-#line 265 "perly.y"
-{ package(yyvsp[-1].opval); }
+#line 276 "perly.y"
+{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 53:
-#line 267 "perly.y"
-{ package(Nullop); }
+#line 280 "perly.y"
+{ yyval.ival = start_subparse(FALSE, 0); }
break;
case 54:
-#line 271 "perly.y"
-{ utilize(yyvsp[-4].ival, yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval); }
+#line 284 "perly.y"
+{ yyval.ival = start_subparse(FALSE, CVf_ANON); }
break;
case 55:
-#line 275 "perly.y"
-{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
+#line 288 "perly.y"
+{ yyval.ival = start_subparse(TRUE, 0); }
break;
case 56:
-#line 277 "perly.y"
+#line 291 "perly.y"
+{ char *name = SvPVx(((SVOP*)yyvsp[0].opval)->op_sv, na);
+ if (strEQ(name, "BEGIN") || strEQ(name, "END"))
+ CvUNIQUE_on(compcv);
+ yyval.opval = yyvsp[0].opval; }
+break;
+case 57:
+#line 298 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 59:
+#line 302 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 60:
+#line 303 "perly.y"
+{ yyval.opval = Nullop; expect = XSTATE; }
+break;
+case 61:
+#line 307 "perly.y"
+{ package(yyvsp[-1].opval); }
+break;
+case 62:
+#line 309 "perly.y"
+{ package(Nullop); }
+break;
+case 63:
+#line 313 "perly.y"
+{ CvUNIQUE_on(compcv); /* It's a BEGIN {} */ }
+break;
+case 64:
+#line 315 "perly.y"
+{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
+break;
+case 65:
+#line 319 "perly.y"
+{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
+break;
+case 66:
+#line 321 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 58:
-#line 282 "perly.y"
+case 68:
+#line 326 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
-case 59:
-#line 284 "perly.y"
+case 69:
+#line 328 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 61:
-#line 289 "perly.y"
+case 71:
+#line 333 "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 62:
-#line 292 "perly.y"
+case 72:
+#line 336 "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 63:
-#line 295 "perly.y"
+case 73:
+#line 339 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
- prepend_elem(OP_LIST, yyvsp[-5].opval, yyvsp[-1].opval),
+ prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval),
newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); }
break;
-case 64:
-#line 300 "perly.y"
+case 74:
+#line 344 "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 65:
-#line 305 "perly.y"
+case 75:
+#line 349 "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 66:
-#line 310 "perly.y"
+case 76:
+#line 354 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 67:
-#line 312 "perly.y"
+case 77:
+#line 356 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
-case 68:
-#line 314 "perly.y"
+case 78:
+#line 358 "perly.y"
+{ yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); }
+break;
+case 79:
+#line 360 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST,
- prepend_elem(OP_LIST, newANONSUB(yyvsp[-2].ival, 0, yyvsp[-1].opval), yyvsp[0].opval),
- yyvsp[-3].opval)); }
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); }
break;
-case 71:
-#line 325 "perly.y"
+case 82:
+#line 370 "perly.y"
{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); }
break;
-case 72:
-#line 327 "perly.y"
+case 83:
+#line 372 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 73:
-#line 329 "perly.y"
+case 84:
+#line 374 "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 74:
-#line 333 "perly.y"
+case 85:
+#line 378 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 75:
-#line 335 "perly.y"
+case 86:
+#line 380 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 76:
-#line 337 "perly.y"
+case 87:
+#line 382 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 77:
-#line 339 "perly.y"
+case 88:
+#line 384 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 78:
-#line 341 "perly.y"
+case 89:
+#line 386 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 79:
-#line 343 "perly.y"
+case 90:
+#line 388 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 80:
-#line 345 "perly.y"
+case 91:
+#line 390 "perly.y"
{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));}
break;
-case 81:
-#line 347 "perly.y"
+case 92:
+#line 392 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 82:
-#line 349 "perly.y"
+case 93:
+#line 394 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 83:
-#line 351 "perly.y"
+case 94:
+#line 396 "perly.y"
{ yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 84:
-#line 353 "perly.y"
+case 95:
+#line 398 "perly.y"
{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 85:
-#line 356 "perly.y"
+case 96:
+#line 401 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
-case 86:
-#line 358 "perly.y"
+case 97:
+#line 403 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 87:
-#line 360 "perly.y"
+case 98:
+#line 405 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
-case 88:
-#line 362 "perly.y"
+case 99:
+#line 407 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
-case 89:
-#line 364 "perly.y"
+case 100:
+#line 409 "perly.y"
{ yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
break;
-case 90:
-#line 366 "perly.y"
+case 101:
+#line 411 "perly.y"
{ yyval.opval = newUNOP(OP_POSTINC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTINC)); }
break;
-case 91:
-#line 369 "perly.y"
+case 102:
+#line 414 "perly.y"
{ yyval.opval = newUNOP(OP_POSTDEC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); }
break;
-case 92:
-#line 372 "perly.y"
+case 103:
+#line 417 "perly.y"
{ yyval.opval = newUNOP(OP_PREINC, 0,
mod(scalar(yyvsp[0].opval), OP_PREINC)); }
break;
-case 93:
-#line 375 "perly.y"
+case 104:
+#line 420 "perly.y"
{ yyval.opval = newUNOP(OP_PREDEC, 0,
mod(scalar(yyvsp[0].opval), OP_PREDEC)); }
break;
-case 94:
-#line 378 "perly.y"
+case 105:
+#line 423 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
-case 95:
-#line 380 "perly.y"
+case 106:
+#line 425 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
-case 96:
-#line 382 "perly.y"
+case 107:
+#line 427 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
-case 97:
-#line 384 "perly.y"
+case 108:
+#line 429 "perly.y"
{ yyval.opval = newANONLIST(yyvsp[-1].opval); }
break;
-case 98:
-#line 386 "perly.y"
+case 109:
+#line 431 "perly.y"
{ yyval.opval = newANONLIST(Nullop); }
break;
-case 99:
-#line 388 "perly.y"
+case 110:
+#line 433 "perly.y"
{ yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
-case 100:
-#line 390 "perly.y"
+case 111:
+#line 435 "perly.y"
{ yyval.opval = newANONHASH(Nullop); }
break;
-case 101:
-#line 392 "perly.y"
+case 112:
+#line 437 "perly.y"
{ yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
-case 102:
-#line 394 "perly.y"
+case 113:
+#line 439 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 103:
-#line 396 "perly.y"
+case 114:
+#line 441 "perly.y"
{ yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); }
break;
-case 104:
-#line 398 "perly.y"
+case 115:
+#line 443 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 105:
-#line 400 "perly.y"
+case 116:
+#line 445 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); }
break;
-case 106:
-#line 402 "perly.y"
+case 117:
+#line 447 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-4].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
-case 107:
-#line 406 "perly.y"
+case 118:
+#line 451 "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 108:
-#line 410 "perly.y"
+case 119:
+#line 455 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 109:
-#line 412 "perly.y"
+case 120:
+#line 457 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 110:
-#line 414 "perly.y"
+case 121:
+#line 459 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
-case 111:
-#line 416 "perly.y"
+case 122:
+#line 461 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
-case 112:
-#line 419 "perly.y"
+case 123:
+#line 464 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-5].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
-case 113:
-#line 424 "perly.y"
+case 124:
+#line 469 "perly.y"
{ assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-4].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
-case 114:
-#line 429 "perly.y"
+case 125:
+#line 474 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
-case 115:
-#line 431 "perly.y"
+case 126:
+#line 476 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
-case 116:
-#line 433 "perly.y"
+case 127:
+#line 478 "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 117:
-#line 439 "perly.y"
+case 128:
+#line 484 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
@@ -2063,38 +2075,38 @@ case 117:
ref(oopsHV(yyvsp[-4].opval), OP_HSLICE)));
expect = XOPERATOR; }
break;
-case 118:
-#line 446 "perly.y"
+case 129:
+#line 491 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 119:
-#line 448 "perly.y"
+case 130:
+#line 493 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
break;
-case 120:
-#line 450 "perly.y"
+case 131:
+#line 495 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
-case 121:
-#line 452 "perly.y"
+case 132:
+#line 497 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); }
break;
-case 122:
-#line 455 "perly.y"
+case 133:
+#line 500 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
-case 123:
-#line 458 "perly.y"
+case 134:
+#line 503 "perly.y"
{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); }
break;
-case 124:
-#line 460 "perly.y"
+case 135:
+#line 505 "perly.y"
{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
break;
-case 125:
-#line 462 "perly.y"
+case 136:
+#line 507 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
@@ -2103,8 +2115,8 @@ case 125:
scalar(yyvsp[-2].opval)
)),Nullop)); dep();}
break;
-case 126:
-#line 470 "perly.y"
+case 137:
+#line 515 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
append_elem(OP_LIST,
@@ -2114,139 +2126,162 @@ case 126:
scalar(yyvsp[-3].opval)
)))); dep();}
break;
-case 127:
-#line 479 "perly.y"
+case 138:
+#line 524 "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 128:
-#line 483 "perly.y"
+case 139:
+#line 528 "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 129:
-#line 488 "perly.y"
+case 140:
+#line 533 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ newCVREF(0, scalar(yyvsp[-3].opval))); }
+break;
+case 141:
+#line 536 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, yyvsp[-1].opval,
+ newCVREF(0, scalar(yyvsp[-4].opval)))); }
+break;
+case 142:
+#line 540 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
hints |= HINT_BLOCK_SCOPE; }
break;
-case 130:
-#line 491 "perly.y"
+case 143:
+#line 543 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
-case 131:
-#line 493 "perly.y"
+case 144:
+#line 545 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
-case 132:
-#line 495 "perly.y"
+case 145:
+#line 547 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
-case 133:
-#line 497 "perly.y"
+case 146:
+#line 549 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 134:
-#line 499 "perly.y"
+case 147:
+#line 551 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 135:
-#line 501 "perly.y"
+case 148:
+#line 553 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
-case 136:
-#line 504 "perly.y"
+case 149:
+#line 556 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
-case 137:
-#line 506 "perly.y"
+case 150:
+#line 558 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
-case 138:
-#line 508 "perly.y"
-{ yyval.opval = newUNOP(OP_ENTERSUB, 0,
+case 151:
+#line 560 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar(yyvsp[0].opval)); }
break;
-case 139:
-#line 511 "perly.y"
+case 152:
+#line 563 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
-case 140:
-#line 513 "perly.y"
+case 153:
+#line 565 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
-case 141:
-#line 515 "perly.y"
+case 154:
+#line 567 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
-case 142:
-#line 517 "perly.y"
+case 155:
+#line 569 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
-case 145:
-#line 523 "perly.y"
+case 158:
+#line 575 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 146:
-#line 525 "perly.y"
+case 159:
+#line 577 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 147:
-#line 529 "perly.y"
+case 160:
+#line 581 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 148:
-#line 531 "perly.y"
+case 161:
+#line 583 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 149:
-#line 533 "perly.y"
+case 162:
+#line 585 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
-case 150:
-#line 537 "perly.y"
+case 163:
+#line 588 "perly.y"
+{ yyval.ival = 0; }
+break;
+case 164:
+#line 589 "perly.y"
+{ yyval.ival = 1; }
+break;
+case 165:
+#line 593 "perly.y"
+{ in_my = 0; yyval.opval = my(yyvsp[0].opval); }
+break;
+case 166:
+#line 597 "perly.y"
{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
break;
-case 151:
-#line 541 "perly.y"
+case 167:
+#line 601 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
-case 152:
-#line 545 "perly.y"
+case 168:
+#line 605 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
-case 153:
-#line 549 "perly.y"
+case 169:
+#line 609 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
-case 154:
-#line 553 "perly.y"
+case 170:
+#line 613 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
-case 155:
-#line 557 "perly.y"
+case 171:
+#line 617 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
-case 156:
-#line 561 "perly.y"
+case 172:
+#line 621 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
-case 157:
-#line 563 "perly.y"
+case 173:
+#line 623 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
-case 158:
-#line 565 "perly.y"
+case 174:
+#line 625 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
-case 159:
-#line 568 "perly.y"
+case 175:
+#line 628 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-#line 2236 "y.tab.c"
+#line 2271 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
@@ -2256,7 +2291,7 @@ break;
{
#if YYDEBUG
if (yydebug)
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: after reduction, shifting from state 0 to state %d\n",
YYFINAL);
#endif
@@ -2272,7 +2307,7 @@ break;
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(stderr, "yydebug: state %d, reading %d (%s)\n",
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
#endif
@@ -2287,7 +2322,7 @@ break;
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: after reduction, shifting from state %d to state %d\n",
*yyssp, yystate);
#endif
diff --git a/gnu/usr.bin/perl/perly.c.diff b/gnu/usr.bin/perl/perly.c.diff
index 3b3c04ecf88..b4aec9d5981 100644
--- a/gnu/usr.bin/perl/perly.c.diff
+++ b/gnu/usr.bin/perl/perly.c.diff
@@ -1,82 +1,84 @@
-*** perly.c.orig Wed Feb 14 15:29:04 1996
---- perly.c Wed Feb 14 15:29:05 1996
+Index: perly.c
***************
-*** 12,82 ****
- deprecate("\"do\" to call subroutines");
+*** 13,82 ****
}
-- #line 29 "perly.y"
-- typedef union {
-- I32 ival;
-- char *pval;
-- OP *opval;
-- GV *gvval;
-- } YYSTYPE;
-- #line 23 "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 RELOP 285
-- #define EQOP 286
-- #define MULOP 287
-- #define ADDOP 288
-- #define DOLSHARP 289
-- #define DO 290
-- #define LOCAL 291
-- #define HASHBRACK 292
-- #define NOAMP 293
-- #define OROP 294
-- #define ANDOP 295
-- #define NOTOP 296
-- #define LSTOP 297
-- #define ASSIGNOP 298
-- #define OROR 299
-- #define ANDAND 300
-- #define BITOROP 301
-- #define BITANDOP 302
-- #define UNIOP 303
-- #define SHIFTOP 304
-- #define MATCHOP 305
-- #define UMINUS 306
-- #define REFGEN 307
-- #define POWOP 308
-- #define PREINC 309
-- #define PREDEC 310
-- #define POSTINC 311
-- #define POSTDEC 312
-- #define ARROW 313
+! #line 29 "perly.y"
+! typedef union {
+! I32 ival;
+! char *pval;
+! OP *opval;
+! GV *gvval;
+! } YYSTYPE;
+! #line 23 "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,
+--- 13,17 ----
+ }
+
+! #line 16 "perly.c"
#define YYERRCODE 256
short yylhs[] = { -1,
- 31, 0, 5, 3, 6, 6, 6, 7, 7, 7,
---- 12,17 ----
***************
-*** 1381,1393 ****
- int yynerrs;
+*** 1348,1358 ****
int yyerrflag;
int yychar;
- short *yyssp;
@@ -86,14 +88,12 @@
- short yyss[YYSTACKSIZE];
- YYSTYPE yyvs[YYSTACKSIZE];
- #define yystacksize YYSTACKSIZE
- #line 571 "perly.y"
+ #line 631 "perly.y"
/* PROGRAM */
- #line 1394 "y.tab.c"
---- 1316,1323 ----
+--- 1283,1288 ----
***************
-*** 1394,1407 ****
---- 1324,1382 ----
- #define YYABORT goto yyabort
+*** 1361,1372 ****
+--- 1291,1347 ----
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
+
@@ -138,7 +138,7 @@
register char *yys;
extern char *getenv();
+ #endif
-
++
+ struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv));
+ SAVEDESTRUCTOR(yydestruct, ysave);
+ ysave->oldyydebug = yydebug;
@@ -147,15 +147,13 @@
+ ysave->oldyychar = yychar;
+ ysave->oldyyval = yyval;
+ ysave->oldyylval = yylval;
-+
+
+ #if YYDEBUG
if (yys = getenv("YYDEBUG"))
{
- yyn = *yys;
***************
-*** 1414,1419 ****
---- 1389,1402 ----
- yyerrflag = 0;
+*** 1381,1384 ****
+--- 1356,1367 ----
yychar = (-1);
+ /*
@@ -168,27 +166,21 @@
+
yyssp = yyss;
yyvsp = yyvs;
- *yyssp = yystate = 0;
***************
-*** 1429,1435 ****
- yys = 0;
+*** 1396,1400 ****
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! printf("yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
- #endif
---- 1412,1418 ----
- yys = 0;
+--- 1379,1383 ----
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
- #endif
***************
-*** 1439,1450 ****
- {
+*** 1406,1415 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: state %d, shifting to state %d\n",
@@ -199,9 +191,7 @@
! goto yyoverflow;
}
*++yyssp = yystate = yytable[yyn];
- *++yyvsp = yylval;
---- 1422,1447 ----
- {
+--- 1389,1412 ----
#if YYDEBUG
if (yydebug)
! fprintf(stderr, "yydebug: state %d, shifting to state %d\n",
@@ -226,10 +216,8 @@
! yyvsp = yyvs + yypv_index;
}
*++yyssp = yystate = yytable[yyn];
- *++yyvsp = yylval;
***************
-*** 1480,1491 ****
- {
+*** 1447,1456 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: state %d, error recovery shifting\
@@ -240,9 +228,7 @@
! goto yyoverflow;
}
*++yyssp = yystate = yytable[yyn];
- *++yyvsp = yylval;
---- 1477,1503 ----
- {
+--- 1444,1468 ----
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
@@ -268,19 +254,15 @@
! yyvsp = yyvs + yypv_index;
}
*++yyssp = yystate = yytable[yyn];
- *++yyvsp = yylval;
***************
-*** 1495,1502 ****
- {
+*** 1462,1467 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: error recovery discarding state %d\n",
! *yyssp);
#endif
if (yyssp <= yyss) goto yyabort;
- --yyssp;
---- 1507,1515 ----
- {
+--- 1474,1480 ----
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
@@ -288,19 +270,15 @@
! *yyssp);
#endif
if (yyssp <= yyss) goto yyabort;
- --yyssp;
***************
-*** 1513,1520 ****
- yys = 0;
+*** 1480,1485 ****
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);
---- 1526,1534 ----
- yys = 0;
+--- 1493,1499 ----
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(stderr,
@@ -308,36 +286,28 @@
! yystate, yychar, yys);
}
#endif
- yychar = (-1);
***************
-*** 1523,1529 ****
- yyreduce:
+*** 1490,1494 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
- yym = yylen[yyn];
---- 1537,1543 ----
- yyreduce:
+--- 1504,1508 ----
#if YYDEBUG
if (yydebug)
! fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
- yym = yylen[yyn];
***************
-*** 2242,2249 ****
- {
+*** 2278,2283 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: after reduction, shifting from state 0 to\
! state %d\n", YYFINAL);
#endif
yystate = YYFINAL;
- *++yyssp = YYFINAL;
---- 2256,2264 ----
- {
+--- 2292,2298 ----
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
@@ -345,27 +315,21 @@
! YYFINAL);
#endif
yystate = YYFINAL;
- *++yyssp = YYFINAL;
***************
-*** 2257,2263 ****
- yys = 0;
+*** 2293,2297 ****
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! printf("yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
- #endif
---- 2272,2278 ----
- yys = 0;
+--- 2308,2312 ----
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
- #endif
***************
-*** 2272,2291 ****
- yystate = yydgoto[yym];
+*** 2308,2317 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: after reduction, shifting from state %d \
@@ -376,17 +340,7 @@
! goto yyoverflow;
}
*++yyssp = yystate;
- *++yyvsp = yyval;
- goto yyloop;
- yyoverflow:
-! yyerror("yacc stack overflow");
- yyabort:
-! return (1);
- yyaccept:
-! return (0);
- }
---- 2287,2321 ----
- yystate = yydgoto[yym];
+--- 2323,2347 ----
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
@@ -412,7 +366,17 @@
! yyvsp = yyvs + yypv_index;
}
*++yyssp = yystate;
- *++yyvsp = yyval;
+***************
+*** 2319,2326 ****
+ goto yyloop;
+ yyoverflow:
+! yyerror("yacc stack overflow");
+ yyabort:
+! return (1);
+ yyaccept:
+! return (0);
+ }
+--- 2349,2356 ----
goto yyloop;
yyoverflow:
! yyerror("Out of memory for yacc stack");
diff --git a/gnu/usr.bin/perl/perly.fixer b/gnu/usr.bin/perl/perly.fixer
index 98296a72fd2..156881657f0 100644
--- a/gnu/usr.bin/perl/perly.fixer
+++ b/gnu/usr.bin/perl/perly.fixer
@@ -5,8 +5,9 @@
#
# 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 supported.
+# 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
@@ -44,7 +45,15 @@ fi
plan="unknown"
-# Below, we check for various yaccpar outputs.
+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
@@ -73,13 +82,15 @@ if *\( *\+\+yy_ps *>= *&yys\[ *YYMAXDEPTH *\] *\)' $input >$tmp 2>/dev/null
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 "Patching perly.c to allow dynamic yacc stack allocation"
+ echo "Attempting to path perly.c to allow dynamic yacc stack allocation"
echo "Assuming bsd4.3 yaccpar"
cat >$tmp <<'END'
/YYSTYPE[ ]*yyv\[ *YYMAXDEPTH *\];/c\
@@ -128,11 +139,15 @@ short *maxyyps;
/yacc stack overflow.*}/d
/yacc stack overflow/,/}/d
END
- sed -f $tmp <$input >$output ;;
+ 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 "Patching perly.c to allow dynamic yacc stack allocation"
+ 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.
@@ -178,11 +193,20 @@ int *maxyyps;
\ }\
\ if (yyv == NULL || yys == NULL)
END
- sed -f $tmp < $input > $output ;;
+ 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
- *) sed -e 's/Received token/ *** Received token/' $input >$output;
+ *)
+ 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/gnu/usr.bin/perl/perly.h b/gnu/usr.bin/perl/perly.h
index 56eaf7e2a46..99077270011 100644
--- a/gnu/usr.bin/perl/perly.h
+++ b/gnu/usr.bin/perl/perly.h
@@ -26,35 +26,36 @@
#define FUNC0 282
#define FUNC1 283
#define FUNC 284
-#define RELOP 285
-#define EQOP 286
-#define MULOP 287
-#define ADDOP 288
-#define DOLSHARP 289
-#define DO 290
-#define LOCAL 291
-#define HASHBRACK 292
-#define NOAMP 293
-#define OROP 294
-#define ANDOP 295
-#define NOTOP 296
-#define LSTOP 297
-#define ASSIGNOP 298
-#define OROR 299
-#define ANDAND 300
-#define BITOROP 301
-#define BITANDOP 302
-#define UNIOP 303
-#define SHIFTOP 304
-#define MATCHOP 305
-#define UMINUS 306
-#define REFGEN 307
-#define POWOP 308
-#define PREINC 309
-#define PREDEC 310
-#define POSTINC 311
-#define POSTDEC 312
-#define ARROW 313
+#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;
diff --git a/gnu/usr.bin/perl/perly.y b/gnu/usr.bin/perl/perly.y
index 96a35e1c0ec..6313061934f 100644
--- a/gnu/usr.bin/perl/perly.y
+++ b/gnu/usr.bin/perl/perly.y
@@ -1,6 +1,6 @@
/* perly.y
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -9,7 +9,7 @@
/*
* 'I see,' laughed Strider. 'I look foul and feel fair. Is that it?
- * All that is gold does not glitter, not all those that wander are lost.'
+ * All that is gold does not glitter, not all those who wander are lost.'
*/
%{
@@ -41,22 +41,24 @@ dep()
%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
+%token <ival> FUNC0 FUNC1 FUNC UNIOP LSTOP
%token <ival> RELOP EQOP MULOP ADDOP
-%token <ival> DOLSHARP DO LOCAL HASHBRACK NOAMP
+%token <ival> DOLSHARP DO HASHBRACK NOAMP
+%token LOCAL MY
-%type <ival> prog decl format remember startsub '&'
-%type <opval> block lineseq line loop cond nexpr else argexpr
+%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> listexpr listexprcom indirob
-%type <opval> texpr listop method proto
+%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
-%type <opval> cont
%left <ival> OROP
%left ANDOP
%right NOTOP
-%nonassoc <ival> LSTOP
+%nonassoc LSTOP LSTOPSUB
%left ','
%right <ival> ASSIGNOP
%right '?' ':'
@@ -67,7 +69,7 @@ dep()
%left <ival> BITANDOP
%nonassoc EQOP
%nonassoc RELOP
-%nonassoc <ival> UNIOP
+%nonassoc UNIOP UNIOPSUB
%left <ival> SHIFTOP
%left ADDOP
%left MULOP
@@ -92,11 +94,23 @@ prog : /* NULL */
;
block : '{' remember lineseq '}'
- { $$ = block_end($1,$2,$3); }
+ { if (copline > (line_t)$1)
+ copline = $1;
+ $$ = block_end($2, $3); }
;
-remember: /* NULL */ /* start a lexical scope */
- { $$ = block_start(); }
+remember: /* NULL */ /* start a full lexical scope */
+ { $$ = block_start(TRUE); }
+ ;
+
+mblock : '{' mremember lineseq '}'
+ { if (copline > (line_t)$1)
+ copline = $1;
+ $$ = block_end($2, $3); }
+ ;
+
+mremember: /* NULL */ /* start a partial lexical scope */
+ { $$ = block_start(FALSE); }
;
lineseq : /* NULL */
@@ -137,37 +151,29 @@ sideff : error
{ $$ = newLOGOP(OP_OR, 0, $3, $1); }
| expr WHILE expr
{ $$ = newLOOPOP(OPf_PARENS, 1, scalar($3), $1); }
- | expr UNTIL expr
- { $$ = newLOOPOP(OPf_PARENS, 1, invert(scalar($3)), $1);}
+ | expr UNTIL iexpr
+ { $$ = newLOOPOP(OPf_PARENS, 1, $3, $1);}
;
else : /* NULL */
{ $$ = Nullop; }
- | ELSE block
+ | ELSE mblock
{ $$ = scope($2); }
- | ELSIF '(' expr ')' block else
+ | ELSIF '(' mexpr ')' mblock else
{ copline = $1;
- $$ = newSTATEOP(0, 0,
- newCONDOP(0, $3, scope($5), $6));
+ $$ = newSTATEOP(0, Nullch,
+ newCONDOP(0, $3, scope($5), $6));
hints |= HINT_BLOCK_SCOPE; }
;
-cond : IF '(' expr ')' block else
- { copline = $1;
- $$ = newCONDOP(0, $3, scope($5), $6); }
- | UNLESS '(' expr ')' block else
+cond : IF '(' remember mexpr ')' mblock else
{ copline = $1;
- $$ = newCONDOP(0,
- invert(scalar($3)), scope($5), $6); }
- | IF block block else
+ $$ = block_end($3,
+ newCONDOP(0, $4, scope($6), $7)); }
+ | UNLESS '(' remember miexpr ')' mblock else
{ copline = $1;
- deprecate("if BLOCK BLOCK");
- $$ = newCONDOP(0, scope($2), scope($3), $4); }
- | UNLESS block block else
- { copline = $1;
- deprecate("unless BLOCK BLOCK");
- $$ = newCONDOP(0, invert(scalar(scope($2))),
- scope($3), $4); }
+ $$ = block_end($3,
+ newCONDOP(0, $4, scope($6), $7)); }
;
cont : /* NULL */
@@ -176,43 +182,41 @@ cont : /* NULL */
{ $$ = scope($2); }
;
-loop : label WHILE '(' texpr ')' block cont
- { copline = $2;
- $$ = newSTATEOP(0, $1,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- $4, $6, $7) ); }
- | label UNTIL '(' expr ')' block cont
- { copline = $2;
- $$ = newSTATEOP(0, $1,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- invert(scalar($4)), $6, $7) ); }
- | label WHILE block block cont
+loop : label WHILE '(' remember mtexpr ')' mblock cont
{ copline = $2;
- $$ = newSTATEOP(0, $1,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- scope($3), $4, $5) ); }
- | label UNTIL block block cont
+ $$ = block_end($4,
+ newSTATEOP(0, $1,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ $2, $5, $7, $8))); }
+ | label UNTIL '(' remember miexpr ')' mblock cont
{ copline = $2;
- $$ = newSTATEOP(0, $1,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- invert(scalar(scope($3))), $4, $5)); }
- | label FOR scalar '(' expr ')' block cont
- { $$ = newFOROP(0, $1, $2, mod($3, OP_ENTERLOOP),
- $5, $7, $8); }
- | label FOR '(' expr ')' block cont
- { $$ = newFOROP(0, $1, $2, Nullop, $4, $6, $7); }
- | label FOR '(' nexpr ';' texpr ';' nexpr ')' block
+ $$ = 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 */
- { copline = $2;
- $$ = append_elem(OP_LINESEQ,
- newSTATEOP(0, $1, scalar($4)),
- newSTATEOP(0, $1,
+ { OP *forop = append_elem(OP_LINESEQ,
+ scalar($5),
newWHILEOP(0, 1, (LOOP*)Nullop,
- scalar($6), $10, scalar($8)) )); }
+ $2, scalar($7),
+ $11, scalar($9)));
+ 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,
- Nullop, $2, $3)); }
+ { $$ = newSTATEOP(0, $1,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ NOLINE, Nullop, $2, $3)); }
;
nexpr : /* NULL */
@@ -225,6 +229,26 @@ texpr : /* NULL means true */
| 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
@@ -240,25 +264,43 @@ decl : format
{ $$ = 0; }
;
-format : FORMAT startsub WORD block
+format : FORMAT startformsub formname block
{ newFORM($2, $3, $4); }
- | FORMAT startsub block
- { newFORM($2, Nullop, $3); }
;
-subrout : SUB startsub WORD proto block
+formname: WORD { $$ = $1; }
+ | /* NULL */ { $$ = Nullop; }
+ ;
+
+subrout : SUB startsub subname proto subbody
{ newSUB($2, $3, $4, $5); }
- | SUB startsub WORD proto ';'
- { newSUB($2, $3, $4, Nullop); expect = XSTATE; }
+ ;
+
+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 = SvPVx(((SVOP*)$1)->op_sv, na);
+ if (strEQ(name, "BEGIN") || strEQ(name, "END"))
+ CvUNIQUE_on(compcv);
+ $$ = $1; }
;
proto : /* NULL */
{ $$ = Nullop; }
| THING
;
-
-startsub: /* NULL */ /* start a subroutine scope */
- { $$ = start_subparse(); }
+
+subbody : block { $$ = $1; }
+ | ';' { $$ = Nullop; expect = XSTATE; }
;
package : PACKAGE WORD ';'
@@ -267,8 +309,10 @@ package : PACKAGE WORD ';'
{ package(Nullop); }
;
-use : USE startsub WORD listexpr ';'
- { utilize($1, $2, $3, $4); }
+use : USE startsub
+ { CvUNIQUE_on(compcv); /* It's a BEGIN {} */ }
+ WORD WORD listexpr ';'
+ { utilize($1, $2, $4, $5, $6); }
;
expr : expr ANDOP expr
@@ -294,7 +338,7 @@ listop : LSTOP indirob argexpr
| term ARROW method '(' listexprcom ')'
{ $$ = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
- prepend_elem(OP_LIST, $1, $5),
+ prepend_elem(OP_LIST, scalar($1), $5),
newUNOP(OP_METHOD, 0, $3))); }
| METHOD indirob listexpr
{ $$ = convert(OP_ENTERSUB, OPf_STACKED,
@@ -310,11 +354,12 @@ listop : LSTOP indirob argexpr
{ $$ = convert($1, 0, $2); }
| FUNC '(' listexprcom ')'
{ $$ = convert($1, 0, $3); }
- | LSTOPSUB startsub block listexpr %prec LSTOP
+ | LSTOPSUB startanonsub block
+ { $3 = newANONSUB($2, 0, $3); }
+ listexpr %prec LSTOP
{ $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST,
- prepend_elem(OP_LIST, newANONSUB($2, 0, $3), $4),
- $1)); }
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, $3, $5), $1)); }
;
method : METHOD
@@ -374,7 +419,7 @@ term : term ASSIGNOP term
| PREDEC term
{ $$ = newUNOP(OP_PREDEC, 0,
mod(scalar($2), OP_PREDEC)); }
- | LOCAL term %prec UNIOP
+ | local term %prec UNIOP
{ $$ = localize($2,$1); }
| '(' expr ')'
{ $$ = sawparens($2); }
@@ -388,7 +433,7 @@ term : term ASSIGNOP term
{ $$ = newANONHASH($2); }
| HASHBRACK ';' '}' %prec '('
{ $$ = newANONHASH(Nullop); }
- | ANONSUB startsub proto block %prec '('
+ | ANONSUB startanonsub proto block %prec '('
{ $$ = newANONSUB($2, $3, $4); }
| scalar %prec '('
{ $$ = $1; }
@@ -484,6 +529,13 @@ term : term ASSIGNOP term
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);
hints |= HINT_BLOCK_SCOPE; }
@@ -505,7 +557,7 @@ term : term ASSIGNOP term
| FUNC0 '(' ')'
{ $$ = newOP($1, 0); }
| FUNC0SUB
- { $$ = newUNOP(OP_ENTERSUB, 0,
+ { $$ = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar($1)); }
| FUNC1 '(' ')'
{ $$ = newOP($1, OPf_SPECIAL); }
@@ -533,6 +585,14 @@ listexprcom: /* NULL */
{ $$ = $1; }
;
+local : LOCAL { $$ = 0; }
+ | MY { $$ = 1; }
+ ;
+
+my_scalar: scalar
+ { in_my = 0; $$ = my($1); }
+ ;
+
amper : '&' indirob
{ $$ = newCVREF($1,$2); }
;
diff --git a/gnu/usr.bin/perl/plan9/aperl b/gnu/usr.bin/perl/plan9/aperl
new file mode 100644
index 00000000000..4d032e3c3d7
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/aperl
@@ -0,0 +1,7 @@
+#!/bin/rc
+
+# aperl:
+# Executes perl command and alters stderr to produce Acme-friendly error messages
+# Created 02-JUL-1996, Luther Huffman, lutherh@stratcom.com
+
+/bin/perl $* |[2] /bin/perl -pe 's/ line (\d+)/:$1/' >[1=2]
diff --git a/gnu/usr.bin/perl/plan9/arpa/inet.h b/gnu/usr.bin/perl/plan9/arpa/inet.h
new file mode 100644
index 00000000000..518d517190c
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/arpa/inet.h
@@ -0,0 +1,7 @@
+/* Declarations which would have been found in <arpa/inet.h> */
+/* On Plan 9, these are found in <netinet/in.h> */
+
+/* extern unsigned long inet_addr(const char *); */
+/* extern char *inet_ntoa(struct in_addr); */
+
+#include <netinet/in.h>
diff --git a/gnu/usr.bin/perl/plan9/buildinfo b/gnu/usr.bin/perl/plan9/buildinfo
new file mode 100644
index 00000000000..9ec2c590b97
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/buildinfo
@@ -0,0 +1 @@
+p9pvers = 5.004
diff --git a/gnu/usr.bin/perl/plan9/config.plan9 b/gnu/usr.bin/perl/plan9/config.plan9
new file mode 100644
index 00000000000..463c0942fbb
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/config.plan9
@@ -0,0 +1,1709 @@
+/*
+ * This file is mangled by fndvers (and perhaps other scripts) to produce the config.h
+ * for Plan 9. It was handwritten because the standard configuration scripts were
+ * written in a shell dialect incomprehensible to Plan 9.
+ * config.h for Plan 9
+ * Version: 5.004
+ */
+
+/* Configuration time: 21-Oct-1996 15:11
+ * Configured by: Luther Huffman, lutherh@stratcom.com
+ * Target system: Plan 9
+ */
+
+#ifndef _config_h_
+#define _config_h_
+
+/* CAT2:
+ * This macro catenates 2 tokens together.
+ */
+
+#define CAT2(a,b)a ## b
+#define CAT3(a,b,c)a ## b ## c
+#define CAT4(a,b,c,d)a ## b ## c ## d
+#define CAT5(a,b,c,d,e)a ## b ## c ## d ## e
+#define StGiFy(a)# a
+#define STRINGIFY(a)StGiFy(a)
+#define SCAT2(a,b)StGiFy(a) StGiFy(b)
+#define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c)
+#define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d)
+#define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e)
+
+/* config-start */
+
+/* MEM_ALIGNBYTES:
+ * This symbol contains the number of bytes required to align a
+ * double. Usual values are 2, 4 and 8.
+ */
+#if (_P9P_OBJTYPE == 386) || (_P9P_OBJTYPE==power)
+# define MEM_ALIGNBYTES 4 /* config-skip */
+#else
+# if _P9P_OBJTYPE == 68020
+# define MEM_ALIGNBYTES 2 /* config-skip */
+# else
+# define MEM_ALIGNBYTES 8 /* config-skip */
+# endif
+#endif
+
+/* 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 "/_P9P_OBJTYPE/bin" /* */
+#define BIN_EXP "/_P9P_OBJTYPE/bin" /* */
+
+/* BINCOMPAT3:
+ * This symbol, if defined, indicates that Perl 5.004 should be
+ * binary-compatible with Perl 5.003.
+ */
+#undef BINCOMPAT3 /**/
+
+/* 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 "cpp"
+#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.
+ */
+#undef HASATTRIBUTE /* config-skip*/
+#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 /**/
+
+/* CASTI32:
+ * This symbol is defined if the C compiler can cast negative
+ * or large floating point numbers to 32-bit ints.
+ */
+#undef 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
+ */
+#undef CASTNEGFLOAT /**/
+#if _P9P_OBJTYPE == 386
+# define CASTFLAGS 3 /**/ /* config-skip */
+#else
+# define CASTFLAGS 0 /**/ /* config-skip */
+#endif
+
+/* HAS_CHOWN:
+ * This symbol, if defined, indicates that the chown routine is
+ * available.
+ */
+#undef HAS_CHOWN /**/
+
+/* HAS_CHROOT:
+ * This symbol, if defined, indicates that the chroot routine is
+ * available.
+ */
+#undef 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.
+ */
+#undef HAS_CHSIZE /**/
+
+/* VOID_CLOSEDIR:
+ * This symbol, if defined, indicates that the closedir() routine
+ * does not return a value.
+ */
+#define VOID_CLOSEDIR /**/
+
+/* 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 /**/
+
+/* 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.
+ */
+#undef 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().
+ */
+#undef HAS_DLERROR /**/
+
+/* 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().
+ */
+#undef 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().
+ */
+#undef 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.
+ */
+#undef 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_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.
+ */
+/* 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.
+ */
+#undef HAS_GETGROUPS /* config-skip */
+#undef HAS_SETGROUPS /* config-skip */
+
+/* HAS_GETHOSTENT:
+ * This symbol, if defined, indicates that the gethostent routine is
+ * available to lookup host names in some data base or other.
+ */
+#undef HAS_GETHOSTENT /* config-skip */
+
+/* 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.
+ */
+#undef HAS_UNAME /**/
+
+/* HAS_GETLOGIN:
+ * This symbol, if defined, indicates that the getlogin routine is
+ * available to get the login name.
+ */
+#define HAS_GETLOGIN /**/
+
+/* 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 /**/
+#undef 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.
+ */
+#undef 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.
+ */
+#undef HAS_GETPRIORITY /**/
+
+/* 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 /**/
+#define Timeval struct timeval /* Structure used by gettimeofday() */ /* config-skip */
+
+/* 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.
+ */
+#undef HAS_INET_ATON /**/
+
+/* HAS_ISASCII:
+ * This manifest constant lets the C program know that isascii
+ * is available.
+ */
+#undef HAS_ISASCII /**/
+
+/* 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.
+ */
+#undef 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.
+ */
+#undef 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).
+ */
+#undef HAS_MSG /**/
+
+/* HAS_NICE:
+ * This symbol, if defined, indicates that the nice routine is
+ * available.
+ */
+#undef HAS_NICE /**/
+
+/* HAS_OPEN3:
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+#define HAS_OPEN3 /**/
+
+/* 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.
+ */
+#undef 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_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_SEEKDIR:
+ * This symbol, if defined, indicates that the seekdir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+#undef 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.
+ */
+#undef 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_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.
+ */
+#undef 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.
+ */
+#undef HAS_SAFE_MEMCPY /**/
+
+/* 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 /* config-skip */
+
+/* HAS_SEM:
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+#undef HAS_SEM /**/
+
+/* HAS_SETEGID:
+ * This symbol, if defined, indicates that the setegid routine is available
+ * to change the effective gid of the current program.
+ */
+#undef HAS_SETEGID /**/
+
+/* HAS_SETEUID:
+ * This symbol, if defined, indicates that the seteuid routine is available
+ * to change the effective uid of the current program.
+ */
+#undef 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.
+ */
+#undef 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 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_BSDPGRP:
+ * This symbol, if defined, indicates that the BSD notion of process
+ * group is to be used. For instance, you have to say setpgrp(pid, pgrp)
+ * instead of the USG setpgrp().
+ */
+/* 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.
+ */
+#undef HAS_SETPGRP /**/
+#undef USE_BSDPGRP /**/
+#undef 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.
+ */
+#undef HAS_SETPGRP2 /**/
+
+/* HAS_SETPRIORITY:
+ * This symbol, if defined, indicates that the setpriority routine is
+ * available to set a process's priority.
+ */
+#undef 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.
+ */
+#undef HAS_SETREGID /**/
+#undef 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.
+ */
+#undef HAS_SETREUID /**/
+#undef HAS_SETRESUID /**/
+
+/* HAS_SETRGID:
+ * This symbol, if defined, indicates that the setrgid routine is available
+ * to change the real gid of the current program.
+ */
+#undef HAS_SETRGID /**/
+
+/* HAS_SETRUID:
+ * This symbol, if defined, indicates that the setruid routine is available
+ * to change the real uid of the current program.
+ */
+#undef 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.
+ */
+#undef 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.
+ */
+#undef Shmat_t /* config-skip */
+#undef HAS_SHMAT_PROTOTYPE /**/
+
+/* HAS_SIGACTION:
+ * This symbol, if defined, indicates that Vr4's sigaction() routine
+ * is available.
+ */
+#define HAS_SIGACTION /**/
+
+/* 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_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 /**/
+
+/* USE_STAT_BLOCKS:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+#undef USE_STAT_BLOCKS /**/
+
+/* 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.
+ */
+/* 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.
+ */
+#undef USE_STDIO_PTR /**/
+#undef USE_STDIO_BASE /**/
+
+/* 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.
+ */
+#ifdef USE_STDIO_PTR
+#define FILE_ptr(fp) ((fp)->_ptr)
+#define STDIO_PTR_LVALUE /**/
+#define FILE_cnt(fp) ((fp)->_cnt)
+#define STDIO_CNT_LVALUE /**/
+#endif
+
+/* 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.
+ */
+#ifdef USE_STDIO_BASE
+#define FILE_base(fp) ((fp)->_base)
+#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
+#endif
+
+/* 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 /**/
+#undef 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_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.
+ */
+#undef 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 /**/
+
+/* Time_t:
+ * This symbol holds the type returned by time(). It can be long,
+ * or time_t on BSD sites (in which case <sys/types.h> should be
+ * included).
+ */
+#define Time_t time_t /* Time type */
+
+/* HAS_TIMES:
+ * This symbol, if defined, indicates that the times() routine exists.
+ * Note that this became obsolete on some systems (SUNOS), which now
+ * use getrusage(). It may be necessary to include <sys/times.h>.
+ */
+#define HAS_TIMES /**/
+
+/* HAS_TRUNCATE:
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
+ */
+#undef 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.
+ */
+#undef HAS_VFORK /**/
+
+/* Signal_t:
+ * This symbol's value is either "void" or "int", corresponding to the
+ * appropriate return type of a signal handler. Thus, you can declare
+ * a signal handler using "Signal_t (*handler)()", and define the
+ * handler using "Signal_t handler(sig)".
+ */
+#define Signal_t void /* Signal handler's return type */
+
+/* HASVOLATILE:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+#define HASVOLATILE /**/
+#ifndef HASVOLATILE
+#define volatile /* config-skip */
+#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 /**/
+
+/* HAS_WAIT4:
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+#undef HAS_WAIT4 /**/
+
+/* HAS_WAITPID:
+ * This symbol, if defined, indicates that the waitpid routine is
+ * available to wait for child process.
+ */
+#undef 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 /**/
+
+/* 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 /* config-skip */
+
+/* Groups_t:
+ * This symbol holds the type used for the second argument to
+ * [gs]etgroups(). Usually, this is the same of gidtype, 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 setgroups().
+ */
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+#define Groups_t gid_t /* Type for 2nd arg to [gs]etgroups() */
+#endif
+
+/* DB_Prefix_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is u_int32_t.
+ */
+/* DB_Hash_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is size_t.
+ */
+#define DB_Hash_t int /**/
+#define DB_Prefix_t int /**/
+
+/* 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 /**/
+#undef DIRNAMLEN /**/
+#define Direntry_t struct dirent
+
+/* I_DLFCN:
+ * This symbol, if defined, indicates that <dlfcn.h> exists and should
+ * be included.
+ */
+#undef 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>.
+ */
+#define I_GRP /**/
+
+/* 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_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>.
+ */
+#undef I_MEMORY /**/
+
+/* I_NDBM:
+ * This symbol, if defined, indicates that <ndbm.h> exists and should
+ * be included.
+ */
+#undef I_NDBM /**/
+
+/* I_NET_ERRNO:
+ * This symbol, if defined, indicates that <net/errno.h> exists and
+ * should be included.
+ */
+#undef I_NET_ERRNO /* config-skip */
+
+/* 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 /* config-skip */
+
+/* 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.
+ */
+#define I_PWD /**/
+#undef PWQUOTA /**/
+#undef PWAGE /**/
+#undef PWCHANGE /**/
+#undef PWCLASS /**/
+#undef PWEXPIRE /**/
+#undef PWCOMMENT /**/
+
+/* 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>.
+ */
+#undef 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.
+ */
+#undef 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>.
+ */
+#undef 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 /**/
+
+/* Plan 9: file position in Plan 9 is <select.h> */
+/* 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.
+ */
+#undef I_SYS_SELECT /**/
+
+/* 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_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.
+ */
+#undef I_TERMIO /**/
+#define I_TERMIOS /**/
+#undef I_SGTTY /**/
+
+/* Plan 9: P9 has both <time.h> and <sys/time.h> */
+/* 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 /**/
+#undef I_SYS_TIME_KERNEL /**/
+
+/* 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_VFORK:
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+#undef I_VFORK /**/
+
+/* 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 */
+
+/* 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 /* config-skip */
+#else
+#define _(args) () /* config-skip */
+#endif
+
+/* RANDBITS:
+ * This symbol contains the number of bits of random number the rand()
+ * function produces. Usual values are 15, 16, and 31.
+ */
+#define RANDBITS 15 /**/
+
+/* 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 * /**/
+
+/* 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 */
+
+/* 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 */
+
+/* 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 /**/
+
+/* 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 */
+
+/* PLAN9:
+ This symbol, if defined, indicates that the program is running under the
+* Plan 9 operating system.
+*/
+#define PLAN9 /**/
+
+#define OSNAME "plan9"
+
+#define BIN_SH "/bin/rc" /* config-skip */
+
+/* MYMALLOC:
+ * This symbol, if defined, indicates that we're using our own malloc.
+ */
+#undef MYMALLOC /**/
+
+
+#undef VMS /* config-skip */
+
+/* LOC_SED:
+ * This symbol holds the complete pathname to the sed program.
+ */
+#define LOC_SED "/bin/sed" /**/
+
+/* 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_EXP "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION"
+#define ARCHLIB "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION"
+
+/* 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 "plan9__P9P_OBJTYPE" /**/
+
+/* BYTEORDER:
+ * This symbol hold the hexadecimal constant defined in byteorder,
+ * i.e. 0x1234 or 0x4321, etc...
+ */
+#if _P9P_OBJTYPE == 386
+# define BYTEORDER 0x1234 /* little-endian */ /* config-skip */
+#else
+# define BYTEORDER 0x4321 /* big-endian */ /* config-skip */
+#endif
+
+/* CSH:
+ * This symbol, if defined, indicates that the C-shell exists.
+ * If defined, contains the full pathname of csh.
+ */
+#undef CSH /**/
+
+/* 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.
+ */
+#undef DLSYM_NEEDS_UNDERSCORE /* */
+
+/* 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 /**/
+#undef DOSUID /**/
+
+/* Gconvert:
+ * This preprocessor macro is defined to convert a floating point
+ * number to a string without a trailing decimal point. This
+ * emulates the behavior of sprintf("%g"), but is sometimes much more
+ * efficient. If gconvert() is not available, but gcvt() drops the
+ * trailing decimal point, then gcvt() is used. If all else fails,
+ * a macro using sprintf("%g") is used. Arguments for the Gconvert
+ * macro are: value, number of digits, whether trailing zeros should
+ * be retained, and the output buffer.
+ * Possible values are:
+ * d_Gconvert='gconvert((x),(n),(t),(b))'
+ * d_Gconvert='gcvt((x),(n),(b))'
+ * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ * The last two assume trailing zeros should not be kept.
+ */
+#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
+
+/* 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.
+ */
+/* Siglongjmp:
+ * This macro is used in the same way as siglongjmp(), but will invoke
+ * traditional longjmp() if siglongjmp isn't available.
+ */
+#define HAS_SIGSETJMP /**/ /* config-skip */
+#define Sigjmp_buf sigjmp_buf /* config-skip */
+#define Sigsetjmp(buf,save_mask) sigsetjmp(buf,save_mask) /* config-skip */
+#define Siglongjmp(buf,retval) siglongjmp(buf,retval) /* config-skip */
+
+/* USE_DYNAMIC_LOADING:
+ * This symbol, if defined, indicates that dynamic loading of
+ * some sort is available.
+ */
+#undef USE_DYNAMIC_LOADING /**/
+
+/* 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.
+ */
+#undef I_DBM /**/
+#undef I_RPCSVC_DBM /**/
+
+/* I_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
+#define I_LOCALE /**/
+
+/* I_SYS_STAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/stat.h>.
+ */
+#define I_SYS_STAT /**/
+
+/* 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 /**/
+#undef I_VARARGS /**/
+
+/* 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 /**/
+
+/* 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 /**/
+
+/* 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
+
+/* OLDARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of OLDARCHLIB, to be
+ * used in programs that are not prepared to deal with ~ expansion at
+ * run-time.
+ */
+#undef OLDARCHLIB_EXP /**/
+#undef OLDARCHLIB /**/
+
+/* 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_EXP "/sys/lib/perl" /* */
+#define PRIVLIB "/sys/lib/perl" /* */
+
+/* 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","ABRT","FPE","KILL","SEGV","PIPE","ALRM","TERM","USR1","USR2","CHLD","CONT","STOP","TSTP","TTIN","TTOU",0 /* config-skip */
+#define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,0 /* config-skip */
+
+/* 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_EXP "/sys/lib/perl/site_perl" /* */
+#define SITELIB "/sys/lib/perl/site_perl" /* */
+
+/* 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_EXP "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION/site_perl" /* */
+#define SITEARCH "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION/site_perl" /* */
+
+/* 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 "#!/bin/perl" /**/
+
+/* SH_PATH:
+ * Just here to shut up compiler warnings.
+*/
+#define SH_PATH "/bin/rc" /**/
+
+#define PERLIO_IS_STDIO /* config-skip */
+#undef I_SFIO
+
+/* 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.
+ */
+#undef USE_PERLIO /**/
+
+/* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+#undef USE_SFIO /**/
+
+/* HAS_GETPGID:
+ * This symbol, if defined, indicates to the C program that
+ * the getpgid(pid) function is available to get the
+ * process group id.
+ */
+#undef HAS_GETPGID /**/
+
+/* 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_WAIT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/wait.h>.
+ */
+#define I_SYS_WAIT /**/
+
+/* 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.
+ */
+#undef I_VALUES /**/
+
+/* 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? */ /* config-skip */
+#define M_VOID /* Xenix strikes again */ /* config-skip */
+#endif
+
+#endif
diff --git a/gnu/usr.bin/perl/plan9/exclude b/gnu/usr.bin/perl/plan9/exclude
new file mode 100644
index 00000000000..7d9fc3c8afd
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/exclude
@@ -0,0 +1,18 @@
+comp/cpp.t
+io/dup.t
+io/fs.t
+lib/anydbm.t
+lib/complex.t
+lib/filefind.t
+lib/io_dup.t
+lib/io_pipe.t
+lib/io_sock.t
+lib/io_udp.t
+lib/posix.t
+lib/socket.t
+op/exec.t
+op/goto.t
+op/misc.t
+op/oct.t
+op/split.t
+op/stat.t
diff --git a/gnu/usr.bin/perl/plan9/fndvers b/gnu/usr.bin/perl/plan9/fndvers
new file mode 100644
index 00000000000..a848de2b6db
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/fndvers
@@ -0,0 +1,14 @@
+#!/bin/rc
+
+. plan9/buildinfo
+
+ed plan9/config.plan9 <<!
+g/_P9P_VERSION/s//$p9pvers/g
+g/_P9P_OBJTYPE/s//$objtype/g
+w config.h
+!
+
+ed plan9/genconfig.pl<<!
+g/_P9P_VERSION/s//$p9pvers/g
+w plan9/genconfig.pl
+!
diff --git a/gnu/usr.bin/perl/plan9/genconfig.pl b/gnu/usr.bin/perl/plan9/genconfig.pl
new file mode 100644
index 00000000000..458c4c3ee9b
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/genconfig.pl
@@ -0,0 +1,275 @@
+#!../miniperl
+# Habit . . .
+#
+# Extract info from config.h, and add extra data here, to generate config.sh
+# Edit the static information after __END__ to reflect your site and options
+# that went into your perl binary. In addition, values which change from run
+# to run may be supplied on the command line as key=val pairs.
+#
+# Last Modified: 28-Jun-1996 Luther Huffman lutherh@stratcom.com
+#
+
+#==== Locations of installed Perl components
+$p9pvers="_P9P_VERSION";
+$prefix='';
+$p9p_objtype=$ENV{'objtype'};
+$builddir="/sys/src/cmd/perl/$p9pvers";
+$installbin="/$p9p_objtype/bin";
+$installman1dir="/sys/man/1";
+$installman3dir="/sys/man/2";
+$installprivlib="/sys/lib/perl";
+$installarchlib = "/$p9p_objtype/lib/perl/$p9pvers";
+$archname="plan9_$p9p_objtype";
+$installsitelib="$installprivlib/site_perl";
+$installsitearch="$installarchlib/site_perl";
+$installscript="/bin";
+
+unshift(@INC,'lib'); # In case someone didn't define Perl_Root
+ # before the build
+
+if ($ARGV[0] eq '-f') {
+ open(ARGS,$ARGV[1]) or die "Can't read data from $ARGV[1]: $!\n";
+ @ARGV = ();
+ while (<ARGS>) {
+ push(@ARGV,split(/\|/,$_));
+ }
+ close ARGS;
+}
+
+if (-f "config.h") { $infile = "config.h"; $outdir = "../"; }
+elsif (-f "plan9/config.h") { $infile = "plan9/config.h"; $outdir = "./"; }
+
+if ($infile) { print "Generating config.sh from $infile . . .\n"; }
+else { die <<EndOfGasp;
+Can't find config.h to read!
+ Please run this script from the perl source directory or
+ the plan9 subdirectory in the distribution.
+EndOfGasp
+}
+$outdir = '';
+open(IN,"$infile") || die "Can't open $infile: $!\n";
+open(OUT,">${outdir}config.sh") || die "Can't open ${outdir}config.sh: $!\n";
+
+$time = localtime;
+$cf_by = $ENV{'user'};
+($vers = $]) =~ tr/./_/;
+
+# Plan 9 doesn't actually use version numbering. Following the original Unix
+# precedent of assigning a Unix edition number based on the edition number
+# of the manuals, I am referring to this as Plan 9, 1st edition.
+$osvers = '1';
+
+print OUT <<EndOfIntro;
+# This file generated by genconfig.pl on a Plan 9 system.
+# Input obtained from:
+# $infile
+# $0
+# Time: $time
+
+package='perl5'
+CONFIG='true'
+cf_time='$time'
+cf_by='$cf_by'
+ccdlflags=''
+cccdlflags=''
+libpth='$installprivlib'
+ld='pcc'
+lddlflags=''
+ranlib=''
+ar='ar'
+nroff='/bin/nroff'
+eunicefix=':'
+hint='none'
+hintfile=''
+intsize='4'
+longsize='4'
+shortsize='2'
+shrplib='define'
+usemymalloc='n'
+usevfork='true'
+useposix='true'
+spitshell='cat'
+dlsrc='dl_none.c'
+binexp='$installbin'
+man1ext=''
+man3ext=''
+arch='$archname'
+archname='$archname'
+osname='plan9'
+extensions='IO Socket Opcode Fcntl POSIX DynaLoader FileHandle'
+osvers='$osvers'
+sig_maxsig='19'
+sig_name='ZERO HUP INT QUIT ILL ABRT FPE KILL SEGV PIPE ALRM TERM USR1 USR2 CHLD CONT STOP TSTP TTIN TTOU'
+sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19'
+sig_numsig='20'
+prefix='$prefix'
+builddir='$builddir'
+installbin='$installbin'
+installman1dir='$installman1dir'
+installman3dir='$installman3dir'
+installprivlib='$installprivlib'
+installarchlib='$installarchlib'
+installsitelib='$installsitelib'
+installsitearch='$installsitearch'
+installscript='$installscript'
+scriptdir='$installscript'
+scriptdirexp='$installscript'
+EndOfIntro
+
+# Plan 9 compiler stuff
+print OUT "cc='pcc'\n";
+print OUT "d_attribut='undef'\n";
+print OUT "d_socket='define'\n";
+print OUT "d_sockpair='define'\n";
+print OUT "d_sigsetjmp='define'\n";
+print OUT "sigjmp_buf='sigjmp_buf'\n";
+print OUT "sigsetjmp='sigsetjmp(buf,save_mask)'\n";
+print OUT "siglongjmp='siglongjmp(buf,retval) '\n";
+print OUT "exe_ext=''\n";
+if ($p9p_objtype eq '386') {
+ $objext = '.8';
+ $alignbytes = '4';
+ $cstflags = 2;
+}
+elsif ($p9p_objtype eq '68020') {
+ $objext = '.2';
+ $alignbytes = '2';
+ $cstflags = 0;
+}
+elsif ($p9p_objtype eq 'mips') {
+ $objext = '.v';
+ $alignbytes = '8';
+ $cstflags = 0;
+}
+elsif ($p9p_objtype eq 'sparc') {
+ $objext = '.k';
+ $alignbytes = '4';
+ $cstflags = 0;
+}
+print OUT "obj_ext='$objext'\n";
+print OUT "alignbytes='$alignbytes'\n";
+print OUT "castflags='$cstflags'\n";
+
+$myname = $ENV{'site'} ;
+($myhostname,$mydomain) = split(/\./,$myname,2);
+print OUT "myhostname='$myhostname'\n" if $myhostname;
+if ($mydomain) {
+ print OUT "mydomain='.$mydomain'\n";
+ print OUT "perladmin='$cf_by\@$myhostname.$mydomain'\n";
+ print OUT "cf_email='$cf_by\@$myhostname.$mydomain'\n";
+}
+else {
+ print OUT "perladmin='$cf_by'\n";
+ print OUT "cf_email='$cf_by'\n";
+}
+print OUT "myuname='Plan9 $myname $osvers $p9p_objtype'\n";
+
+# Before we read the C header file, find out what config.sh constants are
+# equivalent to the C preprocessor macros
+if (open(SH,"${outdir}config_h.SH")) {
+ while (<SH>) {
+ next unless m%^#(?!if).*\$%;
+ s/^#//; s!(.*?)\s*/\*.*!$1!;
+ my(@words) = split;
+ $words[1] =~ s/\(.*//; # Clip off args from macro
+ # Did we use a shell variable for the preprocessor directive?
+ if ($words[0] =~ m!^\$(\w+)!) { $pp_vars{$words[1]} = $1; }
+ if (@words > 2) { # We may also have a shell var in the value
+ shift @words; # Discard preprocessor directive
+ my($token) = shift @words; # and keep constant name
+ my($word);
+ foreach $word (@words) {
+ next unless $word =~ m!\$(\w+)!;
+ $val_vars{$token} = $1;
+ last;
+ }
+ }
+ }
+ close SH;
+}
+else { warn "Couldn't read ${outfile}config_h.SH: $!\n"; }
+$pp_vars{PLAN9} = 'define'; #Plan 9 specific
+
+# OK, now read the C header file, and retcon statements into config.sh
+while (<IN>) { # roll through the comment header in config.h
+ last if /config-start/;
+}
+
+while (<IN>) {
+ chop;
+ while (/\\\s*$/) { # pick up contination lines
+ my $line = $_;
+ $line =~ s/\\\s*$//;
+ $_ = <IN>;
+ s/^\s*//;
+ $_ = $line . $_;
+ }
+ next unless my ($blocked,$un,$token,$val) =
+ m%^(\/\*)?\s*\#\s*(un)?def\w*\s+([A-Za-z0-9]\w+)\S*\s*(.*)%;
+ if (/config-skip/) {
+ delete $pp_vars{$token} if exists $pp_vars{$token};
+ delete $val_vars{$token} if exists $val_vars{$token};
+ next;
+ }
+ $val =~ s!\s*/\*.*!!; # strip off trailing comment
+ my($had_val); # Maybe a macro with args that we just #undefd or commented
+ if (!length($val) and $val_vars{$token} and ($un || $blocked)) {
+ print OUT "$val_vars{$token}=''\n";
+ delete $val_vars{$token};
+ $had_val = 1;
+ }
+ $state = ($blocked || $un) ? 'undef' : 'define';
+ if ($pp_vars{$token}) {
+ print OUT "$pp_vars{$token}='$state'\n";
+ delete $pp_vars{$token};
+ }
+ elsif (not length $val and not $had_val) {
+ # Wups -- should have been shell var for C preprocessor directive
+ warn "Constant $token not found in config_h.SH\n";
+ $token =~ tr/A-Z/a-z/;
+ $token = "d_$token" unless $token =~ /^i_/;
+ print OUT "$token='$state'\n";
+ }
+ next unless length $val;
+ $val =~ s/^"//; $val =~ s/"$//; # remove end quotes
+ $val =~ s/","/ /g; # make signal list look nice
+
+ if ($val_vars{$token}) {
+ print OUT "$val_vars{$token}='$val'\n";
+ if ($val_vars{$token} =~ s/exp$//) {print OUT "$val_vars{$token}='$val'\n";}
+ delete $val_vars{$token};
+ }
+ elsif (!$pp_vars{$token}) { # Haven't seen it previously, either
+ warn "Constant $token not found in config_h.SH (val=|$val|)\n";
+ $token =~ tr/A-Z/a-z/;
+ print OUT "$token='$val'\n";
+ if ($token =~ s/exp$//) {print OUT "$token='$val'\n";}
+ }
+}
+close IN;
+
+foreach (sort keys %pp_vars) {
+ warn "Didn't see $_ in $infile\n";
+}
+foreach (sort keys %val_vars) {
+ warn "Didn't see $_ in $infile(val)\n";
+}
+
+
+# print OUT "libs='",join(' ',@libs),"'\n";
+# print OUT "libc='",join(' ',@crtls),"'\n";
+
+if (open(PL,"${outdir}patchlevel.h")) {
+ while (<PL>) {
+ if (/^#define PATCHLEVEL\s+(\S+)/) { print OUT "PATCHLEVEL='$1'\n"; }
+ elsif (/^#define SUBVERSION\s+(\S+)/) { print OUT "SUBVERSION='$1'\n"; }
+ }
+ close PL;
+}
+else { warn "Can't read ${outdir}patchlevel.h - skipping 'PATCHLEVEL'"; }
+
+print OUT "pager='/bin/p'\n";
+
+close OUT;
+
+
diff --git a/gnu/usr.bin/perl/plan9/mkfile b/gnu/usr.bin/perl/plan9/mkfile
new file mode 100644
index 00000000000..e56aa3c472c
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/mkfile
@@ -0,0 +1,143 @@
+APE=/sys/src/ape
+< $APE/config
+<plan9/buildinfo
+sourcedir = /sys/src/cmd/perl/$p9pvers
+archname = plan9_$objtype
+privlib=/sys/lib/perl
+archlib = /$objtype/lib/perl/$p9pvers
+sitelib = $privlib/site_perl
+sitearch = $archlib/site_perl
+
+CFLAGS = -B -D_POSIX_SOURCE -D_BSD_EXTENSION -DMY_UV_MAX=0x7fffffffUL
+LDFLAGS = -B
+
+CCCMD = $CC -c $CFLAGS
+
+perllib = $archlib/CORE/libperl.a
+
+perlshr = $archlib/CORE/libperlshr.a
+
+installman1dir = /sys/man/1
+installman3dir = /sys/man/2
+
+podnames = perl perlbook perlbot perlcall perldata perldebug perldiag perldsc perlembed perlform perlfunc perlguts perlipc perllol perlmod perlobj perlop perlpod perlre perlref perlrun perlsec perlstyle perlsub perlsyn perltie perltoc perltrap perlvar perlxs perlxstut
+
+libpods = ${podnames:%=pod/%.pod}
+
+perlpods = $libpods
+
+extensions = IO Socket Opcode DynaLoader Fcntl POSIX
+ext_xs = IO.xs Socket.xs Opcode.xs dl_none.xs Fcntl.xs POSIX.xs
+ext_c = ${ext_xs:%.xs=%.c}
+ext_obj = ${ext_xs:%.xs=%.$O}
+
+obj = gv.$O toke.$O perly.$O op.$O regcomp.$O dump.$O util.$O mg.$O hv.$O av.$O run.$O pp_hot.$O sv.$O pp.$O scope.$O pp_ctl.$O pp_sys.$O doop.$O doio.$O regexec.$O taint.$O deb.$O globals.$O plan9.$O universal.$O perlio.$O
+
+OBJS = perl.$O $obj
+
+testlist = base/*.t comp/*.t cmd/*.t io/*.t op/*.t
+
+install:V: perl preplibrary
+ cp perl /$objtype/bin/perl
+ cp plan9/aperl /rc/bin/Perl
+ mk man
+
+perl: config.h miniperlmain.$O miniperl $archlib/Config.pm perlmain.$O $perlshr
+ $LD $CFLAGS -o perl perlmain.$O $perllib $perlshr
+
+miniperl: config.h $perllib miniperlmain.$O
+ $LD $CFLAGS -o miniperl miniperlmain.$O $perllib
+
+preplibrary:V: miniperl $archlib/Config.pm
+ cd $privlib
+ for (file in *.pm */*.pm $archlib/Config.pm) $sourcedir/miniperl -e 'use AutoSplit; autosplit(@ARGV)' $file $privlib/auto
+
+$perllib(%):N: %
+$perllib: ${OBJS:%=$perllib(%)}
+ ar rv $perllib $OBJS
+ $RANLIB $perllib
+
+miniperlmain.$O: config.h
+ $CCCMD miniperlmain.c
+
+perlmain.$O: config.h perlmain.c
+ $CCCMD perlmain.c
+
+perlmain.c: miniperl vms/writemain.pl
+ ./miniperl vms/writemain.pl $extensions
+
+config.h: plan9/fndvers
+ plan9/fndvers
+ cp config.h $archlib/CORE
+
+$perlshr(%):N: %
+$perlshr: ${ext_obj:%=$perlshr(%)}
+ ar rv $perlshr $ext_obj
+ $RANLIB $perlshr
+
+IO.c: miniperl ext/IO/IO.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/IO/IO.xs > $target
+ cp ext/IO/*.pm $privlib
+ if (test !-d $privlib/IO) {
+ mkdir $privlib/IO
+ cp ext/IO/lib/IO/*.pm $privlib/IO
+ }
+
+Socket.$O: config.h Socket.c
+ $CCCMD -I plan9 Socket.c
+
+Socket.c: miniperl ext/Socket/Socket.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Socket/Socket.xs > $target
+ cp ext/Socket/Socket.pm $privlib
+
+Opcode.c: miniperl ext/Opcode/Opcode.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Opcode/Opcode.xs > $target
+ cp ext/Opcode/*.pm $privlib
+
+Fcntl.c: miniperl ext/Fcntl/Fcntl.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Fcntl/Fcntl.xs > $target
+ cp ext/Fcntl/Fcntl.pm $privlib
+
+POSIX.c: miniperl ext/POSIX/POSIX.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/POSIX/POSIX.xs > $target
+ cp ext/POSIX/POSIX.pm $privlib
+
+dl_none.c: miniperl ext/DynaLoader/dl_none.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/DynaLoader/dl_none.xs > $target
+ cp ext/DynaLoader/DynaLoader.pm $privlib
+
+test:V:
+ bind -b $privlib $sourcedir/lib
+ bind -b $archlib $sourcedir/lib
+ cd $sourcedir/t
+ rm -f perl
+ cp /$objtype/bin/perl $sourcedir/t
+ perl TEST `{ ls */*.t | comm -23 - ../plan9/exclude }
+
+plan9.$O: config.h ./plan9/plan9.c
+ cp ./plan9/plan9.c ./plan9.c
+ $CCCMD plan9.c
+
+%.$O: config.h %.c
+ $CCCMD $stem.c
+
+$archlib/Config.pm: miniperl config.sh
+ ./miniperl configpm $archlib/Config.pm
+
+config.sh: miniperl config.h
+ ./miniperl ./plan9/genconfig.pl
+
+installall:V:
+ for (objtype in 386 mips 68020 sparc) mk install
+
+man:V: $perlpods pod/pod2man.PL perl
+ perl pod/pod2man.PL
+ for (i in $podnames) pod/pod2man pod/$i.pod > $installman3dir/$i
+ pod/pod2man plan9/perlplan9.pod > $installman3dir/perlplan9
+
+nuke clean:V:
+ rm -f *.$O $extensions^.pm config.sh $perllib config.h $perlshr perlmain.c perl miniperl $archlib/Config.pm $ext_c
+ rm -rf $privlib/IO
+
+deleteman:V:
+ rm -f $installman1dir/perl* $installman3dir/perl*
diff --git a/gnu/usr.bin/perl/plan9/myconfig.plan9 b/gnu/usr.bin/perl/plan9/myconfig.plan9
new file mode 100644
index 00000000000..f336a7ce530
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/myconfig.plan9
@@ -0,0 +1,39 @@
+#!/bin/rc
+
+# 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.
+
+#This script is the "myconfig" script altered to run on Plan 9.
+#Last Modified: 28-Jun-96 Luther Huffman lutherh@stratcom.com
+
+
+. config.sh
+
+# Note that the text lines /^Summary of/ .. /^\s*$/ are copied into Config.pm.
+# XXX Add d_sigaction (?) once it's defined.
+
+$spitshell<<!GROK!THIS!
+
+Summary of my $package ($baserev patchlevel $PATCHLEVEL) configuration:
+ Platform:
+ osname=$osname, osver=$osvers, archname=$archname
+ uname='$myuname'
+ hint=$hint, useposix=$useposix
+ Compiler:
+ cc='$cc', optimize='$optimize', gccversion=$gccversion
+ cppflags='$cppflags'
+ ccflags ='$ccflags'
+ stdchar='$stdchar', d_stdstdio=$d_stdstdio, usevfork=$usevfork
+ voidflags=$voidflags, castflags=$castflags, d_casti32=$d_casti32, d_castneg=$d_castneg
+ intsize=$intsize, alignbytes=$alignbytes, usemymalloc=$usemymalloc, randbits=$randbits
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+ libs=$libs
+ libc=$libc, so=$so
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+ cccdlflags='$cccdlflags', lddlflags='$lddlflags'
+
+!GROK!THIS!
diff --git a/gnu/usr.bin/perl/plan9/perlplan9.doc b/gnu/usr.bin/perl/plan9/perlplan9.doc
new file mode 100644
index 00000000000..d6d7df8b742
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/perlplan9.doc
@@ -0,0 +1,91 @@
+
+ PLAN9/PERLPLAN9(1) (perl 5.003, patch 05) PLAN9/PERLPLAN9(1)
+
+ NNNNAAAAMMMMEEEE
+ perlplan9 - Plan 9-specific documentation for Perl
+
+ DDDDEEEESSSSCCCCRRRRIIIIPPPPTTTTIIIIOOOONNNN
+ These are a few notes describing features peculiar to Plan 9
+ Perl. As such, it is not intended to be a replacement for
+ the rest of the Perl 5 documentation (which is both copious
+ and excellent). If you have any questions to which you can't
+ find answers in these man pages, contact Luther Huffman at
+ lutherh@stratcom.com and we'll try to answer them.
+
+ IIIInnnnvvvvooookkkkiiiinnnngggg PPPPeeeerrrrllll
+
+ Perl is invoked from the command line as described in the
+ _p_e_r_l manpage. Most perl scripts, however, do have a first
+ line such as "#!/usr/local/bin/perl". This is known as a
+ shebang (shell-bang) statement and tells the OS shell where
+ to find the perl interpreter. In Plan 9 Perl this statement
+ should be "#!/bin/perl" if you wish to be able to directly
+ invoke the script by its name.
+ Alternatively, you may invoke perl with the command
+ "Perl" instead of "perl". This will produce Acme-friendly
+ error messages of the form "filename:18".
+
+ Some scripts, usually identified with a *.PL extension, are
+ self-configuring and are able to correctly create their own
+ shebang path from config information located in Plan 9 Perl.
+ These you won't need to be worried about.
+
+ WWWWhhhhaaaatttt''''ssss iiiinnnn PPPPllllaaaannnn 9999 PPPPeeeerrrrllll
+
+ Although Plan 9 Perl currently only provides static
+ loading, it is built with a number of useful extensions.
+ These include Opcode, FileHandle, Fcntl, and POSIX. Expect
+ to see others (and DynaLoading!) in the future.
+
+ WWWWhhhhaaaatttt''''ssss nnnnooootttt iiiinnnn PPPPllllaaaannnn 9999 PPPPeeeerrrrllll
+
+ As mentioned previously, dynamic loading isn't currently
+ available nor is MakeMaker. Both are high-priority items.
+
+ PPPPeeeerrrrllll5555 FFFFuuuunnnnccccttttiiiioooonnnnssss nnnnooootttt ccccuuuurrrrrrrreeeennnnttttllllyyyy ssssuuuuppppppppoooorrrrtttteeeedddd
+
+ Some, such as chown and umask aren't provided because the
+ concept does not exist within Plan 9. Others, such as some
+ of the socket-related functions, simply haven't been written
+ yet. Many in the latter category may be supported in the
+ future.
+
+ The functions not currently implemented include:
+
+ Page 1 9/Oct/96 (printed 10/9/96)
+
+ PLAN9/PERLPLAN9(1) (perl 5.003, patch 05) PLAN9/PERLPLAN9(1)
+
+ chown, chroot, dbmclose, dbmopen, getsockopt,
+ setsockopt, recvmsg, sendmsg, getnetbyname,
+ getnetbyaddr, getnetent, getprotoent, getservent,
+ sethostent, setnetent, setprotoent, setservent,
+ endservent, endnetent, endprotoent, umask
+
+ There may be several other functions that have undefined
+ behavior so this list shouldn't be considered complete.
+
+ SSSSiiiiggggnnnnaaaallllssss
+
+ For compatibility with perl scripts written for the Unix
+ environment, Plan 9 Perl uses the POSIX signal emulation
+ provided in Plan 9's ANSI POSIX Environment (APE). Signal
+ stacking isn't supported. The signals provided are:
+
+ SIGHUP, SIGINT, SIGQUIT, SIGILL, SIGABRT,
+ SIGFPE, SIGKILL, SIGSEGV, SIGPIPE, SIGPIPE, SIGALRM,
+ SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT,
+ SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU
+
+ BBBBUUUUGGGGSSSS
+ "As many as there are grains of sand on all the beaches of
+ the world . . ." - Carl Sagan
+
+ RRRReeeevvvviiiissssiiiioooonnnn ddddaaaatttteeee
+ This document was revised 09-October-1996 for Perl 5.003_7.
+
+ AAAAUUUUTTTTHHHHOOOORRRR
+ Luther Huffman, lutherh@stratcom.com
+
+ Page 2 9/Oct/96 (printed 10/9/96)
+
diff --git a/gnu/usr.bin/perl/plan9/perlplan9.pod b/gnu/usr.bin/perl/plan9/perlplan9.pod
new file mode 100644
index 00000000000..fb581494401
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/perlplan9.pod
@@ -0,0 +1,87 @@
+=head1 NAME
+
+perlplan9 - Plan 9-specific documentation for Perl
+
+=head1 DESCRIPTION
+
+These are a few notes describing features peculiar to
+Plan 9 Perl. As such, it is not intended to be a replacement
+for the rest of the Perl 5 documentation (which is both
+copious and excellent). If you have any questions to
+which you can't find answers in these man pages, contact
+Luther Huffman at lutherh@stratcom.com and we'll try to
+answer them.
+
+=head2 Invoking Perl
+
+Perl is invoked from the command line as described in
+L<perl>. Most perl scripts, however, do have a first line
+such as "#!/usr/local/bin/perl". This is known as a shebang
+(shell-bang) statement and tells the OS shell where to find
+the perl interpreter. In Plan 9 Perl this statement should be
+"#!/bin/perl" if you wish to be able to directly invoke the
+script by its name.
+ Alternatively, you may invoke perl with the command "Perl"
+instead of "perl". This will produce Acme-friendly error
+messages of the form "filename:18".
+
+Some scripts, usually identified with a *.PL extension, are
+self-configuring and are able to correctly create their own
+shebang path from config information located in Plan 9
+Perl. These you won't need to be worried about.
+
+=head2 What's in Plan 9 Perl
+
+Although Plan 9 Perl currently only provides static
+loading, it is built with a number of useful extensions.
+These include Opcode, FileHandle, Fcntl, and POSIX. Expect
+to see others (and DynaLoading!) in the future.
+
+=head2 What's not in Plan 9 Perl
+
+As mentioned previously, dynamic loading isn't currently
+available nor is MakeMaker. Both are high-priority items.
+
+=head2 Perl5 Functions not currently supported
+
+Some, such as C<chown> and C<umask> aren't provided
+because the concept does not exist within Plan 9. Others,
+such as some of the socket-related functions, simply
+haven't been written yet. Many in the latter category
+may be supported in the future.
+
+The functions not currently implemented include:
+
+ chown, chroot, dbmclose, dbmopen, getsockopt,
+ setsockopt, recvmsg, sendmsg, getnetbyname,
+ getnetbyaddr, getnetent, getprotoent, getservent,
+ sethostent, setnetent, setprotoent, setservent,
+ endservent, endnetent, endprotoent, umask
+
+There may be several other functions that have undefined
+behavior so this list shouldn't be considered complete.
+
+=head2 Signals
+
+For compatibility with perl scripts written for the Unix
+environment, Plan 9 Perl uses the POSIX signal emulation
+provided in Plan 9's ANSI POSIX Environment (APE). Signal stacking
+isn't supported. The signals provided are:
+
+ SIGHUP, SIGINT, SIGQUIT, SIGILL, SIGABRT,
+ SIGFPE, SIGKILL, SIGSEGV, SIGPIPE, SIGPIPE, SIGALRM,
+ SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT,
+ SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU
+
+=head1 BUGS
+
+"As many as there are grains of sand on all the beaches of the
+world . . ." - Carl Sagan
+
+=head1 Revision date
+
+This document was revised 09-October-1996 for Perl 5.003_7.
+
+=head1 AUTHOR
+
+Luther Huffman, lutherh@stratcom.com
diff --git a/gnu/usr.bin/perl/plan9/plan9.c b/gnu/usr.bin/perl/plan9/plan9.c
new file mode 100644
index 00000000000..ebdac27dcb5
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/plan9.c
@@ -0,0 +1,134 @@
+#include "EXTERN.h"
+#include "perl.h"
+
+/* Functions mentioned in <sys/socket.h> but not implemented */
+
+int getsockopt(int a, int b, int c, void *d, int *e)
+{
+ croak("Function \"getsockopt\" not implemented in this version of perl.");
+ return (int)NULL;
+}
+
+int setsockopt(int a, int b, int c, void *d, int *e)
+{
+ croak("Function \"setsockopt\" not implemented in this version of perl.");
+ return (int)NULL;
+}
+
+
+int recvmsg(int a, struct msghdr *b, int c)
+{
+ croak("Function \"recvmsg\" not implemented in this version of perl.");
+ return (int)NULL;
+}
+
+int sendmsg(int a, struct msghdr *b, int c)
+{
+ croak("Function \"sendmsg\" not implemented in this version of perl.");
+ return (int)NULL;
+}
+
+
+/* Functions mentioned in <netdb.h> but not implemented */
+struct netent *getnetbyname(const char *a)
+{
+ croak("Function \"getnetbyname\" not implemented in this version of perl.");
+ return (struct netent *)NULL;
+}
+
+struct netent *getnetbyaddr(long a, int b)
+{
+ croak("Function \"getnetbyaddr\" not implemented in this version of perl.");
+ return (struct netent *)NULL;
+}
+
+struct netent *getnetent()
+{
+ croak("Function \"getnetent\" not implemented in this version of perl.");
+ return (struct netent *)NULL;
+}
+
+struct protoent *getprotobyname(const char *a)
+{
+ croak("Function \"getprotobyname\" not implemented in this version of perl.");
+ return (struct protoent *)NULL;
+}
+
+struct protoent *getprotobynumber(int a)
+{
+ croak("Function \"getprotobynumber\" not implemented in this version of perl.");
+ return (struct protoent *)NULL;
+}
+
+struct protoent *getprotoent()
+{
+ croak("Function \"getprotoent\" not implemented in this version of perl.");
+ return (struct protoent *)NULL;
+}
+
+struct servent *getservbyport(int a, const char *b)
+{
+ croak("Function \"getservbyport\" not implemented in this version of perl.");
+ return (struct servent *)NULL;
+}
+
+struct servent *getservent()
+{
+ croak("Function \"getservent\" not implemented in this version of perl.");
+ return (struct servent *)NULL;
+}
+
+void sethostent(int a)
+{
+ croak("Function \"sethostent\" not implemented in this version of perl.");
+}
+
+void setnetent(int a)
+{
+ croak("Function \"setnetent\" not implemented in this version of perl.");
+}
+
+void setprotoent(int a)
+{
+ croak("Function \"setprotoent\" not implemented in this version of perl.");
+}
+
+void setservent(int a)
+{
+ croak("Function \"setservent\" not implemented in this version of perl.");
+}
+
+void endnetent()
+{
+ croak("Function \"endnetent\" not implemented in this version of perl.");
+}
+
+void endprotoent()
+{
+ croak("Function \"endprotoent\" not implemented in this version of perl.");
+}
+
+void endservent()
+{
+ croak("Function \"endservent\" not implemented in this version of perl.");
+}
+
+int tcdrain(int)
+{
+croak("Function \"tcdrain\" not implemented in this version of perl.");
+}
+
+int tcflow(int, int)
+{
+croak("Function \"tcflow\" not implemented in this version of perl.");
+}
+
+int tcflush(int, int)
+{
+croak("Function \"tcflush\" not implemented in this version of perl.");
+}
+
+int tcsendbreak(int, int)
+{
+croak("Function \"tcsendbreak\" not implemented in this version of perl.");
+}
diff --git a/gnu/usr.bin/perl/plan9/plan9ish.h b/gnu/usr.bin/perl/plan9/plan9ish.h
new file mode 100644
index 00000000000..3a5ad5eb1a3
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/plan9ish.h
@@ -0,0 +1,126 @@
+#ifndef __PLAN9ISH_H__
+#define __PLAN9ISH_H__
+
+/*
+ * 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(),
+ * getgrgid(), and getgrent() routines are available to
+ * get group entries.
+ */
+/*#define HAS_GROUP /**/
+
+/* HAS_PASSWD
+ * This symbol, if defined, indicates that the getpwnam(),
+ * getpwuid(), and getpwent() routines are available to
+ * get password entries.
+ */
+/*#define HAS_PASSWD /**/
+
+#define HAS_KILL
+#define HAS_WAIT
+
+/* 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 /**/
+
+/* PLAN9:
+ * This symbol, if defined, indicates that the program is running under
+ * Plan 9.
+ */
+#ifndef PLAN9
+#define PLAN9 /**/
+#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
+
+/* USE_STAT_RDEV:
+* This symbol is defined if this system has a stat structure declaring
+* st_rdev
+*/
+#undef 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.
+ */
+#define 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 "#!" / **/
+
+#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);
+
+#define BIT_BUCKET "/dev/null"
+#define PERL_SYS_INIT(c,v)
+#define dXSUB_SYS
+#define PERL_SYS_TERM()
+
+/*
+ * 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))
+
+/* getenv related stuff */
+#define my_getenv(var) getenv(var)
+/* Plan 9 prefers getenv("home") to getenv("HOME")
+#define HOME home
+
+/* For use by POSIX.xs */
+extern int tcsendbreak(int, int);
+
+#endif /* __PLAN9ISH_H__ */
diff --git a/gnu/usr.bin/perl/plan9/setup.rc b/gnu/usr.bin/perl/plan9/setup.rc
new file mode 100644
index 00000000000..dd96c1f9c7d
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/setup.rc
@@ -0,0 +1,51 @@
+#!/bin/rc
+# This is an rc shell script which unpacks the perl distribution, builds
+# directories, and puts files where they belong.
+# To use, just run it from within the plan9 subdirectory with the appropriate
+# permissions.
+# Last modified 6/30/96 by:
+# Luther Huffman, Strategic Computer Solutions, Inc., lutherh@stratcom.com
+
+awk -f versnum ../patchlevel.h
+. buildinfo
+builddir = `{ cd .. ; pwd }
+if (~ $#* 0) platforms = $objtype
+if not switch($1) {
+ case -a ; platforms = (386 mips sparc 68020)
+ case * ; echo 'Usage: setup.rc [-a]' >[1=2] ; exit
+}
+sourcedir=/sys/src/cmd/perl/$p9pvers
+privlib=/sys/lib/perl
+sitelib=$privlib/site_perl
+
+#Build source directory
+if (test ! -d /sys/src/cmd/perl) mkdir /sys/src/cmd/perl
+if (test ! -d $sourcedir) mkdir $sourcedir
+
+#Populate source directory
+echo Building source directories ...
+{cd $builddir ; tar c .} | { cd $sourcedir ; tar x}
+cp $builddir/plan9/plan9.c $builddir/plan9/plan9ish.h $builddir/plan9/mkfile $sourcedir
+cd $sourcedir/lib ; rm -rf *
+
+#Build library directories
+echo Building library directories ...
+if (test ! -d $privlib) mkdir $privlib
+if (test ! -d $privlib/auto) mkdir $privlib/auto
+if (test ! -d $sitelib) mkdir $sitelib
+for(i in $platforms){
+ archlib=/$i/lib/perl/$p9pvers
+ sitearch=$archlib/site_perl
+ corelib=$archlib/CORE
+ arpalib=$corelib/arpa
+ if (test ! -d /$i/lib/perl) mkdir /$i/lib/perl
+ if (test ! -d $archlib) mkdir $archlib
+ if (test ! -d $sitearch) mkdir $sitearch
+ if (test ! -d $corelib) mkdir $corelib
+ if (test ! -d $arpalib) mkdir $arpalib
+ cp $builddir/*.h $builddir/plan9/*.h $corelib
+ cp $builddir/plan9/arpa/*.h $arpalib
+}
+
+#Populate library directories
+{cd $builddir/lib ; tar c . } | {cd $privlib ; tar x }
diff --git a/gnu/usr.bin/perl/plan9/versnum b/gnu/usr.bin/perl/plan9/versnum
new file mode 100644
index 00000000000..83e46826c34
--- /dev/null
+++ b/gnu/usr.bin/perl/plan9/versnum
@@ -0,0 +1,8 @@
+/PATCHLEVEL/ {base = $3}
+/SUBVERSION/ {subvers = $3}
+END {
+if (subvers == 0)
+ printf "p9pvers = 5.%03d\n", base> "buildinfo";
+else
+ printf "p9pvers = 5.%03d_%02d\n" , base, subvers> "buildinfo";
+}
diff --git a/gnu/usr.bin/perl/pod/Makefile b/gnu/usr.bin/perl/pod/Makefile
index bfe6c8edada..7eeabd943b0 100644
--- a/gnu/usr.bin/perl/pod/Makefile
+++ b/gnu/usr.bin/perl/pod/Makefile
@@ -1,154 +1,219 @@
-CONVERTERS = pod2html pod2latex pod2man pod2text
+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
+
PERL = ../miniperl
-POD = \
+POD = \
perl.pod \
- perlbook.pod \
- perlbot.pod \
- perlcall.pod \
+ perldelta.pod \
perldata.pod \
- perldebug.pod \
- perldiag.pod \
- perldsc.pod \
- perlembed.pod \
- perlform.pod \
- perlfunc.pod \
- perlguts.pod \
- perlipc.pod \
- perllol.pod \
- perlmod.pod \
- perlobj.pod \
+ perlsyn.pod \
perlop.pod \
- perlovl.pod \
- perlpod.pod \
perlre.pod \
- perlref.pod \
perlrun.pod \
- perlsec.pod \
- perlstyle.pod \
+ perlfunc.pod \
+ perlvar.pod \
perlsub.pod \
- perlsyn.pod \
+ perlmod.pod \
+ perlmodlib.pod \
+ perlform.pod \
+ perllocale.pod \
+ perlref.pod \
+ perldsc.pod \
+ perllol.pod \
+ perltoot.pod \
+ perlobj.pod \
perltie.pod \
- perltoc.pod \
+ perlbot.pod \
+ perlipc.pod \
+ perldebug.pod \
+ perldiag.pod \
+ perlsec.pod \
perltrap.pod \
- perlvar.pod \
+ perlstyle.pod \
+ perlpod.pod \
+ perlbook.pod \
+ perlembed.pod \
+ perlapio.pod \
perlxs.pod \
- perlxstut.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 = \
+MAN = \
perl.man \
- perlbook.man \
- perlbot.man \
- perlcall.man \
+ perldelta.man \
perldata.man \
- perldebug.man \
- perldiag.man \
- perldsc.man \
- perlembed.man \
- perlform.man \
- perlfunc.man \
- perlguts.man \
- perlipc.man \
- perllol.man \
- perlmod.man \
- perlobj.man \
+ perlsyn.man \
perlop.man \
- perlovl.man \
- perlpod.man \
perlre.man \
- perlref.man \
perlrun.man \
- perlsec.man \
- perlstyle.man \
+ perlfunc.man \
+ perlvar.man \
perlsub.man \
- perlsyn.man \
+ perlmod.man \
+ perlmodlib.man \
+ perlform.man \
+ perllocale.man \
+ perlref.man \
+ perldsc.man \
+ perllol.man \
+ perltoot.man \
+ perlobj.man \
perltie.man \
- perltoc.man \
+ perlbot.man \
+ perlipc.man \
+ perldebug.man \
+ perldiag.man \
+ perlsec.man \
perltrap.man \
- perlvar.man \
+ perlstyle.man \
+ perlpod.man \
+ perlbook.man \
+ perlembed.man \
+ perlapio.man \
perlxs.man \
- perlxstut.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 = \
+HTML = \
perl.html \
- perlbook.html \
- perlbot.html \
- perlcall.html \
+ perldelta.html \
perldata.html \
- perldebug.html \
- perldiag.html \
- perldsc.html \
- perlembed.html \
- perlform.html \
- perlfunc.html \
- perlguts.html \
- perlipc.html \
- perllol.html \
- perlmod.html \
- perlobj.html \
+ perlsyn.html \
perlop.html \
- perlovl.html \
- perlpod.html \
perlre.html \
- perlref.html \
perlrun.html \
- perlsec.html \
- perlstyle.html \
+ perlfunc.html \
+ perlvar.html \
perlsub.html \
- perlsyn.html \
+ perlmod.html \
+ perlmodlib.html \
+ perlform.html \
+ perllocale.html \
+ perlref.html \
+ perldsc.html \
+ perllol.html \
+ perltoot.html \
+ perlobj.html \
perltie.html \
- perltoc.html \
+ perlbot.html \
+ perlipc.html \
+ perldebug.html \
+ perldiag.html \
+ perlsec.html \
perltrap.html \
- perlvar.html \
+ perlstyle.html \
+ perlpod.html \
+ perlbook.html \
+ perlembed.html \
+ perlapio.html \
perlxs.html \
- perlxstut.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 = \
+TEX = \
perl.tex \
- perlbook.tex \
- perlbot.tex \
- perlcall.tex \
+ perldelta.tex \
perldata.tex \
- perldebug.tex \
- perldiag.tex \
- perldsc.tex \
- perlembed.tex \
- perlform.tex \
- perlfunc.tex \
- perlguts.tex \
- perlipc.tex \
- perllol.tex \
- perlmod.tex \
- perlobj.tex \
+ perlsyn.tex \
perlop.tex \
- perlovl.tex \
- perlpod.tex \
perlre.tex \
- perlref.tex \
perlrun.tex \
- perlsec.tex \
- perlstyle.tex \
+ perlfunc.tex \
+ perlvar.tex \
perlsub.tex \
- perlsyn.tex \
+ perlmod.tex \
+ perlmodlib.tex \
+ perlform.tex \
+ perllocale.tex \
+ perlref.tex \
+ perldsc.tex \
+ perllol.tex \
+ perltoot.tex \
+ perlobj.tex \
perltie.tex \
- perltoc.tex \
+ perlbot.tex \
+ perlipc.tex \
+ perldebug.tex \
+ perldiag.tex \
+ perlsec.tex \
perltrap.tex \
- perlvar.tex \
+ perlstyle.tex \
+ perlpod.tex \
+ perlbook.tex \
+ perlembed.tex \
+ perlapio.tex \
perlxs.tex \
- perlxstut.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)
+man: pod2man $(MAN)
-# pod2html normally runs on all the pods at once in order to build up
-# cross-references.
-html: pod2html
- $(PERL) -I../lib pod2html $(POD)
+html: pod2html $(HTML)
tex: pod2latex $(TEX)
-.SUFFIXES: .pm .pod .man
+toc:
+ $(PERL) -I../lib buildtoc >perltoc.pod
+
+.SUFFIXES: .pm .pod
+
+.SUFFIXES: .man
.pm.man: pod2man
$(PERL) -I../lib pod2man $*.pm >$*.man
@@ -156,30 +221,36 @@ tex: pod2latex $(TEX)
.pod.man: pod2man
$(PERL) -I../lib pod2man $*.pod >$*.man
-.SUFFIXES: .mp .pod .html
+.SUFFIXES: .html
.pm.html: pod2html
- $(PERL) -I../lib pod2html $*.pod
+ $(PERL) -I../lib $(POD2HTML) --infile=$*.pm --outfile=$*.html
.pod.html: pod2html
- $(PERL) -I../lib pod2html $*.pod
+ $(PERL) -I../lib $(POD2HTML) --infile=$*.pod --outfile=$*.html
-.SUFFIXES: .pm .pod .tex
-
-.pod.tex: pod2latex
- $(PERL) -I../lib pod2latex $*.pod
+.SUFFIXES: .tex
.pm.tex: pod2latex
+ $(PERL) -I../lib pod2latex $*.pm
+
+.pod.tex: pod2latex
$(PERL) -I../lib pod2latex $*.pod
clean:
rm -f $(MAN) $(HTML) $(TEX)
+ rm -f pod2html-*cache
+ rm -f *.aux *.log
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
@@ -192,3 +263,8 @@ pod2man: pod2man.PL ../lib/Config.pm
pod2text: pod2text.PL ../lib/Config.pm
$(PERL) -I ../lib pod2text.PL
+
+checkpods: checkpods.PL ../lib/Config.pm
+ $(PERL) -I ../lib checkpods.PL
+
+
diff --git a/gnu/usr.bin/perl/pod/buildtoc b/gnu/usr.bin/perl/pod/buildtoc
index 9ca5e920fdf..d657d68c848 100644
--- a/gnu/usr.bin/perl/pod/buildtoc
+++ b/gnu/usr.bin/perl/pod/buildtoc
@@ -1,19 +1,25 @@
use File::Find;
use Cwd;
+use Text::Wrap;
-@pods = qw{
- perl perldata perlsyn perlop perlre perlrun perlfunc perlvar
- perlsub perlmod perlref perldsc perllol perlobj perltie
- perlbot perldebug perldiag perlform perlipc perlsec perltrap
- perlstyle perlxs perlxstut perlguts perlcall perlembed perlpod
- perlbook
- };
-for (@pods) { s/$/.pod/ }
+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 perlform perllocale perlref perldsc
+ perllol perltoot perlobj perltie perlbot perlipc perldebug
+ perldiag perlsec perltrap perlstyle perlpod perlbook
+ perlembed perlapio perlxs perlxstut perlguts perlcall
+ );
+
+for (@pods) { s/$/.pod/ }
$/ = '';
@ARGV = @pods;
-($_= <<EOPOD2B) =~ s/^\t//gm && print;
+($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
=head1 NAME
@@ -21,38 +27,40 @@ $/ = '';
=head1 DESCRIPTION
- This page provides a brief table of contents for the rest of the Perl
- documentation set. It is meant to be be quickly scanned or grepped
+ 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)$/) {
- my $tmp;
+ if (/\.p(od|m)$/) {
# Skip .pm files that have corresponding .pod files, and Functions.pm.
- return if (($tmp = $_) =~ s/\.pm$/.pod/ && -f $tmp);
- return if ($_ eq '../lib/Pod/Functions.pm');####Used only by pod itself
-
+ 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 {
+ }
+ else {
my $line;
while ($line = <F>) {
if ($line =~ /^=head1\s+NAME\b/) {
push @modpods, $file;
#warn "GOOD $file\n";
return;
- }
- }
+ }
+ }
warn "EVIL $file\n";
}
}
@@ -69,14 +77,14 @@ for (@modpods) {
if ($done{$name}++) {
# warn "already did $_\n";
next;
- }
+ }
push @modules, $_;
push @modname, $name;
- }
-}
+ }
+}
+
+($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
-($_= <<EOPOD2B) =~ s/^\t//gm && print;
-
=head1 PRAGMA DOCUMENTATION
@@ -85,8 +93,8 @@ EOPOD2B
podset(sort @pragmata);
-($_= <<EOPOD2B) =~ s/^\t//gm && print;
-
+($_= <<EOPOD2B) =~ s/^\t//gm && output($_);
+
=head1 MODULE DOCUMENTATION
@@ -96,41 +104,41 @@ 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 program's docs, but they
- don't all have man pages yet:
+ 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 pod2man
=item wrapsuid
=head1 AUTHOR
- Larry Wall E<lt>F<lwall\@sems.com>E<gt>, with the help of oodles
+ Larry Wall <F<larry\@wall.org>>, with the help of oodles
of other folks.
EOPOD2B
-print;
-
+output $_;
+output "\n"; # flush $LINE
exit;
sub podset {
@@ -139,69 +147,94 @@ sub podset {
while(<>) {
if (s/^=head1 (NAME)\s*/=head2 /) {
$pod = path2modname($ARGV);
- sub path2modname {
- local $_ = shift;
- s/\.p(m|od)$//;
- s-.*?/(lib|ext)/--;
- s-/-::-g;
- s/(\w+)::\1/$1/;
- return $_;
- }
- unitem(); unhead2();
- print "\n \n\n=head2 ";
+ unitem();
+ unhead2();
+ output "\n \n\n=head2 ";
$_ = <>;
if ( /^\s*$pod\b/ ) {
- print;
+ s/$pod\.pm/$pod/; # '.pm' in NAME !?
+ output $_;
} else {
s/^/$pod, /;
- print;
- }
+ output $_;
+ }
next;
}
if (s/^=head1 (.*)/=item $1/) {
unitem(); unhead2();
- print; nl(); next;
- }
+ output $_; nl(); next;
+ }
if (s/^=head2 (.*)/=item $1/) {
unitem();
- print "=over\n\n" unless $inhead2;
+ output "=over\n\n" unless $inhead2;
$inhead2 = 1;
- print; nl(); next;
+ 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 'perlmod' && /^ftp:/;
+ next if $pod eq 'perlmodlib' && /^ftp:/;
##print "=over\n\n" unless $initem;
- print ", " if $initem;
+ output ", " if $initem;
$initem = 1;
s/\.$//;
- print; next;
- }
- }
+ 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) {
- print "\n\n=back\n\n";
- }
- $inhead2 = 0;
- $initem = 0;
-}
+ output "\n\n=back\n\n";
+ }
+ $inhead2 = 0;
+ $initem = 0;
+}
sub unitem {
if ($initem) {
- print "\n\n";
+ output "\n\n";
##print "\n\n=back\n\n";
- }
+ }
$initem = 0;
-}
+}
sub nl {
- print "\n";
-}
+ 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/gnu/usr.bin/perl/pod/checkpods.PL b/gnu/usr.bin/perl/pod/checkpods.PL
new file mode 100644
index 00000000000..ccd78ec9cf0
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/checkpods.PL
@@ -0,0 +1,75 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+
+# 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.
+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.
+$exit = $last_blank = 0;
+while (<>) {
+ chop;
+ if (/^(=\S+)/ && $last_blank) {
+ printf "%s: line %5d, Non-empty line preceeding directive %s\n",
+ $ARGV, $., $1;
+ $exit = 1;
+ }
+ $last_blank = /^\s+$/;
+ if (eof) {
+ close(ARGV);
+ $last_blank = 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 ':';
diff --git a/gnu/usr.bin/perl/pod/perl.pod b/gnu/usr.bin/perl/pod/perl.pod
index 150bb7d842e..e989ebaacf4 100644
--- a/gnu/usr.bin/perl/pod/perl.pod
+++ b/gnu/usr.bin/perl/pod/perl.pod
@@ -19,7 +19,9 @@ For ease of access, the Perl manual has been split up into a number
of sections:
perl Perl overview (this section)
- perltoc Perl documentation table of contents
+ perldelta Perl changes since previous version
+ perlfaq Perl frequently asked questions
+
perldata Perl data structures
perlsyn Perl syntax
perlop Perl operators and precedence
@@ -28,42 +30,61 @@ of sections:
perlfunc Perl builtin functions
perlvar Perl predefined variables
perlsub Perl subroutines
- perlmod Perl modules
- perlref Perl references
+ perlmod Perl modules: how they work
+ perlmodlib Perl modules: how to write and use
+ 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
- perlform Perl formats
- perlipc Perl interprocess communication
perlsec Perl security
perltrap Perl traps for the unwary
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
+ perlguts Perl internal functions for those doing extensions
perlcall Perl calling conventions from C
- perlembed Perl how to embed perl in your C or C++ app
- perlpod Perl plain old documentation
- perlbook Perl book information
(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.)
-Additional documentation for Perl modules is available in the
-F</usr/local/man/> directory. Some of this is distributed standard with
-Perl, but you'll also find third-party modules there. You should be able
-to view this with your man(1) program by including the proper directories
-in the appropriate start-up files. To find out where these are, type:
+By default, all of the above manpages are installed in the
+F</usr/local/man/> directory.
- perl -le 'use Config; print "@Config{man1dir,man3dir}"'
+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.
-If the directories were F</usr/local/man/man1> and F</usr/local/man/man3>,
-you would only need to add F</usr/local/man> to your MANPATH. If
-they are different, you'll have to add both stems.
+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
@@ -75,33 +96,35 @@ will often point out exactly where the trouble is.
=head1 DESCRIPTION
-Perl is an interpreted language optimized for scanning arbitrary
+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
+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 hash tables used by 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 associative
-arrays. 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.
+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...
@@ -131,7 +154,8 @@ will continue to work unchanged.
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".
+to better privacy for "programming in the large". Anonymous
+subroutines exhibit deep binding of lexical variables (closures).
=item * Arbitrarily nested data structures
@@ -159,7 +183,7 @@ 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.
+supported, and Perl itself can be made into a dynamic library.
=item * POSIX compliant
@@ -184,80 +208,49 @@ 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 just for autoloading.
+semantics for undefined subroutine calls. It's not for just autoloading.
=item * Regular expression enhancements
-You can now specify non-greedy quantifiers. You can now do grouping
+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.
-=back
-
-Ok, that's I<definitely> enough hype.
+=item * Innumerable Unbundled Modules
-=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
+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.
-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
+=item * Compilability
- use lib "/my/directory";
-
-=item PERL5DB
-
-The command used to get the debugger code. If unset, uses
-
- BEGIN { require 'perl5db.pl' }
-
-=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.
+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
-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:
+Okay, that's I<definitely> enough hype.
+
+=head1 ENVIRONMENT
- $ENV{'PATH'} = '/bin:/usr/bin'; # or whatever you need
- $ENV{'SHELL'} = '/bin/sh' if defined $ENV{'SHELL'};
- $ENV{'IFS'} = '' if defined $ENV{'IFS'};
+See L<perlrun>.
=head1 AUTHOR
-Larry Wall E<lt>F<lwall@sems.com>E<gt>, with the help of oodles of other folks.
+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 5 libraries
+ "@INC" locations of perl libraries
=head1 SEE ALSO
@@ -287,8 +280,8 @@ switch?
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 sprintf(). The latter
-can even trigger a coredump when passed ludicrous input values.
+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()
@@ -296,14 +289,13 @@ 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 identifier may not be longer than 255 characters, and no
+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.
-See the perl bugs database at F< http://perl.com/perl/bugs/ >. You may
-mail your bug reports (be sure to include full configuration information
-as output by the myconfig program in the perl source tree) to
-F<perlbug@perl.com>.
+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.
diff --git a/gnu/usr.bin/perl/pod/perlapio.pod b/gnu/usr.bin/perl/pod/perlapio.pod
new file mode 100644
index 00000000000..c963d232f6c
--- /dev/null
+++ b/gnu/usr.bin/perl/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>, I<perlio.h> will the 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 *. Unlike 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 is 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"
+is 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/gnu/usr.bin/perl/pod/perlbook.pod b/gnu/usr.bin/perl/pod/perlbook.pod
index 5bb4bfb0b52..9a725cb8330 100644
--- a/gnu/usr.bin/perl/pod/perlbook.pod
+++ b/gnu/usr.bin/perl/pod/perlbook.pod
@@ -5,18 +5,29 @@ perlbook - Perl book information
=head1 DESCRIPTION
You can order 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. I<Programming Perl> is a
-reference work that covers nearly all of Perl (version 4, alas), while
-I<Learning Perl> is a tutorial that covers the most frequently used subset
-of the language.
-
- Programming Perl (the Camel Book):
- ISBN 0-937175-64-1 (English)
- ISBN 4-89052-384-7 (Japanese)
-
- Learning Perl (the Llama Book):
- ISBN 1-56592-042-2 (English)
- ISBN 4-89502-678-1 (Japanese)
- ISBN 2-84177-005-2 (French)
- ISBN 3-930673-08-8 (German)
+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.
+
+I<Programming Perl, Second Edition> is a reference work that covers
+nearly all of Perl, while I<Learning Perl, Second Edition> is a
+tutorial that covers the most frequently used subset of the language.
+You might also check out the very handy, inexpensive, and compact
+I<Perl 5 Desktop Reference>, especially when the thought of lugging
+the 676-page Camel around doesn't make much sense. I<Mastering
+Regular Expressions>, by Jeffrey Friedl, is a reference work that
+covers the art and implementation of regular expressions in various
+languages including Perl.
+
+ Programming Perl, Second Edition (the Camel Book):
+ ISBN 1-56592-149-6 (English)
+
+ Learning Perl, Second Edition (the Llama Book):
+ ISBN 1-56592-284-0 (English)
+
+ Perl 5 Desktop Reference (the reference card):
+ ISBN 1-56592-187-9 (brief English)
+
+ Mastering Regular Expressions (the Hip Owl Book):
+ ISBN 1-56592-257-3 (English)
diff --git a/gnu/usr.bin/perl/pod/perlbot.pod b/gnu/usr.bin/perl/pod/perlbot.pod
index 0fd545fe88f..bc4e4da1f77 100644
--- a/gnu/usr.bin/perl/pod/perlbot.pod
+++ b/gnu/usr.bin/perl/pod/perlbot.pod
@@ -57,7 +57,7 @@ See L<CLASS CONTEXT AND THE OBJECT>.
=item 7
-IO syntax is certainly less noisy, but it is also prone to ambiguities which
+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.
@@ -265,7 +265,7 @@ This example demonstrates an interface for the SDBM class. This creates a
$ref->FETCH(@_);
}
sub STORE {
- my $self = shift;
+ my $self = shift;
if (defined $_[0]){
my $ref = $self->{'dbm'};
$ref->STORE(@_);
@@ -277,11 +277,11 @@ This example demonstrates an interface for the SDBM class. This creates a
package main;
use Fcntl qw( O_RDWR O_CREAT );
- tie %foo, Mydbm, "Sdbm", O_RDWR|O_CREAT, 0640;
+ 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;
+ tie %bar, "Mydbm", "Sdbm2", O_RDWR|O_CREAT, 0640;
$bar{'Cathy'} = 456;
print "bar-Cathy = $bar{'Cathy'}\n";
@@ -404,7 +404,7 @@ 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 to just let the object tell the
+and will lead to hackery. It is better just to let the object tell the
method where that data is located.
package Bar;
@@ -420,7 +420,7 @@ method where that data is located.
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.
@@ -522,6 +522,6 @@ behavior by adding custom FETCH() and STORE() methods, if this is desired.
package main;
use Fcntl qw( O_RDWR O_CREAT );
- tie %foo, Mydbm, "adbm", O_RDWR|O_CREAT, 0640;
+ tie %foo, "Mydbm", "adbm", O_RDWR|O_CREAT, 0640;
$foo{'bar'} = 123;
print "foo-bar = $foo{'bar'}\n";
diff --git a/gnu/usr.bin/perl/pod/perlcall.pod b/gnu/usr.bin/perl/pod/perlcall.pod
index 996c9145d08..f90e09f2384 100644
--- a/gnu/usr.bin/perl/pod/perlcall.pod
+++ b/gnu/usr.bin/perl/pod/perlcall.pod
@@ -5,7 +5,7 @@ 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>.
+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
@@ -29,8 +29,8 @@ called instead.
The classic example of where callbacks are used is when writing an
event driven program like for an X windows application. In this case
-your register functions to be called whenever specific events occur,
-e.g. a mouse button is pressed, the cursor moves into a window or a
+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
@@ -61,7 +61,7 @@ subroutines. They are
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 actually invoke the Perl subroutine.
+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
@@ -84,9 +84,9 @@ use of I<perl_call_sv>.
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, 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">.
+package name in the string, e.g., C<"pkg::fred">.
=item B<perl_call_method>
@@ -126,31 +126,55 @@ 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
+This flag has 2 effects:
=over 5
=item 1.
-it indicates to the subroutine being called that it is executing in a
+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.
+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 may
+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.
@@ -164,34 +188,34 @@ 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 behaviour.
+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
+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
+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
+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 may
+The value returned by the I<perl_call_*> function indicates how many
items have been returned by the Perl subroutine.
-If 0, the you have specified the G_DISCARD flag.
+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
@@ -208,10 +232,10 @@ 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
+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
-explicitly dispose of these temporaries and the section I<Using Perl 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.
@@ -251,10 +275,10 @@ What has happened is that C<fred> accesses the C<@_> array which
belongs to C<joe>.
-=head2 G_EVAL
+=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
+abnormally, e.g., by calling I<die> explicitly or by not actually
existing. By default, when either of these of events occurs, the
process will terminate immediately. If though, you want to trap this
type of event, specify the G_EVAL flag. It will put an I<eval { }>
@@ -265,7 +289,7 @@ 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
+occurred. Here are all the different cases that can occur:
=over 5
@@ -293,7 +317,7 @@ from the stack.
=back
-See I<Using G_EVAL> for details of using G_EVAL.
+See I<Using G_EVAL> for details on using G_EVAL.
=head2 G_KEEPERR
@@ -326,14 +350,17 @@ 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
+=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> macro. This will return C<G_SCALAR>
-if you have been called in a scalar context and C<G_ARRAY> if in an
-array context. An example of using the C<GIMME> macro is shown in
-section I<Using GIMME>.
+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
@@ -368,7 +395,7 @@ For example, say you want to call this Perl sub
sub fred
{
eval { die "Fatal Error" ; }
- print "Trapped error: $@\n"
+ print "Trapped error: $@\n"
if $@ ;
}
@@ -388,8 +415,8 @@ When C<Call_fred> is executed it will print
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
-later), or use the G_EVAL flag with I<perl_call_*> as shown below
+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()
@@ -408,7 +435,7 @@ 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. Hopefully this should make the code less vulnerable
+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
@@ -458,7 +485,7 @@ 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 actually
+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>.
@@ -529,15 +556,15 @@ 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
-explicitly use the C<dSP> macro - it will be declared for you
+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 automatically count the number of parameters you
-are pushing. Then whenever Perl is creating the C<@_> array for the
+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
@@ -555,7 +582,7 @@ local copy, I<not> the global copy.
=item 4.
-The only flag specified this time is G_DISCARD. Since we are passing 2
+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.
@@ -565,7 +592,7 @@ 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 the section L<perlguts/"XSUB'S and the Argument Stack"> for details
+See L<perlguts/"XSUBs and the Argument Stack"> for details
on how the XPUSH macros work.
=item 6.
@@ -580,7 +607,7 @@ function.
Now for an example of dealing with the items returned from a Perl
subroutine.
-Here is a Perl subroutine, I<Adder>, which takes 2 integer parameters
+Here is a Perl subroutine, I<Adder>, that takes 2 integer parameters
and simply returns their sum.
sub Adder
@@ -589,7 +616,7 @@ and simply returns their sum.
$a + $b ;
}
-Since we are now concerned with the return value from I<Adder>, the C
+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
@@ -626,7 +653,7 @@ Points to note this time are
=over 5
-=item 1.
+=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
@@ -654,7 +681,7 @@ 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, plus it will also dump the mortal SV's we have
+the Perl subroutine, 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.
@@ -668,11 +695,11 @@ an alternative to using these macros.
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 re-allocated whilst in the
+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 your local copy using SPAGAIN whenever you make use
+always refresh the local copy using SPAGAIN whenever you make use
of the I<perl_call_*> functions or any other Perl internal function.
=item 4.
@@ -685,7 +712,7 @@ 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 ever happen.
+I<really> don't want to happen ever.
=item 5.
@@ -834,7 +861,7 @@ then the output will be
Value 1 = 3
In this case the main point to note is that only the last item in the
-list returned from the subroutine, I<Adder> actually made it back to
+list is returned from the subroutine, I<AddSubtract> actually made it back to
I<call_AddSubScalar>.
@@ -977,7 +1004,7 @@ I<Subtract>.
=item 2.
-The code
+The code
if (SvTRUE(GvSV(errgv)))
{
@@ -998,7 +1025,7 @@ refers to the C equivalent of C<$@>.
Note that the stack is popped using C<POPs> in the block where
C<SvTRUE(GvSV(errgv))> 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>. Since we want the
+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>.
@@ -1012,7 +1039,7 @@ version of the call_Subtract example above inside a destructor:
package Foo;
sub new { bless {}, $_[0] }
- sub Subtract {
+ sub Subtract {
my($a,$b) = @_;
die "death can be fatal" if $a < $b ;
$a - $b;
@@ -1026,7 +1053,7 @@ version of the call_Subtract example above inside a destructor:
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 since
+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.
@@ -1063,8 +1090,8 @@ Here is a snippet of XSUB which defines I<CallSubPV>.
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 only as a string. For Perl 4 this was adequate,
+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.
@@ -1079,7 +1106,7 @@ I<perl_call_sv> instead of I<perl_call_pv>.
PUSHMARK(sp) ;
perl_call_sv(name, G_DISCARD|G_NOARGS) ;
-Since we are using an SV to call I<fred> the following can all be used
+Because we are using an SV to call I<fred> the following can all be used
CallSubSV("fred") ;
CallSubSV(\&fred) ;
@@ -1092,7 +1119,7 @@ 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 to just store a copy of the
+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 ;
@@ -1121,29 +1148,29 @@ particularly true for these cases
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.
+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
+Similarly, with this code
$ref = \&fred ;
SaveSub1($ref) ;
$ref = 47 ;
CallSavedSub1() ;
-you can expect one of these messages (which you actually get is dependant on
-the version of Perl you are using)
+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>. Since we
+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
@@ -1159,7 +1186,7 @@ A similar but more subtle problem is illustrated with this code
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
+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
@@ -1185,7 +1212,7 @@ SV. The code below shows C<SaveSub2> modified to do that
PUSHMARK(sp) ;
perl_call_sv(keepSub, G_DISCARD|G_NOARGS) ;
-In order to avoid creating a new SV every time C<SaveSub2> is called,
+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
@@ -1247,9 +1274,9 @@ Consider the following Perl code
}
}
-It just implements a very simple class to manage an array. Apart from
+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>, simply prints out the class
+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.
@@ -1260,7 +1287,7 @@ single element of the array. Here is an all Perl example of using it.
will print
1: green
- This is Class Mine version 1.0
+ This is Class Mine version 1.0
Calling a Perl method from C is fairly straightforward. The following
things are required
@@ -1320,33 +1347,38 @@ 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
+=head2 Using GIMME_V
-Here is a trivial XSUB which prints the context in which it is
+Here is a trivial XSUB which prints the context in which it is
currently executing.
void
PrintContext()
CODE:
- if (GIMME == G_SCALAR)
+ 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
+(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
@@ -1418,30 +1450,30 @@ will be more like this
perl --> XSUB --> event handler
...
- event handler --> perl_call --> perl
+ event handler --> perl_call --> perl
|
- event handler <-- perl_call --<--+
+ event handler <-- perl_call <----+
...
- event handler --> perl_call --> perl
+ event handler --> perl_call --> perl
|
- event handler <-- perl_call --<--+
+ event handler <-- perl_call <----+
...
- event handler --> perl_call --> perl
+ event handler --> perl_call --> perl
|
- event handler <-- perl_call --<--+
+ event handler <-- perl_call <----+
In this case the flow of control can consist of only the repeated
sequence
event handler --> perl_call --> perl
-for the 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.
+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 actually dispose of your temporaries, control must drop back to the
+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
@@ -1450,7 +1482,7 @@ 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 explicitly dispose of
+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.
@@ -1524,7 +1556,7 @@ registers, C<pcb1>, might look like this
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 1 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
@@ -1553,7 +1585,7 @@ This may expect the C I<ProcessRead> function of this form
int fh ;
char * buffer ;
{
- ...
+ ...
}
To provide a Perl interface to this library we need to be able to map
@@ -1646,7 +1678,7 @@ the C<buffer> parameter like this
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 pre-define a
+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
@@ -1761,7 +1793,7 @@ series of C functions to act as the interface to Perl, thus
asynch_close(fh) ;
-In this case the functions C<fn1>, C<fn2> and C<fn3> are used to
+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.
@@ -1774,7 +1806,7 @@ 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
-re-compiling. None the less, as long as the number of functions is
+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.
@@ -1878,18 +1910,37 @@ sets the stack up so that we can use the C<ST> macro.
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)>
+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, L<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);
+
+L<perlguts/perl_eval_pv> is used to compile the anonymous subroutine, which
+will be the return value as well. 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 <pmarquess@bfsec.bt.co.uk>
+Paul Marquess <F<pmarquess@bfsec.bt.co.uk>>
Special thanks to the following people who assisted in the creation of
the document.
@@ -1899,4 +1950,4 @@ and Larry Wall.
=head1 DATE
-Version 1.2, 16th Jan 1996
+Version 1.3, 14th Apr 1997
diff --git a/gnu/usr.bin/perl/pod/perldata.pod b/gnu/usr.bin/perl/pod/perldata.pod
index 4b6e4335153..dc2975a7d44 100644
--- a/gnu/usr.bin/perl/pod/perldata.pod
+++ b/gnu/usr.bin/perl/pod/perldata.pod
@@ -11,6 +11,28 @@ 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
+which 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 which 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 which 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:
@@ -43,14 +65,14 @@ 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.
-Since variable and array references always start with '$', '@', or '%',
+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
+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.
@@ -58,9 +80,9 @@ 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 only contain more digits. Names
+Names that start with a digit may contain only more digits. Names
which 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
+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.)
@@ -81,14 +103,14 @@ list context to each of its arguments. For example, if you say
int( <STDIN> )
-the integer operation provides a scalar context for the <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 <STDIN>, which
+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
@@ -113,7 +135,7 @@ 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
+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.
@@ -122,13 +144,13 @@ 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 same thing for nearly all purposes, references are strongly-typed
-uncastable pointers with built-in reference-counting and destructor
+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.
+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
@@ -138,14 +160,14 @@ 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 non-zero number, it's usually
+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 the do in I<awk>:
+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
@@ -154,27 +176,27 @@ for details on regular expressions.
warn "has nondigits" if /\D/;
warn "not a whole number" unless /^\d+$/;
- warn "not an integer" unless /^[+-]?\d+$/
- warn "not a decimal number" unless /^[+-]?\d+\.?\d*$/
- warn "not a C float"
+ warn "not an integer" unless /^[+-]?\d+$/
+ warn "not a decimal number" unless /^[+-]?\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, since
+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 make to make sure destructors were
+in Perl 4, but we had to break this to make sure destructors were
called when expected.) You can also gain some measure of efficiency by
-preextending an array that is going to get big. (You can also extend
+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;
+ $#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
@@ -182,10 +204,10 @@ last value, like the C comma operator.) The following is always true:
scalar(@whatever) == $#whatever - $[ + 1;
-Version 5 of Perl changed the semantics of $[: files that don't set
-the value of $[ no longer need to worry about whether another
-file changed its value. (In other words, use of $[ is deprecated.)
-So in general you can just assume that
+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;
@@ -198,7 +220,7 @@ If you evaluate a hash in a scalar context, it returns a value which 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 only useful to find out whether Perl's
+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
@@ -217,27 +239,33 @@ integer formats:
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/qq> for a list.
+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
+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,
-identifiers beginning with $ or @, followed by an optional bracketed
+names beginning with $ or @, followed by an optional bracketed
expression as a subscript.) The following code segment prints out "The
-price is $100."
+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 identifier to
+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,
@@ -253,19 +281,25 @@ 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, since single quote is a valid (though deprecated) character in
-an identifier (see L<perlmod/Packages>).
-
-Two special literals are __LINE__ and __FILE__, which represent the
-current line number and filename at that point in your program. They
-may only be used as separate tokens; they will not be interpolated into
-strings. In addition, the token __END__ 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 the DATA filehandle. (The DATA
-filehandle may read data only from the main script, but not from any
-required file or evaluated string.) The two control characters ^D and
-^Z are synonyms for __END__ (or __DATA__ in a module; see L<SelfLoader> for
-details on __DATA__).
+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 a 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
@@ -279,12 +313,12 @@ say
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
+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 ($LIST_SEPARATOR in English), space by default. The following
+variable (C<$LIST_SEPARATOR> in English), space by default. The following
are equivalent:
$temp = join($",@ARGV);
@@ -302,19 +336,20 @@ 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 blank line.) The terminating string must appear by itself
-(unquoted and with no surrounding whitespace) on the terminating line.
-
- print <<EOF;
+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
@@ -337,11 +372,11 @@ first blank line.) The terminating string must appear by itself
Here's a line
or two.
THIS
- and here another.
+ 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
+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
@@ -369,12 +404,12 @@ assigns the entire list value to array foo, but
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 to $foo the value 3:
+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 an
+You may have an optional comma before the closing parenthesis of a
list literal, so that you can say:
@foo = (
@@ -402,13 +437,13 @@ 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. Examples:
+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 PARENS
+ $time = stat($file)[8]; # OOPS, FORGOT PARENTHESES
# Find a hex digit.
$hexdigit = ('a','b','c','d','e','f')[$digit-10];
@@ -416,6 +451,11 @@ put the list in parentheses to avoid ambiguity. Examples:
# 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:
@@ -430,7 +470,7 @@ produced by the expression on the right side of the assignment:
$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, since most list functions return a null list when finished,
+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:
@@ -457,8 +497,9 @@ 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 quotes its left-hand operand, which makes
-it nice for initializing hashes:
+synonym for a comma, but it also arranges for its left-hand operand to be
+interpreted as a string, if it's a bareword which would be a legal identifier.
+This makes it nice for initializing hashes:
%map = (
red => 0x00f,
@@ -476,7 +517,7 @@ or for initializing hash references to be used as records:
or for using call-by-named-parameter to complicated functions:
- $field = $query->radio_group(
+ $field = $query->radio_group(
name => 'group_name',
values => ['eenie','meenie','minie'],
default => 'meenie',
@@ -488,17 +529,19 @@ 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
+=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
+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.
+we have real references, this is seldom needed. It also used to be the
+preferred way to pass filehandles into a function, but now
+that we have the *foo{THING} notation it isn't often needed for that,
+either. It is still needed to pass new filehandles into functions
+(*HANDLE{IO} only works if HANDLE has already been used).
-One place where you still use typeglobs (or references thereto)
-is for passing or storing filehandles. If you want to save away
-a filehandle, do it this way:
+If you need to use a typeglob to save away a filehandle, do it this way:
$fh = *STDOUT;
@@ -506,16 +549,18 @@ or perhaps as a real reference, like this:
$fh = \*STDOUT;
-This is also the way to create a local filehandle. For example:
+This is also a way to create a local filehandle. For example:
sub newopen {
my $path = shift;
local *FH; # not my!
open (FH, $path) || return undef;
- return \*FH;
+ return *FH;
}
$fh = newopen('/etc/passwd');
-See L<perlref>, L<perlsub>, and L<perlmod/"Symbols Tables"> for more
-discussion on typeglobs. See L<perlfunc/open> for other ways of
-generating filehandles.
+Another way to create local filehandles is with IO::Handle and its ilk,
+see the bottom of L<perlfunc/open()>.
+
+See L<perlref>, L<perlsub>, and L<perlmod/"Symbol Tables"> for more
+discussion on typeglobs.
diff --git a/gnu/usr.bin/perl/pod/perldebug.pod b/gnu/usr.bin/perl/pod/perldebug.pod
index 17fe25926fe..a02fd5c7103 100644
--- a/gnu/usr.bin/perl/pod/perldebug.pod
+++ b/gnu/usr.bin/perl/pod/perldebug.pod
@@ -6,178 +6,533 @@ perldebug - Perl debugging
First of all, have you tried using the B<-w> switch?
-=head2 Debugging
-
-If you invoke Perl with a B<-d> switch, your script will be run under the
-debugger. However, the Perl debugger is not a separate program as it is
-in a C environment. Instead, the B<-d> flag tells the compiler to insert
-source information into the pseudocode it's about to hand to the
-interpreter. (That means your code must compile correctly for the
-debugger to work on it.) Then when the interpreter starts up, it
-pre-loads a Perl library file containing the debugger itself. The program
-will halt before the first executable statement (but see below) and ask
-you for one of the following commands:
+=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
+=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 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
-Stack trace.
-If you do bizarre things to your @_ arguments in a subroutine, the stack
-backtrace will not always show the original values.
+Produce a stack backtrace. See below for details on its output.
-=item s
+=item s [expr]
Single step. Executes until it reaches the beginning of another
-statement.
+statement, descending into subroutine calls. If an expression is
+supplied that includes function calls, it too will be single-stepped.
-=item n
+=item n [expr]
Next. Executes over subroutine calls, until it reaches the beginning
-of the next statement.
-
-=item f
+of the next statement. If an expression is supplied that includes
+function calls, those functions will be executed with stops before
+each statement.
-Finish. Executes statements until it has finished the current
-subroutine.
+=item E<lt>CRE<gt>
-=item c
+Repeat last C<n> or C<s> command.
-Continue. Executes until the next breakpoint is reached.
+=item c [line|sub]
-=item c line
+Continue, optionally inserting a one-time-only breakpoint
+at the specified line or subroutine.
-Continue to the specified line. Inserts a one-time-only breakpoint at
-the specified line.
-
-=item <CR>
+=item l
-Repeat last n or s.
+List next window of lines.
=item l min+incr
-List incr+1 lines starting at min. If min is omitted, starts where
-last listing left off. If incr is omitted, previous value of incr is
-used.
+List C<incr+1> lines starting at C<min>.
=item l min-max
-List lines in the indicated range.
+List lines C<min> through C<max>. C<l -> is synonymous to C<->.
=item l line
-List just the indicated line.
+List a single line.
-=item l
+=item l subname
-List next window.
+List first window of lines from subroutine.
=item -
-List previous window.
+List previous window of lines.
-=item w line
+=item w [line]
-List window (a few lines worth of code) around line.
+List window (a few lines) around the current line.
-=item l subname
+=item .
+
+Return debugger pointer to the last-executed line and
+print it out.
-List subroutine. If it's a long subroutine it just lists the
-beginning. Use "l" to list more.
+=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/
-Regular expression search forward in the source code for pattern; the
-final / is optional.
+Search forwards for pattern; final / is optional.
=item ?pattern?
-Regular expression search backward in the source code for pattern; the
-final ? is optional.
+Search backwards for pattern; final ? is optional.
=item L
-List lines that have breakpoints or actions.
+List all breakpoints and actions.
-=item S
+=item S [[!]pattern]
-Lists the names of all subroutines.
+List subroutine names [not] matching pattern.
=item t
-Toggle trace mode on or off.
+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 }
-=item b line [ condition ]
+ 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 is
+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 only be set on lines
-that begin an executable statement. Conditions don't use C<if>:
+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 ]
+=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.
-Set breakpoint at first executable line of subroutine.
+=item b compile subname
-=item d line
+Sets breakpoint at the first statement executed after the subroutine
+is compiled.
-Delete breakpoint. If line is omitted, deletes the breakpoint on the
-line that is about to be executed.
+=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 breakpoints.
+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
-=item a line command
+For example, this will print out C<$foo> every time line
+53 is passed:
-Set an action for line. A multiline command may be entered by
-backslashing the newlines. This command is Perl code, not another
-debugger command.
+ a 53 print "DB FOUND $foo\n"
=item A
-Delete all line actions.
+Delete all installed actions.
-=item < command
+=item O [opt[=val]] [opt"val"] [opt?]...
-Set an action to happen before every debugger prompt. A multiline
-command may be entered by backslashing the newlines.
+Set or query values of options. val defaults to 1. opt can
+be abbreviated. Several options can be listed.
-=item > command
+=over 12
-Set an action to happen after the prompt when you've just given a
-command to return to executing the script. A multiline command may be
-entered by backslashing the newlines.
+=item C<recallCommand>, C<ShellBang>
-=item V package [symbols]
+The characters used to recall command or spawn shell. By
+default, these are both set to C<!>.
-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 $) there, just the symbol
-names, like this:
+=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<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
- V DB filename line
+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).
-=item X [symbols]
+Other examples may include
-Same as as "V" command, but within the current package.
+ $ 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 debugging command. If number is omitted, redoes the previous
-command.
+Redo a previous command (default previous command).
=item ! -number
-Redo the command that was that many commands ago.
+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
@@ -186,51 +541,545 @@ listed. If number is omitted, lists them all.
=item q or ^D
-Quit. ("quit" doesn't work for this.)
+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 p expr
+=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
-Same as C<print DB::OUT expr>. The DB::OUT filehandle is opened to
-/dev/tty, regardless of where STDOUT may be redirected to.
+ 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<L<perlfunc/require>>
+frame and an C<L<perlfunc/eval EXPR>>) 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
-Any command you type in that isn't recognized by the debugger will be
-directly executed (C<eval>'d) as Perl code. Leading white space will
-cause the debugger to think it's C<NOT> a debugger command.
+=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 I<NOT> be stopped by debugger,
-although C<require>s will. From your own code, however, you can transfer
-control back to the debugger using the following statement, which is harmless
-if the debugger is not running:
+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;
-=head2 Customization
+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.
-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 environment variable PERL5DB to say something like this:
+Another way to debug compile-time code is to start debugger, set a
+breakpoint on I<load> of some module thusly
- BEGIN { require "myperl5db.pl" }
+ 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 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 in particular most people seem to expect to
-be there):
+like these (the last one is one people expect to be there):
- $DB::alias{'len'} = 's/^len(.*)/p length($1)/';
+ $DB::alias{'len'} = 's/^len(.*)/p length($1)/';
$DB::alias{'stop'} = 's/^stop (at|in)/b/';
- $DB::alias{'.'} = 's/^\./p '
- . '"\$DB::sub(\$DB::filename:\$DB::line):\t"'
- . ',\$DB::dbline[\$DB::line]/' ;
+ $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<@{"_<$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<%{"_<$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 C<$filename> for C<eval>ed strings looks like
+C<(eval 34)>.
+
+=item *
+
+The scalar C<${"_<$filename"}> contains C<"_<$filename">. Same for
+evaluated strings which contain subroutines, or which are currently
+executed. The C<$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(*{"_<$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 C<%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 an array 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
@@ -238,12 +1087,8 @@ You did try the B<-w> switch, didn't you?
=head1 BUGS
-If your program exit()s or die()s, so does the debugger.
-
-There's no builtin way to restart the debugger without exiting and coming back
-into it. You could use an alias like this:
-
- $DB::alias{'rerun'} = 'exec "perl -d $DB::filename"';
+You cannot get the stack frame information or otherwise debug functions
+that were not compiled by Perl, such as C or C++ extensions.
-But you'd lose any pending breakpoint information, and that might not
-be the right path, etc.
+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.
diff --git a/gnu/usr.bin/perl/pod/perldelta.pod b/gnu/usr.bin/perl/pod/perldelta.pod
new file mode 100644
index 00000000000..7400940dcad
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perldelta.pod
@@ -0,0 +1,1586 @@
+=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 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 L<README.win32> 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 L<README.cygwin32> for
+more details on this port, and how to obtain the Cygwin32 toolkit.
+
+=head2 Plan 9
+
+See L<README.plan9>.
+
+=head2 QNX
+
+See L<README.qnx>.
+
+=head2 AmigaOS
+
+See L<README.amigaos>.
+
+=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 translation (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 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
+exclamation marks 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/gnu/usr.bin/perl/pod/perldiag.pod b/gnu/usr.bin/perl/pod/perldiag.pod
index 38edda19827..166e046f22b 100644
--- a/gnu/usr.bin/perl/pod/perldiag.pod
+++ b/gnu/usr.bin/perl/pod/perldiag.pod
@@ -12,18 +12,18 @@ desperation):
(S) A severe warning (mandatory).
(F) A fatal error (trappable).
(P) An internal error you should never see (trappable).
- (X) A very fatal error (non-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<$^Q> to a reference to a routine that will be
-called on each warning instead of printing it. See L<perlvar>.
+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 message start with a %s!
-The symbols C<"%-?@> sort before the letters, while C<[> and C<\> sort after.
+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
@@ -33,6 +33,14 @@ The symbols C<"%-?@> sort before the letters, while C<[> and C<\> sort after.
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
@@ -45,23 +53,35 @@ no useful value. See L<perlmod>.
=item % may only be used in unpack
-(F) You can't pack a string by supplying a checksum, since the
+(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 parens. See L<perlop/Terms and List Operators (Leftward)>.
+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 delete() or exists() must be a hash element, such as
+(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
@@ -76,11 +96,11 @@ 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.
+=item %s had compilation errors
(F) The final summary message when a C<perl -c> fails.
-=item %s has too many errors.
+=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.
@@ -99,30 +119,36 @@ before it could possibly have been used.
(F) The final summary message when a C<perl -c> succeeds.
-=item %s: Command not found.
+=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.
+of Perl. Check the #! line, or manually feed your script into
+Perl yourself.
-=item %s: Expression syntax.
+=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.
+of Perl. Check the #! line, or manually feed your script into
+Perl yourself.
-=item %s: Undefined variable.
+=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.
+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
+(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,
@@ -133,6 +159,12 @@ which provides a race condition that breaks security.
(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.
@@ -144,7 +176,7 @@ if you meant it literally. See L<perlre>.
=item @ outside of string
-(F) You had a pack template that specified an absolution position outside
+(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
@@ -154,7 +186,20 @@ the return value of your socket() call? See L<perlfunc/accept>.
=item Allocation too large: %lx
-(F) You can't allocate more than 64K on an MSDOS machine.
+(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 translation (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
@@ -164,14 +209,16 @@ the return value of your socket() call? See L<perlfunc/accept>.
(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, paren pair or declaration.
+a missing quote, operator, parenthesis pair or declaration.
=item Args must match #! line
(F) The setuid emulator requires that the arguments Perl was invoked
-with match the arguments specified on the #! line.
+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
+=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
@@ -202,6 +249,13 @@ know which context to supply to the right side.
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()
@@ -223,17 +277,28 @@ 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 sized are, respectively,
-S<sizeof(struct msqid_ds *)>, S<sizeof(struct semid_ds *)> and
+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 associative array
-
-(P) One of the internal hash routines was passed a null HV pointer.
-
=item Bad filehandle: %s
(F) A symbol was passed to something wanting a filehandle, but the symbol
@@ -243,7 +308,17 @@ 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.
+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 name after %s::
@@ -274,17 +349,31 @@ wasn't a symbol table entry.
(P) An internal request asked to add a hash entry to something that
wasn't a symbol table entry.
-=item Badly places ()'s
+=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.
+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 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
@@ -299,30 +388,42 @@ the return value of your socket() call? See L<perlfunc/bind>.
(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. You can usually double the curlies to get the same
-effect though, since the inner curlies will be considered a block
-that loops once. See L<perlfunc/last>.
+"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. You can usually double the curlies to get
-the same effect though, since the inner curlies will be considered a block
-that loops once. See L<perlfunc/last>.
+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. You can usually double the curlies to get
-the same effect though, since the inner curlies will be considered a block
-that loops once. See L<perlfunc/last>.
+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
@@ -331,7 +432,7 @@ encapsulation of objects. See L<perlobj>.
=item Can't break at that line
-(S) A warning intended for while running within the debugger, indicating
+(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.
@@ -343,7 +444,7 @@ in it, let alone methods. See L<perlobj>.
=item Can't call method "%s" on unblessed reference
-(F) A method call must know what package it's supposed to run in. It
+(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>.
@@ -367,7 +468,7 @@ 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
-(type GLOB), can't be forced to stop being what they are. So you can't
+(typeglobs), can't be forced to stop being what they are. So you can't
say things like:
*foo += 1;
@@ -382,12 +483,12 @@ 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
-(type GLOB), can't be forced to stop being what they are.
+(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
-(type GLOB), can't be forced to stop being what they are.
+(typeglobs), can't be forced to stop being what they are.
=item Can't create pipe mailbox
@@ -396,7 +497,7 @@ or other plumbing problems.
=item Can't declare %s in my
-(F) Only scalar, array and hash variables may be declared as lexical variables.
+(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
@@ -405,11 +506,11 @@ They must have ordinary identifiers as names.
=item Can't do inplace edit without backup
-(F) You're on a system such as MSDOS that gets confused if you try reading
-from a deleted (but still opened) file. You have to say B<-i>C<.bak>, or some
+(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 > 14 characters
+=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.
@@ -441,7 +542,7 @@ your sysadmin why he and/or she removed it.
(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 > m
+=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>.
@@ -453,7 +554,7 @@ 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
+(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
@@ -468,8 +569,19 @@ 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.
+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
@@ -479,10 +591,14 @@ 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. Since bracketed quotes count nesting
+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.)
+ 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
@@ -498,7 +614,7 @@ 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, since the device name is overwritten with each call. If this warning
+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
@@ -519,42 +635,53 @@ mailbox buffers to be, and didn't get an answer.
(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 only be calling it out of an AUTOLOAD routine anyway. See
+you should be calling it out of only an AUTOLOAD routine anyway. See
L<perlfunc/goto>.
-=item Can't localize a reference
+=item Can't localize through a reference
-(F) You said something like C<local $$ref>, which is not allowed because
-the compiler can't determine whether $ref will end up pointing to anything
-with a symbol table entry, and a symbol table entry is necessary to
-do a local.
+(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 previous declared as a
+(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 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 environment variable to say where the extra library is,
-or maybe the script needs to add the library name to @INC. Or maybe
+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 it's base classes. See L<perlobj>.
+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 mktemp()
(F) The mktemp() routine failed for some reason while trying to process
@@ -563,46 +690,49 @@ a B<-e> switch. Maybe your /tmp partition is full, or clobbered.
=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 autoincrement.
+change it, such as with an auto-increment.
-=item Can't modify non-existent substring
+=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 readonly var
+=item Can't msgrcv to read-only var
-(F) The target of a msgrcv must be modifiable in order to be used as a receive
+(F) The target of a msgrcv must be modifiable to be used as a receive
buffer.
=item Can't open %s: %s
-(S) An inplace edit couldn't open the original file for the indicated reason.
-Usually this is because you don't have read permission for the file.
+(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
-"open2.pl". Alternately, direct the pipe's output to a file using ">",
+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 '2>' or '2>>' on the command line for
-writing.
+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 '<' on the command line for reading.
+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 '>' or '>>' on the command line for
-writing.
+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)
@@ -613,6 +743,13 @@ couldn't open the pipe into which to send data destined for stdout.
(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
@@ -645,13 +782,16 @@ of suidperl.
=item Can't take log of %g
-(F) Logarithms are only defined on positive real numbers.
+(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 Complex package available for Perl, though,
-if you really want to do that.
+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
@@ -680,7 +820,7 @@ code calling sv_upgrade.
=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,
+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.
@@ -699,10 +839,15 @@ test the type of the reference, if need be.
(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 only valid as part of a regular expression pattern.
+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
@@ -711,17 +856,12 @@ 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 de-lurk some insidious errors.
-
-=item Can't use delimiter brackets within expression
-
-(F) The ${name} construct is for disambiguating identifiers in strings, not
-in ordinary code.
+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 only be tied to one location (namely
+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.
@@ -737,7 +877,7 @@ didn't look like an array reference, or anything else subscriptable.
(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 Can't x= to readonly value
+=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.
@@ -745,9 +885,15 @@ Perhaps you need to copy the value to a temporary, and repeat that.
=item Cannot open temporary file
-(F) The create routine failed for some reaon while trying to process
+(F) The create routine failed for some reason while trying to process
a B<-e> switch. Maybe your /tmp partition is full, or clobbered.
+=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 chmod: mode argument is missing initial 0
(W) A novice will sometimes say
@@ -757,15 +903,37 @@ a B<-e> switch. Maybe your /tmp partition is full, or clobbered.
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 <%s>
+=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 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.
@@ -783,10 +951,16 @@ a valid magic number.
=item Deep recursion on subroutine "%s"
(W) This subroutine has called itself (directly or indirectly) 100
-times than it has returned. This probably indicates an infinite
+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.
@@ -796,6 +970,11 @@ case it indicates something else.
(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
@@ -835,29 +1014,42 @@ The interpreter is immediately exited.
=item Error converting file specification %s
-(F) An error peculiar to VMS. Since Perl may have to deal with file
+(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 Execution of %s aborted due to compilation errors.
+=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
+(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
+(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
+(W) You are exiting a substitution by unconventional means, such as
a return, a goto, or a loop control statement.
=item Fatal VMS error at %s, line %d
@@ -878,19 +1070,21 @@ PDP-11 or something?
You need to do an open() or a socket() call, or call a constructor from
the FileHandle package.
-=item Filehandle %s opened only for input
+=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
-"+<" or "+>" or "+>>" instead of with "<" or nothing. If you only
-intended to write the file, use ">" or ">>". See L<perlfunc/open>.
+"+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 only opened for input
+=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
-"+<" or "+>" or "+>>" instead of with "<" or nothing. If you only
-intended to write the file, use ">" or ">>". See L<perlfunc/open>.
+"+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
@@ -962,8 +1156,8 @@ 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
+(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
@@ -982,11 +1176,40 @@ an emergency basis to prevent a core dump.
(D) Really old Perl let you omit the % on hash names in some spots. This
is now heavily deprecated.
-=item Identifier "%s::%s" used only once: possible typo
+=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.
-(W) Typographical errors often show up as unique identifiers. If you
-had a good reason for having a unique identifier, then just mention it
-again somehow to suppress the message.
+=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
@@ -1007,9 +1230,24 @@ don't take to this kindly.
(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 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.
+(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,
@@ -1020,21 +1258,33 @@ 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 $ENV{PATH} contains a directory that is writable by the world.
+script if C<$ENV{PATH}> contains a directory that is writable by the world.
See L<perlsec>.
=item Insecure PATH
(F) You can't use system(), exec(), or a piped open in a setuid or
-setgid script if $ENV{PATH} is derived from data supplied (or
+setgid script if C<$ENV{PATH}> is 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>, in order to determine
-whether the current call to C<exec> should be affect the current
+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
@@ -1044,6 +1294,17 @@ and execute the specified command.
(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.
@@ -1053,6 +1314,23 @@ and execute the specified command.
(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
@@ -1085,20 +1363,10 @@ L<perlfunc/last>.
(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 Literal @%s now requires backslash
-
-(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 putting 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 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 somehow point to a valid method. See L<perlovl>.
+doesn't resolve to a valid subroutine. See L<overload>.
=item Might be a runaway multi-line %s string starting on line %d
@@ -1112,8 +1380,8 @@ ended earlier on the current line.
=item Missing $ on loop variable
-(F) Apparently you've been programming in csh too much. Variables are always
-mentioned with the $ in Perl, unlike in the shells, where it can vary from
+(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
@@ -1132,16 +1400,10 @@ found where operator expected". Often the missing operator is a comma.
As a general rule, you'll find it's missing near the place you were last
editing.
-=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 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", since the compiler
+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 }
@@ -1149,13 +1411,13 @@ catches that. But an easy way to do the same thing is:
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
+=item Modification of noncreatable 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"
+=item Modification of noncreatable hash value attempted, subscript "%s"
(F) You tried to make a hash value spring into existence, and it couldn't
be created for some peculiar reason.
@@ -1170,8 +1432,15 @@ be created for some peculiar reason.
=item Multidimensional syntax %s not supported
-(W) Multidimensional arrays aren't written like $foo[1,2,3]. They're written
-like $foo[1][2][3], as in C.
+(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
@@ -1180,10 +1449,10 @@ that is less than 0. This is difficult to imagine.
=item nested *?+ in regexp
-(F) You can't quantify a quantifier without intervening parens. So
+(F) You can't quantify a quantifier without intervening parentheses. So
things like ** or +* or ?* are illegal.
-Note, however, that the minimal matching quantifiers, *?, +? and ?? appear
+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
@@ -1208,10 +1477,22 @@ See L<perlsec>.
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 whither you
+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
@@ -1226,7 +1507,7 @@ right.
=item No dbm on this machine
(P) This is counted as an internal error, because every machine should
-supply dbm nowadays, since Perl comes with SDBM. See L<SDBM_File>.
+supply dbm nowadays, because Perl comes with SDBM. See L<SDBM_File>.
=item No DBsub routine
@@ -1235,29 +1516,29 @@ 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 2> or 2>> on command line
+=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 '2>' or a '2>>' on the command line, but can't find the name of the
-file to which to write data destined for stderr.
+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 < on command line
+=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 '<' on the command line, but can't find the name of the file from
-which to read data for stdin.
+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 > on command line
+=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 '>' at the end of the command line, so it doesn't know whither
-you wanted to redirect stdout.
+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 > or >> on command line
+=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 '>' or a '>>' on the command line, but can't find the name of the
-file to which to write data destined for stdout.
+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
@@ -1304,7 +1585,7 @@ 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 "type glob" (that is,
+(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>.
@@ -1334,10 +1615,10 @@ 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
+=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<perlovl>.
+doesn't somehow point to a valid subroutine. See L<overload>.
=item Not an ARRAY reference
@@ -1356,9 +1637,15 @@ See L<perlform>.
=item Null filename used
-(F) You can't require the null filename, especially since on many machines
+(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.
@@ -1369,16 +1656,30 @@ that means the current directory! See L<perlfunc/require>.
=item NULL regexp argument
-(P) The internal pattern matching routines blew it bigtime.
+(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 list
(S) You specified an odd number of elements to a hash list, which is odd,
-since hash lists come in key/value pairs.
+because hash lists 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
@@ -1388,10 +1689,13 @@ since hash lists come in key/value pairs.
(S) An internal warning that the grammar is screwed up.
-=item Operation `%s' %s: no method found,
+=item Operation `%s': no method found,%s
-(F) An attempt was made to use an entry in an overloading table that
-somehow no longer points to a valid method. See L<perlovl>.
+(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
@@ -1408,9 +1712,22 @@ but realloc() wouldn't give it more memory, virtual or otherwise.
=item Out of memory!
-(X) The malloc() function returned 0, indicating there was insufficient
+(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 page overflow
(W) A single call to write() produced more lines than can fit on a page.
@@ -1450,6 +1767,10 @@ it wasn't an eval context.
(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,
@@ -1470,7 +1791,7 @@ it wasn't a block context.
=item panic: leave_scope clearsv
-(P) A writable lexical variable became readonly somehow within the scope.
+(P) A writable lexical variable became read-only somehow within the scope.
=item panic: leave_scope inconsistency
@@ -1556,7 +1877,7 @@ was string.
(P) The lexer got into a bad state while processing a case modifier.
-=item Parens missing around "%s" list
+=item Pareneses missing around "%s" list
(W) You said something like
@@ -1589,6 +1910,52 @@ perspective, it's probably not what you intended.
(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
+exclamation marks 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.
@@ -1606,9 +1973,10 @@ 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
-parens around the filehandle, or use the new "or" operator instead of "||".
+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
@@ -1622,25 +1990,25 @@ Check your logic flow.
=item Probable precedence problem on %s
-(W) The compiler found a bare word where it expected a conditional,
+(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)
+=item Prototype mismatch: %s vs %s
-(S) The subroutine being defined had a predeclared (forward) declaration
-with a different function prototype.
+(S) The subroutine being declared or defined had previously been declared
+or defined with a different function prototype.
-=item Read on closed filehandle <%s>
+=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 MSDOS machine.
+(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
@@ -1658,6 +2026,11 @@ an unintended loop in your inheritance hierarchy.
(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
@@ -1669,7 +2042,7 @@ expression compiler gave it.
=item regexp too big
-(F) The current implementation of regular expression uses shorts as
+(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
@@ -1690,32 +2063,47 @@ 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 value of
+(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 $foo[&bar] always behaves like a scalar, both when
-assigning to it and when evaluating its argument, while @foo[&bar] behaves
+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 only expecting one subscript.
+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, since
+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 with its setuid
+(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 seek() on unopened file
+=item %sseek() on unopened file
-(W) You tried to use the seek() function on a filehandle that was either
-never opened or has been closed since.
+(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
@@ -1740,10 +2128,14 @@ or possibly some other missing operator, such as a comma.
(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 parens aren't allowed. See L<perlre>.
+parenthesis. Embedded parentheses aren't allowed. See L<perlre>.
=item Sequence (?%s...) not implemented
@@ -1757,34 +2149,44 @@ See L<perlre>.
=item Server error
-Also known as "500 Server error". 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.
+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 $), and your operating system doesn't support
+(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 $>, and your operating system doesn't support
+(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 $(, and your operating system doesn't support
+(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 $<, and your operating system doesn't support
+(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.
@@ -1801,7 +2203,7 @@ because the world might have written on it already.
(W) You tried to do a shutdown on a closed socket. Seems a bit superfluous.
-=item SIG%s handler "%s" not defined.
+=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?
@@ -1828,10 +2230,10 @@ or less than one element. See L<perlfunc/sort>.
more times than there are characters of input, which is what happened.)
See L<perlfunc/split>.
-=item Stat on unopened file <%s>
+=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 been closed since.
+on a filehandle that was either never opened or has since been closed.
=item Statement unlikely to be reached
@@ -1841,6 +2243,12 @@ 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
@@ -1854,26 +2262,30 @@ by itself.
(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 Quotelike Operators">.
+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
-(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>.
+(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...
+=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.
@@ -1893,7 +2305,7 @@ 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, since Perl is good at understanding random input.
+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
@@ -1901,13 +2313,13 @@ 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
+(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 IPC is not implemented on this machine
-(F) You tried to do something with a function beginning with "sem", "shm"
+(F) You tried to do something with a function beginning with "sem", "shm",
or "msg". See L<perlfunc/semctl>, for example.
=item Syswrite on closed filehandle
@@ -1915,20 +2327,25 @@ or "msg". See L<perlfunc/semctl>, for example.
(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 been closed since.
+never opened or has since been closed.
-=item Test on unopened file <%s>
+=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 $[ is now strictly circumscribed, and interpreted as
-a compiler directive. You may only say one of
+(F) Assignment to C<$[> is now strictly circumscribed, and interpreted as
+a compiler directive. You may say only one of
$[ = 0;
$[ = 1;
@@ -1945,11 +2362,11 @@ out from under another module inadvertently. See L<perlvar/$[>.
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.
+=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. Govermnment thinks it's a secret, or at least that 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.
@@ -1969,17 +2386,39 @@ you're not running on Unix.
(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.
+of Perl. Check the #! line, or manually feed your script into
+Perl yourself.
=item Too many args to syscall
-(F) Perl only supports a maximum of 14 args to syscall().
+(F) Perl supports a maximum of only 14 args to syscall().
=item Too many arguments for %s
@@ -1993,7 +2432,8 @@ it. See L<perlre>.
=item Translation pattern not terminated
(F) The lexer couldn't find the interior delimiter of a tr/// or tr[][]
-construct.
+or y/// or y[][] construct. Missing the leading C<$> from variables
+C<$tr> or C<$y> may cause this error.
=item Translation replacement not terminated
@@ -2008,13 +2448,13 @@ 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 @{EXPR}. Hashes must be
-%NAME or %{EXPR}. No implicit dereferencing is allowed--use the
+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, since octal literals
+(W) A umask of 222 is incorrect. It should be 0222, because octal literals
always start with 0 in Perl, as in C.
=item Unable to create sub named "%s"
@@ -2078,13 +2518,13 @@ representative, who probably put it there in the first place.
=item Unknown BYTEORDER
-(F) There are no byteswapping functions for a machine with this byte order.
+(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 paren. See L<perlre>.
+the matching parenthesis. See L<perlre>.
=item Unmatched right bracket
@@ -2101,21 +2541,22 @@ See L<perlre>.
=item Unquoted string "%s" may clash with future reserved word
-(W) You used a bare word that might someday be claimed as a 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 \%03o ignored
+=item Unrecognized character %s
-(S) A garbage character was found in the input, and ignored, in case it's
-a weird control character on an EBCDIC machine, or some such.
+(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
+=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
@@ -2125,12 +2566,20 @@ supplying the bad switch on your behalf.)
(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/chop>.
+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 machines doesn't implement the indicated function, apparently.
@@ -2141,40 +2590,46 @@ At least, Configure doesn't think so.
(F) Your machine doesn't support the Berkeley socket mechanism, or at
least that's what Configure thought.
-=item Unterminated <> operator
+=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 awk feature.
+(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 multiline pattern matching, both for
+(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 only
-from C. This usually means there's a better way to do it in Perl.
-
-=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.
+(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 << to mean <<"" is deprecated
+=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 a blank line as the terminator of the here-document.
+wish to use an empty line as the terminator of the here-document.
=item Use of implicit split to @_ is deprecated
@@ -2182,6 +2637,34 @@ wish to use a blank line as the terminator of the here-document.
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->bar()> or C<$obj->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<C<use AutoLoader 'AUTOLOAD';>.
+
+=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
@@ -2219,7 +2702,20 @@ 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 Variable "%s" is not exported
+=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
@@ -2227,18 +2723,67 @@ 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 syntax.
+=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.
+of Perl. Check the #! line, or manually feed your script into
+Perl yourself.
+
+=item Warning: something's wrong
-=item Warning: unable to close filehandle %s properly.
+(W) You passed warn() an empty string (the equivalent of C<warn "">) or
+you called it with no args and C<$_> was empty.
-(S) The implicit close() done by an open() got an error indication on the
-close(0. This usually indicates your filesystem ran out of disk space.
+=item Warning: unable to close filehandle %s properly
-=item Warning: Use of "%s" without parens is ambiguous
+(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
@@ -2255,7 +2800,7 @@ but in actual fact, you got
rand(+5);
-So put in parens to say what you really mean.
+So put in parentheses to say what you really mean.
=item Write on closed filehandle
@@ -2288,7 +2833,7 @@ Use a filename instead.
=item YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!
-(F) And you probably never will, since you probably don't have the
+(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.
@@ -2309,18 +2854,18 @@ 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 righthand side of a
+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 '<' may not both be specified on command line
+=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
-'<'. Only one STDIN stream to a customer, please.
+'E<lt>'. Only one STDIN stream to a customer, please.
-=item '|' and '>' may not both be specified on command line
+=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
@@ -2335,5 +2880,38 @@ streams, such as
}
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/gnu/usr.bin/perl/pod/perldsc.pod b/gnu/usr.bin/perl/pod/perldsc.pod
index 7e18e7405c2..48750dd5de3 100644
--- a/gnu/usr.bin/perl/pod/perldsc.pod
+++ b/gnu/usr.bin/perl/pod/perldsc.pod
@@ -21,7 +21,7 @@ with three dimensions!
for $x (1 .. 10) {
for $y (1 .. 10) {
for $z (1 .. 10) {
- $LoL[$x][$y][$z] =
+ $LoL[$x][$y][$z] =
$x ** $y + $z;
}
}
@@ -30,25 +30,25 @@ with three dimensions!
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 just say C<print @LoL>? How do
+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?
+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.
+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
-documents on each of the following:
+sections on each of the following:
=over 5
@@ -62,36 +62,32 @@ documents on each of the following:
=item * more elaborate constructs
-=item * recursive and self-referential data structures
-
-=item * objects
-
=back
But for now, let's look at some of the general issues common to all
-of these types of data structures.
+of 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 only hold scalar values (meaning a string,
+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'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.) That means that when you have something that
-looks to you like an access to two-or-more-dimensional array and/or hash,
-that what's really going on is that in all these cases, the base type is
+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
@@ -102,7 +98,7 @@ multidimensional arrays work as well.
$hash{string}[7] # hash of arrays
$hash{string}{'another string'} # hash of hashes
-Now, because the top level only contains references, if you try to print
+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:
@@ -130,7 +126,7 @@ 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
@@ -138,8 +134,8 @@ 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;
- }
+ $counts[$i] = scalar @list;
+ }
Here's the case of taking a reference to the same memory location
again and again:
@@ -147,9 +143,9 @@ again and again:
for $i (1..10) {
@list = somefunc($i);
$LoL[$i] = \@list; # WRONG!
- }
+ }
-So, just what's the big problem with that? It looks right, doesn't it?
+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!
@@ -164,29 +160,29 @@ the following C program:
rp = getpwnam("root");
dp = getpwnam("daemon");
- printf("daemon name is %s\nroot name is %s\n",
+ 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
+ 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
+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.
+you want.
Note that this will produce something similar, but it's
much harder to read:
@@ -194,7 +190,7 @@ 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
@@ -218,9 +214,9 @@ 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 to always use the array or hash constructors with C<[]>
+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.
+efficient.
Surprisingly, the following dangerous-looking construct will
actually work out fine:
@@ -228,7 +224,7 @@ 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
@@ -251,7 +247,7 @@ In summary:
@{ $LoL[$i] } = @list; # way too tricky for most programmers
-=head1 CAVEAT ON PRECEDENCE
+=head1 CAVEAT ON PRECEDENCE
Speaking of things like C<@{$LoL[$i]}>, the following are actually the
same thing:
@@ -290,29 +286,24 @@ this:
my $listref = [
[ "fred", "barney", "pebbles", "bambam", "dino", ],
[ "homer", "bart", "marge", "maggie", ],
- [ "george", "jane", "alroy", "judy", ],
+ [ "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 instead write:
+variable, and it would thereby remind you to write instead:
print $listref->[2][2]
=head1 DEBUGGING
-The standard Perl debugger in 5.001 doesn't do a very nice job of
-printing out complex data structures. However, the perl5db that
-Ilya Zakharevich E<lt>F<ilya@math.ohio-state.edu>E<gt>
-wrote, which is accessible at
-
- ftp://ftp.perl.com/pub/perl/ext/perl5db-kit-0.9.tar.gz
-
-has 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:
+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)
@@ -330,15 +321,15 @@ given the assignment to $LoL above, here's the debugger output:
2 ARRAY(0x13b540)
0 'george'
1 'jane'
- 2 'alroy'
+ 2 'elroy'
3 'judy'
-There's also a lower-case B<x> command which is nearly the same.
+There's also a lowercase B<x> command which is nearly the same.
=head1 CODE EXAMPLES
-Presented with little comment (these will get their own man pages someday)
-here are short code examples illustrating access of various
+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
@@ -356,18 +347,18 @@ types of data structures.
# 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";
@@ -383,28 +374,28 @@ types of data structures.
# 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]} ) {
+ 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" ],
+ flintstones => [ "fred", "barney" ],
+ jetsons => [ "george", "jane", "elroy" ],
+ simpsons => [ "homer", "marge", "bart" ],
);
=head2 Generation of a HASH OF LISTS
@@ -414,7 +405,7 @@ types of data structures.
while ( <> ) {
next unless s/^(.*?):\s*//;
$HoL{$1} = [ split ];
-
+ }
# reading from file; more temps
# flintstones: fred barney wilma dino
@@ -422,18 +413,18 @@ types of data structures.
($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";
@@ -449,24 +440,31 @@ types of data structures.
# 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} ) {
+ 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{$b}} } keys %HoL ) {
+ 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}} } keys %HoL ) {
+ foreach $family ( sort {
+ @{$HoL{$b}} <=> @{$HoL{$a}}
+ ||
+ $a cmp $b
+ } keys %HoL )
+ {
print "$family: ", join(", ", sort @{ $HoL{$family}), "\n";
+ }
=head1 LISTS OF HASHES
@@ -474,8 +472,8 @@ types of data structures.
@LoH = (
{
- Lead => "fred",
- Friend => "barney",
+ Lead => "fred",
+ Friend => "barney",
},
{
Lead => "george",
@@ -500,6 +498,7 @@ types of data structures.
$rec->{$key} = $value;
}
push @LoH, $rec;
+ }
# reading from file
@@ -507,30 +506,30 @@ types of data structures.
# no temp
while ( <> ) {
push @LoH, { split /[\s+=]/ };
-
+ }
# calling a function that returns a key,value list, like
# "lead","fred","daughter","pebbles"
- while ( %fields = getnextpairset() )
+ 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";
+ $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";
+ $LoH[0]{lead} = "fred";
# another element
- $LoH[1]{"lead"} =~ s/(\w)/\u$1/;
+ $LoH[1]{lead} =~ s/(\w)/\u$1/;
# print the whole thing with refs
for $href ( @LoH ) {
@@ -539,7 +538,7 @@ types of data structures.
print "$role=$href->{$role} ";
}
print "}\n";
-
+ }
# print the whole thing with indices
for $i ( 0 .. $#LoH ) {
@@ -548,33 +547,35 @@ types of data structures.
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",
+ flintstones => {
+ lead => "fred",
+ pal => "barney",
},
- "jetsons" => {
- "lead" => "george",
- "wife" => "jane",
- "his boy"=> "elroy",
- }
- "simpsons" => {
- "lead" => "homer",
- "wife" => "marge",
- "kid" => "bart",
- );
+ jetsons => {
+ lead => "george",
+ wife => "jane",
+ "his boy" => "elroy",
+ },
+ simpsons => {
+ lead => "homer",
+ wife => "marge",
+ kid => "bart",
+ },
+ );
=head2 Generation of a HASH OF HASHES
@@ -599,81 +600,78 @@ types of data structures.
($key, $value) = split /=/, $field;
$rec->{$key} = $value;
}
-
-
- # calling a function that returns a key,value list, like
- # "lead","fred","daughter","pebbles"
- while ( %fields = getnextpairset() )
- push @a, { %fields };
-
+ }
# 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";
+ 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";
+ $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 "$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 "$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{$b}} } keys %HoH ) {
- print "$family: ";
- for $role ( sort keys %{ $HoH{$family} } {
+ 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{$b}} } keys %HoH ) {
- print "$family: ";
+ 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} } {
+ for $role ( sort { $rank{$a} <=> $rank{$b} } keys %{ $HoH{$family} } ) {
print "$role=$HoH{$family}{$role} ";
}
print "}\n";
+ }
=head1 MORE ELABORATE RECORDS
@@ -684,48 +682,48 @@ Here's a sample showing how to create and use a record whose fields are of
many different sorts:
$rec = {
- STRING => $string,
- LIST => [ @old_values ],
- LOOKUP => { %some_table },
- FUNC => \&some_function,
- FANON => sub { $_[0] ** $_[1] },
- FH => \*STDOUT,
+ TEXT => $string,
+ SEQUENCE => [ @old_values ],
+ LOOKUP => { %some_table },
+ THATCODE => \&some_function,
+ THISCODE => sub { $_[0] ** $_[1] },
+ HANDLE => \*STDOUT,
};
- print $rec->{STRING};
+ print $rec->{TEXT};
print $rec->{LIST}[0];
- $last = pop @ { $rec->{LIST} };
+ $last = pop @ { $rec->{SEQUENCE} };
print $rec->{LOOKUP}{"key"};
($first_k, $first_v) = each %{ $rec->{LOOKUP} };
- $answer = &{ $rec->{FUNC} }($arg);
- $answer = &{ $rec->{FANON} }($arg1, $arg2);
+ $answer = $rec->{THATCODE}->($arg);
+ $answer = $rec->{THISCODE}->($arg1, $arg2);
# careful of extra block braces on fh ref
- print { $rec->{FH} } "a string\n";
+ print { $rec->{HANDLE} } "a string\n";
use FileHandle;
- $rec->{FH}->autoflush(1);
- $rec->{FH}->print(" a string\n");
+ $rec->{HANDLE}->autoflush(1);
+ $rec->{HANDLE}->print(" a string\n");
=head2 Declaration of a HASH OF COMPLEX RECORDS
%TV = (
- "flintstones" => {
+ flintstones => {
series => "flintstones",
- nights => [ qw(monday thursday friday) ];
+ nights => [ qw(monday thursday friday) ],
members => [
{ name => "fred", role => "lead", age => 36, },
{ name => "wilma", role => "wife", age => 31, },
- { name => "pebbles", role => "kid", age => 4, },
+ { name => "pebbles", role => "kid", age => 4, },
],
},
- "jetsons" => {
+ jetsons => {
series => "jetsons",
- nights => [ qw(wednesday saturday) ];
+ nights => [ qw(wednesday saturday) ],
members => [
{ name => "george", role => "lead", age => 41, },
{ name => "jane", role => "wife", age => 39, },
@@ -733,9 +731,9 @@ many different sorts:
],
},
- "simpsons" => {
+ simpsons => {
series => "simpsons",
- nights => [ qw(monday) ];
+ nights => [ qw(monday) ],
members => [
{ name => "homer", role => "lead", age => 34, },
{ name => "marge", role => "wife", age => 37, },
@@ -749,7 +747,7 @@ many different sorts:
# 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 datastructures if declared as data, so
+ # 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
@@ -759,7 +757,7 @@ many different sorts:
@members = ();
# assume this file in field=value syntax
- while () {
+ while (<>) {
%fields = split /[\s=]+/;
push @members, { %fields };
}
@@ -779,7 +777,7 @@ many different sorts:
foreach $family (keys %TV) {
$rec = $TV{$family}; # temp pointer
@kids = ();
- for $person ( @{$rec->{members}} ) {
+ for $person ( @{ $rec->{members} } ) {
if ($person->{role} =~ /kid|son|daughter/) {
push @kids, $person;
}
@@ -808,7 +806,7 @@ many different sorts:
for $who ( @{ $TV{$family}{members} } ) {
print " $who->{name} ($who->{role}), age $who->{age}\n";
}
- print "it turns out that $TV{$family}{'lead'} has ";
+ 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";
@@ -820,18 +818,17 @@ 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 partially address this need is the MLDBM
-module. Check your nearest CPAN site as described in L<perlmod> for
+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
-L<perlref>, L<perllol>, L<perldata>, L<perlobj>
+perlref(1), perllol(1), perldata(1), perlobj(1)
=head1 AUTHOR
-Tom Christiansen E<lt>F<tchrist@perl.com>E<gt>
-
-Last update:
-Tue Dec 12 09:20:26 MST 1995
+Tom Christiansen <F<tchrist@perl.com>>
+Last update:
+Wed Oct 23 04:57:50 MET DST 1996
diff --git a/gnu/usr.bin/perl/pod/perlembed.pod b/gnu/usr.bin/perl/pod/perlembed.pod
index 2f0e9c30fbf..c43ed556aa7 100644
--- a/gnu/usr.bin/perl/pod/perlembed.pod
+++ b/gnu/usr.bin/perl/pod/perlembed.pod
@@ -10,24 +10,24 @@ Do you want to:
=over 5
-=item B<Use C from Perl?>
+=item B<Use C from Perl?>
Read L<perlcall> and L<perlxs>.
-=item B<Use a UNIX program from Perl?>
+=item B<Use a Unix program from Perl?>
-Read about backquotes and L<perlfunc/system> and L<perlfunc/exec>.
+Read about back-quotes and about C<system> and C<exec> in L<perlfunc>.
-=item B<Use Perl from Perl?>
+=item B<Use Perl from Perl?>
-Read about L<perlfunc/do> and L<perlfunc/eval> and L<perlmod/use>
-and L<perlmod/require>.
+Read about L<perlfunc/do> and L<perlfunc/eval> and L<perlfunc/require>
+and L<perlfunc/use>.
-=item B<Use C from C?>
+=item B<Use C from C?>
Rethink your design.
-=item B<Use Perl from C?>
+=item B<Use Perl from C?>
Read on...
@@ -37,7 +37,7 @@ Read on...
L<Compiling your C program>
-There's one example in each of the five sections:
+There's one example in each of the nine sections:
L<Adding a Perl interpreter to your C program>
@@ -49,12 +49,21 @@ L<Performing Perl pattern matches and substitutions from your C program>
L<Fiddling with the Perl stack from your C program>
-This documentation is UNIX specific.
+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>
=head2 Compiling your C program
-Every C program that uses Perl must link in the I<perl library>.
+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
@@ -63,13 +72,14 @@ 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.)
-Your C program will--usually--allocate, "run", and deallocate a
-I<PerlInterpreter> object, which is defined in the perl library.
+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
-(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 resembling this:
+(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
@@ -83,54 +93,89 @@ or maybe something like
Execute this statement for a hint about where to find CORE:
- perl -e 'use Config; print $Config{archlib}'
+ 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 5.003_05, the incantation
+is a bit different:
-Here's how you might compile the example in the next section,
-L<Adding a Perl interpreter to your C program>,
-on a DEC Alpha running the OSF operating system:
+ % 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
- % cc -o interp interp.c -L/usr/local/lib/perl5/alpha-dec_osf/CORE
- -I/usr/local/lib/perl5/alpha-dec_osf/CORE -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.) and
-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
--L. If it complains that it can't find I<EXTERN.h> or I<perl.h>, you need
-to change the path following the -I.
+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
+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:
- perl -e 'use Config; print $Config{libs}'
+ % 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>,
-from the source distribution. Here's a bastardized, non-portable version of
-I<miniperlmain.c> containing the essentials of embedding:
+from the source distribution. Here's a bastardized, nonportable
+version of I<miniperlmain.c> containing the essentials of embedding:
- #include <stdio.h>
#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, env);
+ 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 -L/usr/local/lib/perl5/alpha-dec_osf/CORE
- -I/usr/local/lib/perl5/alpha-dec_osf/CORE -lperl -lm
+ % 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:
@@ -149,122 +194,117 @@ or
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()>.
+calling I<perl_run()>.
=head2 Calling a Perl subroutine from your C program
-To call individual Perl subroutines, you'll need to remove the call to
-I<perl_run()> and replace it with a call to I<perl_call_argv()>.
+To call individual Perl subroutines, you can use any of the B<perl_call_*>
+functions documented in the L<perlcall> manpage.
+In this example we'll use I<perl_call_argv>.
That's shown below, in a program I'll call I<showtime.c>.
- #include <stdio.h>
#include <EXTERN.h>
- #include <perl.h>
-
- static PerlInterpreter *my_perl;
-
+ #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, env);
-
- /*** This replaces perl_run() ***/
- perl_call_argv("showtime", G_DISCARD | G_NOARGS, argv);
+
+ 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_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 -L/usr/local/lib/perl5/alpha-dec_osf/CORE
- -I/usr/local/lib/perl5/alpha-dec_osf/CORE -lperl -lm
-
+ % 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
+(the beginning of the Unix epoch), and the moment I began writing this
sentence.
-If you want to pass some arguments to the Perl subroutine, or
-you want to access the return value, you'll need to manipulate the
-Perl stack, demonstrated in the last section of this document:
-L<Fiddling with the Perl stack from your C program>
+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.
-=head2 Evaluating a Perl statement from your C program
+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>.
-NOTE: This section, and the next, employ some very brittle techniques
-for evaluting strings of Perl code. Perl 5.002 contains some nifty
-features that enable A Better Way (such as with L<perlguts/perl_eval_sv>).
-Look for updates to this document soon.
+=head2 Evaluating a Perl statement from your C program
-One way to evaluate a Perl string is to define a function (we'll call
-ours I<perl_eval()>) that wraps around Perl's L<perlfunc/eval>.
+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, this is the only routine you'll ever need to execute
-snippets of Perl code from within your C program. Your string can be
-as long as you wish; it can contain multiple statements; it can
-use L<perlmod/require> or L<perlfunc/do> to include external Perl
-files.
+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.
-Our I<perl_eval()> lets us evaluate individual Perl strings, and then
-extract variables for coercion into C types. The following program,
+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 <stdio.h>
#include <EXTERN.h>
#include <perl.h>
static PerlInterpreter *my_perl;
- int perl_eval(char *string)
- {
- char *argv[2];
- argv[0] = string;
- argv[1] = NULL;
- perl_call_argv("_eval_", 0, argv);
- }
-
main (int argc, char **argv, char **env)
{
- char *embedding[] = { "", "-e", "sub _eval_ { eval $_[0] }" };
- STRLEN length;
+ char *embedding[] = { "", "-e", "0" };
- my_perl = perl_alloc();
- perl_construct( my_perl );
+ my_perl = perl_alloc();
+ perl_construct( my_perl );
- perl_parse(my_perl, NULL, 3, embedding, env);
+ perl_parse(my_perl, NULL, 3, embedding, NULL);
+ perl_run(my_perl);
- /** Treat $a as an integer **/
- perl_eval("$a = 3; $a **= 2");
- printf("a = %d\n", SvIV(perl_get_sv("a", FALSE)));
+ /** 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("$a = 3.14; $a **= 2");
- printf("a = %f\n", SvNV(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("$a = 'rekcaH lreP rehtonA tsuJ'; $a = reverse($a); ");
- printf("a = %s\n", SvPV(perl_get_sv("a", FALSE), length));
+ /** 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), na));
- perl_destruct(my_perl);
- perl_free(my_perl);
+ 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>.
@@ -277,188 +317,208 @@ I<SvPV()> to create a string:
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 L<perl_eval_pv> instead. Example:
+
+ ...
+ SV *val = perl_eval_pv("reverse 'rekcaH lreP rehtonA tsuJ'", TRUE);
+ printf("%s\n", SvPV(val,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
-Our I<perl_eval()> lets us evaluate strings of Perl code, so we can
+The I<perl_eval_sv()> function lets us evaluate chunks 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()>.
- char match(char *string, char *pattern);
+ char match(SV *string, char *pattern);
-Given a string and a pattern (e.g. "m/clasp/" or "/\b\w*\b/", which in
-your program might be represented as C<"/\\b\\w*\\b/">),
+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(char *string[], char *pattern);
-
-Given a pointer to a string and an "=~" operation (e.g. "s/bob/robert/g" or
-"tr[A-Z][a-z]"), modifies the string according to the operation,
-returning the number of substitutions made.
-
- int matches(char *string, char *pattern, char **matches[]);
-
-Given a string, a pattern, and a pointer to an empty array of strings,
-evaluates C<$string =~ $pattern> in an array context, and fills in
-I<matches> with the array elements (allocating memory as it does so),
-returning the number of matches found.
-
-Here's a sample program, I<match.c>, that uses all three:
-
- #include <stdio.h>
- #include <EXTERN.h>
- #include <perl.h>
-
- static PerlInterpreter *my_perl;
-
- int eval(char *string)
- {
- char *argv[2];
- argv[0] = string;
- argv[1] = NULL;
- perl_call_argv("_eval_", 0, argv);
- }
-
- /** match(string, pattern)
- **
- ** Used for matches in a scalar context.
- **
- ** Returns 1 if the match was successful; 0 otherwise.
- **/
- char match(char *string, char *pattern)
- {
- char *command;
- command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 37);
- sprintf(command, "$string = '%s'; $return = $string =~ %s",
- string, pattern);
- perl_eval(command);
- free(command);
- return SvIV(perl_get_sv("return", FALSE));
- }
-
- /** 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.
- **/
- int substitute(char *string[], char *pattern)
- {
- char *command;
- STRLEN length;
- command = malloc(sizeof(char) * strlen(*string) + strlen(pattern) + 35);
- sprintf(command, "$string = '%s'; $ret = ($string =~ %s)",
- *string, pattern);
- perl_eval(command);
- free(command);
- *string = SvPV(perl_get_sv("string", FALSE), length);
- return SvIV(perl_get_sv("ret", FALSE));
- }
-
- /** matches(string, pattern, matches)
- **
- ** Used for matches in an array context.
- **
- ** Returns the number of matches,
- ** and fills in **matches with the matching substrings (allocates memory!)
- **/
- int matches(char *string, char *pattern, char **matches[])
- {
- char *command;
- SV *current_match;
- AV *array;
+ 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(GvSV(errgv)))
+ croak(SvPVx(GvSV(errgv), 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(0), *retval;
+
+ sv_setpvf(command, "my $string = '%s'; $string =~ %s",
+ SvPV(string,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(0), *retval;
+
+ sv_setpvf(command, "$string = '%s'; ($string =~ %s)",
+ SvPV(*string,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(0);
I32 num_matches;
- STRLEN length;
- int i;
-
- command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 38);
- sprintf(command, "$string = '%s'; @array = ($string =~ %s)",
- string, pattern);
- perl_eval(command);
- free(command);
- array = perl_get_av("array", FALSE);
- num_matches = av_len(array) + 1; /** assume $[ is 0 **/
- *matches = (char **) malloc(sizeof(char *) * num_matches);
- for (i = 0; i <= num_matches; i++) {
- current_match = av_shift(array);
- (*matches)[i] = SvPV(current_match, length);
- }
+
+ sv_setpvf(command, "my $string = '%s'; @array = ($string =~ %s)",
+ SvPV(string,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)
- {
- char *embedding[] = { "", "-e", "sub _eval_ { eval $_[0] }" };
- char *text, **matches;
- int num_matches, i;
- int j;
-
- my_perl = perl_alloc();
- perl_construct( my_perl );
-
- perl_parse(my_perl, NULL, 3, embedding, env);
-
- text = (char *) malloc(sizeof(char) * 486); /** A long string follows! **/
- sprintf(text, "%s", "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 (perl_match(text, "m/quarter/")) /** Does text contain 'quarter'? **/
- printf("perl_match: Text contains the word 'quarter'.\n\n");
- else
- printf("perl_match: Text doesn't contain the word 'quarter'.\n\n");
-
- if (perl_match(text, "m/eighth/")) /** Does text contain 'eighth'? **/
- printf("perl_match: Text contains the word 'eighth'.\n\n");
- else
- printf("perl_match: Text doesn't contain the word 'eighth'.\n\n");
-
- /** Match all occurrences of /wi../ **/
- num_matches = perl_matches(text, "m/(wi..)/g", &matches);
-
- printf("perl_matches: m/(wi..)/g found %d matches...\n", num_matches);
- for (i = 0; i < num_matches; i++)
- printf("match: %s\n", matches[i]);
+ }
+
+ 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(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),na));
printf("\n");
- for (i = 0; i < num_matches; i++) {
- free(matches[i]);
- }
- free(matches);
-
- /** Remove all vowels from text **/
- num_matches = perl_substitute(&text, "s/[aeiou]//gi");
+
+ /** Remove all vowels from text **/
+ num_matches = substitute(&text, "s/[aeiou]//gi");
if (num_matches) {
- printf("perl_substitute: s/[aeiou]//gi...%d substitutions made.\n",
- num_matches);
- printf("Now text is: %s\n\n", text);
+ printf("substitute: s/[aeiou]//gi...%d substitutions made.\n",
+ num_matches);
+ printf("Now text is: %s\n\n", SvPV(text,na));
}
-
- /** Attempt a substitution
- if (!perl_substitute(&text, "s/Perl/C/")) {
- printf("perl_substitute: s/Perl/C...No substitution made.\n\n");
+
+ /** Attempt a substitution **/
+ if (!substitute(&text, "s/Perl/C/")) {
+ printf("substitute: s/Perl/C...No substitution made.\n\n");
}
-
- free(text);
-
+
+ SvREFCNT_dec(text);
+ perl_destruct_level = 1;
perl_destruct(my_perl);
perl_free(my_perl);
- }
+ }
-which produces the output
+which produces the output (again, long lines have been wrapped here)
- perl_match: Text contains the word 'quarter'.
-
- perl_match: Text doesn't contain the word 'eighth'.
-
- perl_matches: m/(wi..)/g found 2 matches...
+ 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
-
- perl_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
-
- perl_substitute: s/Perl/C...No substitution made.
-
+
+ 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
@@ -467,7 +527,7 @@ 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>.
@@ -475,11 +535,11 @@ 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.
+Once you've understood those, embedding Perl in C is easy.
-Since C has no built-in function for integer exponentiation, let's
+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, since Perl implements ** with C's I<pow()> function). First
+sounds, because Perl implements ** with C's I<pow()> function). First
I'll create a stub exponentiation function in I<power.pl>:
sub expo {
@@ -492,12 +552,11 @@ 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 <stdio.h>
#include <EXTERN.h>
#include <perl.h>
-
+
static PerlInterpreter *my_perl;
-
+
static void
PerlPower(int a, int b)
{
@@ -512,54 +571,460 @@ deep breath...
SPAGAIN; /* refresh stack pointer */
/* pop the return value from stack */
printf ("%d to the %dth power is %d.\n", a, b, POPi);
- PUTBACK;
+ PUTBACK;
FREETMPS; /* free that return value */
LEAVE; /* ...and the XPUSHed "mortal" args.*/
}
-
- int main (int argc, char **argv, char **env)
+
+ int main (int argc, char **argv, char **env)
{
- char *my_argv[2];
-
+ char *my_argv[] = { "", "power.pl" };
+
my_perl = perl_alloc();
perl_construct( my_perl );
-
- my_argv[1] = (char *) malloc(10);
- sprintf(my_argv[1], "power.pl");
-
- perl_parse(my_perl, NULL, argc, my_argv, env);
-
+
+ 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 -L/usr/local/lib/perl5/alpha-dec_osf/CORE
- -I/usr/local/lib/perl5/alpha-dec_osf/CORE -lperl -lm
-
- % power
+ % 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';
+
+ 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;
+ }
+
+ #borrowed from Safe.pm
+ sub delete_package {
+ my $pkg = shift;
+ my ($stem, $leaf);
+
+ no strict 'refs';
+ $pkg = "main::$pkg\::"; # expand to full symbol table name
+ ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+
+ my $stem_symtab = *{$stem}{HASH};
+
+ delete $stem_symtab->{$leaf};
+ }
+
+ 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(GvSV(errgv)))
+ fprintf(stderr, "eval error: %s\n", SvPV(GvSV(errgv),na));
+ }
+ }
+
+ 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<perl_destruct_level> is set to C<0>, since extra cleaning isn't
+needed when a program has only one interpreter.
+
+Setting C<perl_destruct_level> to C<1> makes everything squeaky clean:
+
+ perl_destruct_level = 1;
+
+ while(1) {
+ ...
+ /* reset global variables here with 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<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, there are two versions of Perl which run
+under Win32. Interfacing to Activeware'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 Activeware's Perl runtime, see the Perl for Win32 FAQ:
+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 so:
+
+ 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 MS Developer
+stdio. In this case, to generate perlxsi.c run:
+
+ perl -MExtUtils::Embed -e xsinit
+
+Create a new project, 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. Finnally, 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. Since you can use
+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<E<lt>orwant@media.mit.eduE<gt>>, with contributions from
-Tim Bunce, Tom Christiansen, Dov Grobgeld, and Ilya Zakharevich.
+Jon Orwant and <F<orwant@tpj.com>> and Doug MacEachern <F<dougm@osf.org>>,
+with small contributions from Tim Bunce, Tom Christiansen, Hallvard Furuseth,
+Dov Grobgeld, and Ilya Zakharevich.
+
+Check out Doug's article on embedding in Volume 1, Issue 4 of The Perl
+Journal. Info about TPJ is available from http://tpj.com.
-December 18, 1995
+July 17, 1997
-Some of this material is excerpted from my book: I<Perl 5 Interactive>,
-Waite Group Press, 1996 (ISBN 1-57169-064-6) and appears
+Some of this material is excerpted from Jon Orwant's book: I<Perl 5
+Interactive>, Waite Group Press, 1996 (ISBN 1-57169-064-6) and appears
courtesy of Waite Group Press.
+=head1 COPYRIGHT
+
+Copyright (C) 1995, 1996, 1997 Doug MacEachern and Jon Orwant. All
+Rights Reserved.
+
+Although destined for release with the standard Perl distribution,
+this document is not public domain, nor is any of Perl and its
+documentation. Permission is granted to freely distribute verbatim
+copies of this document provided that no modifications outside of
+formatting be made, and that this notice remain intact. You are
+permitted and encouraged to use its code and derivatives thereof in
+your own source code for fun or for profit as you see fit.
diff --git a/gnu/usr.bin/perl/pod/perlfaq.pod b/gnu/usr.bin/perl/pod/perlfaq.pod
new file mode 100644
index 00000000000..2213a0f2f01
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perlfaq.pod
@@ -0,0 +1,174 @@
+=head1 NAME
+
+perlfaq - frequently asked questions about Perl ($Date: 1997/04/24 22:46:06 $)
+
+=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 training,
+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 . Mail sent to the old perlfaq alias
+will merely cause the FAQ to be sent to you.
+
+=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 Tom Christiansen and Nathan Torkington.
+All rights reserved.
+
+=head2 Noncommercial Reproduction
+
+Permission is granted to distribute this document, in part or in full,
+via electronic means or printed copy providing that (1) that all credits
+and copyright notices be retained, (2) that no charges beyond reproduction
+be involved, and (3) that a reasonable attempt be made to use the most
+current version available.
+
+Furthermore, you may include this document in any distribution of the
+full Perl source or binaries, in its verbatim documentation, or on a
+complete dump of the CPAN archive, providing that the three stipulations
+given above continue to be met.
+
+=head2 Commercial Reproduction
+
+Requests for all other distribution rights, including the incorporation
+in part or in full of this text or its code into commercial products
+such as but not limited to books, magazine articles, or CD-ROMs, must
+be made to perlfaq-legal@perl.com. Any commercial use of any portion
+of this document without prior written authorization by its authors
+will be subject to appropriate action.
+
+=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 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 email 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/gnu/usr.bin/perl/pod/perlfaq1.pod b/gnu/usr.bin/perl/pod/perlfaq1.pod
new file mode 100644
index 00000000000..a9a5fd48586
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perlfaq1.pod
@@ -0,0 +1,249 @@
+=head1 NAME
+
+perlfaq1 - General Questions About Perl ($Revision: 1.12 $, $Date: 1997/04/24 22:43:34 $)
+
+=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.
+
+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.004. 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.004 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.
+
+=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?
+
+Perl is easy to start learning -- and easy to keep learning. It looks
+like most programming languages you're likely to have had experience
+with, so if you've ever written an C program, an awk script, a shell
+script, or even an Excel macro, 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.004/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.004 release,
+although 5.003 isn't that bad (it's just one year and one release
+behind). Several important bugs were fixed from the 5.000 through
+5.002 versions, though, so try upgrading past them if possible.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
+All rights reserved. See L<perlfaq> for distribution information.
diff --git a/gnu/usr.bin/perl/pod/perlfaq2.pod b/gnu/usr.bin/perl/pod/perlfaq2.pod
new file mode 100644
index 00000000000..8a954da64e4
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perlfaq2.pod
@@ -0,0 +1,443 @@
+=head1 NAME
+
+perlfaq2 - Obtaining and Learning about Perl ($Revision: 1.16 $, $Date: 1997/04/23 18:04:09 $)
+
+=head1 DESCRIPTION
+
+This section of the FAQ answers questions about where to find
+source and documentation for Perl, support and training, 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 is a
+gzipped archive in POSIX tar format. This source builds with no
+porting whatsoever on most Unix systems (Perl's native environment),
+as well as Plan 9, VMS, QNX, OS/2, and the Amiga.
+
+Although it's rumored that the (imminent) 5.004 release may build
+on Windows NT, this is yet to be proven. Binary distributions
+for 32-bit Microsoft systems and for 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. 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.
+
+It's also worth noting that there's a PDF version of the complete
+documentation for perl available in the CPAN/authors/id/BMIDD
+directory.
+
+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.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.
+
+There is also USENET gateway to the mailing list used by the crack
+Perl development team (perl5-porters) at
+news://genetics.upenn.edu/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.
+
+=head2 Perl Books
+
+A number 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 and his apostles, is now in its second edition and
+fourth printing.
+
+ 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)
+ (French and German translations in progress)
+
+Note that O'Reilly books are color-coded: turquoise (some would call
+it teal) covers indicate perl5 coverage, while magenta (some would
+call it pink) covers indicate perl4 only. Check the cover color
+before you buy!
+
+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.
+
+If you're already a hard-core systems programmer, then the Camel Book
+just might suffice for you to learn Perl from. But if you're not,
+check out the "Llama Book". It currently doesn't cover perl5, but the
+2nd edition is nearly done and should be out by summer 97:
+
+ Learning Perl (the Llama Book):
+ Author: Randal Schwartz, with intro by Larry Wall
+ ISBN 1-56592-042-2 (English)
+ ISBN 4-89502-678-1 (Japanese)
+ ISBN 2-84177-005-2 (French)
+ ISBN 3-930673-08-8 (German)
+
+Another stand-out book in the turquoise O'Reilly Perl line is the "Hip
+Owls" book. It covers regular expressions inside and out, with quite a
+bit devoted exclusively to Perl:
+
+ Mastering Regular Expressions (the Cute Owls Book):
+ Author: Jeffrey Friedl
+ ISBN 1-56592-257-3
+
+You can order any of these 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. See
+http://www.ora.com/ on the Web.
+
+Recommended Perl books that are not from O'Reilly are the following:
+
+ Cross-Platform Perl, (for Unix and Windows NT)
+ Author: Eric F. Johnson
+ ISBN: 1-55851-483-X
+
+ How to Set up and Maintain a World Wide Web Site, (2nd edition)
+ Author: Lincoln Stein, M.D., Ph.D.
+ ISBN: 0-201-63462-7
+
+ CGI Programming in C & Perl,
+ Author: Thomas Boutell
+ ISBN: 0-201-42219-0
+
+Note that some of these address specific application areas (e.g. the
+Web) and are not general-purpose programming books.
+
+=head2 Perl in Magazines
+
+The Perl Journal is the first and only magazine dedicated to Perl.
+It is published (on paper, not online) quarterly by Jon Orwant
+(orwant@tpj.com), editor. Subscription information is at http://tpj.com
+or via email to subscriptions@tpj.com.
+
+Beyond this, two other magazines that frequently carry high-quality
+articles on Perl are Web Techniques (see
+http://www.webtechniques.com/) and Unix Review
+(http://www.unixreview.com/). Randal Schwartz'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/
+
+http:/www.oasis.leo.org/perl/ has, amongst other things, source to
+versions 1 through 5 of Perl.
+
+=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 emailing 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, email
+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 PerlArchive 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 Perl Training
+
+While some large training companies offer their own courses on Perl,
+you may prefer to contact individuals near and dear to the heart of
+Perl development. Two well-known members of the Perl development team
+who offer such things are Tom Christiansen <perl-classes@perl.com>
+and Randal Schwartz <perl-training-info@stonehenge.com>, plus their
+respective minions, who offer a variety of professional tutorials
+and seminars on Perl. These courses include large public seminars,
+private corporate training, and fly-ins to Colorado and Oregon.
+See http://www.perl.com/perl/info/training.html for more details.
+
+=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
+
+=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 perlbug program in the perl distribution or
+email 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 man page (perl5.004 or later) for more information.
+
+=head2 What is perl.com? perl.org? The Perl Institute?
+
+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. Current directors of TPI
+include Larry Wall, Tom Christiansen, and Randal Schwartz, whom you
+may have heard of somewhere else around here.
+
+The perl.com domain is Tom Christiansen's domain. He created it as a
+public service long before perl.org came about. It's the original PBS
+of the Perl world, a clearinghouse for information about all things
+Perlian, accepting no paid advertisements, glossy gifs, or (gasp!)
+java applets on its pages.
+
+=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 Tom Christiansen and Nathan Torkington.
+All rights reserved. See L<perlfaq> for distribution information.
diff --git a/gnu/usr.bin/perl/pod/perlfaq3.pod b/gnu/usr.bin/perl/pod/perlfaq3.pod
new file mode 100644
index 00000000000..65ebafdea50
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perlfaq3.pod
@@ -0,0 +1,504 @@
+=head1 NAME
+
+perlfaq3 - Programming Tools ($Revision: 1.22 $, $Date: 1997/04/24 22:43:42 $)
+
+=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:
+
+ Objects perlref, perlmod, perlobj, perltie
+ Data Structures perlref, perllol, perldsc
+ Modules perlmod, perlmodlib, perlsub
+ Regexps perlre, perlfunc, perlop
+ 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>?
+
+Have you tried C<use strict>?
+
+Did you check the returns of each and every system call?
+
+Did you read L<perltrap>?
+
+Have you tried the Perl debugger, described in L<perldebug>?
+
+=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.
+
+=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), can be used to generate
+cross-reference reports for Perl programs.
+
+ perl -MO=Xref[,OPTIONS] foo.pl
+
+=head2 Is there a pretty-printer (formatter) for Perl?
+
+There is no program that will reformat Perl as much as indent(1) will
+do 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.
+
+Your editor can and should help you with source formatting. 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 using to using 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 ftp://ftp.perl.com/pub/vi/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 "main'foo"
+(single quote), and mess up the indentation and hilighting. You
+should be using "main::foo", anyway.
+
+=head2 How can I use curses with Perl?
+
+The Curses module from CPAN provides a dynamically loadable object
+module interface to a curses library.
+
+=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.
+
+=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 Can I dynamically load C routines into Perl?
+
+If your system architecture supports it, then the standard perl
+on your system should also provide you with this via the
+DynaLoader module. Read L<perlxstut> for details.
+
+=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.
+
+Other approaches include autoloading 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.
+
+If you're currently linking your perl executable to a shared 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. Memory the system allocates to a program will never be
+returned to the system. That's why long-running programs sometimes
+re-exec themselves.
+
+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. (NB: my() variables also execute
+about 10% faster than globals.) 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 at least 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::* modules (from CPAN),
+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. 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 processes.
+
+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.
+
+=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.) 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 as of
+Feb-1997 in late alpha release, which means it's fun to play with if
+you're a programmer but not really for people looking for turn-key
+solutions.
+
+I<Please> understand that 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 thus
+will still 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.
+
+Malcolm will be in charge of the 5.005 release of Perl itself
+to try to unify and merge his compiler and multithreading work into
+the main release.
+
+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 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, /usr/bin/perl is only 11k in
+size!
+
+=head2 How can I get '#!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 Activeware port of Perl,
+will modify the Registry to associate the .pl extension with the perl
+interpreter. If you install another 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 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, I'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.
+
+I'm afraid that there is no general solution to all of this. It is a
+mess, pure and simple.
+
+[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:
+
+ The Idiot's Guide to Solving Perl/CGI Problems, by Tom Christiansen
+ http://www.perl.com/perl/faq/idiots-guide.html
+
+ Frequently Asked Questions about CGI Programming, by Nick Kew
+ ftp://rtfm.mit.edu/pub/usenet/news.answers/www/cgi-faq
+ http://www3.pair.com/webthing/docs/cgi/faqs/cgifaq.shtml
+
+ Perl/CGI programming FAQ, by Shishir Gundavaram and Tom Christiansen
+ http://www.perl.com/perl/faq/perl-cgi-faq.html
+
+ The WWW Security FAQ, by Lincoln Stein
+ http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html
+
+ World Wide Web FAQ, by Thomas Boutell
+ http://www.boutell.com/faq/
+
+=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 Tom Christiansen and Nathan Torkington.
+All rights reserved. See L<perlfaq> for distribution information.
+
diff --git a/gnu/usr.bin/perl/pod/perlfaq4.pod b/gnu/usr.bin/perl/pod/perlfaq4.pod
new file mode 100644
index 00000000000..a5b505c4a7a
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perlfaq4.pod
@@ -0,0 +1,1101 @@
+=head1 NAME
+
+perlfaq4 - Data Manipulation ($Revision: 1.19 $, $Date: 1997/04/24 22:43:57 $)
+
+=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)?
+
+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.
+
+=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?
+
+For rounding to a certain number of digits, sprintf() or printf() is
+usually the easiest route.
+
+The POSIX module (part of the standard perl distribution) implements
+ceil(), floor(), and a number of other mathematical and trigonometric
+functions.
+
+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 '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 that's how these things work. A longer
+explanation is available on
+http://www.perl.com/CPAN/doc/FMTEYEWTK/random, courtesy of Tom
+Phoenix.
+
+You should also check out the Math::TrulyRandom module from CPAN.
+
+=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.
+
+=head2 How can I compare two date strings?
+
+Use the Date::Manip or Date::DateCalc 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 timelocal in the standard
+Time::Local module. Otherwise, you should look into one of the
+Date modules from CPAN.
+
+=head2 How can I find the Julian Day?
+
+Neither Date::Manip nor Date::DateCalc deal with Julian days.
+Instead, there is an example of Julian date calculation in
+http://www.perl.com/CPAN/authors/David_Muir_Sharnoff/modules/Time/JulianDay.pm.gz,
+which should help.
+
+=head2 Does Perl have a year 2000 problem?
+
+Not unless you use Perl to create one. 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).
+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 a 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.
+
+=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, email
+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 (\)
+character are removed with:
+
+ s/\\(.)/$1/g;
+
+Note that this won't expand \n or \t or any other special escapes.
+
+=head2 How do I remove consecutive pairs of characters?
+
+To turn "abbcccd" into "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 a 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";
+
+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 tackled 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.
+
+=head2 How do I reverse a string?
+
+Use reverse() in a scalar context, as documented in
+L<perlfunc/reverse>.
+
+ $reversed = reverse $string;
+
+=head2 How do I expand tabs in a string?
+
+You can do it the old-fashioned way:
+
+ 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 may 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 regexp 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. For example, let's say you want
+to change the fifth occurrence of "whoever" or "whomever"
+into "whosoever" or "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;
+
+=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 E<lt>comdog@computerdog.comE<gt>):
+
+ $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;
+
+=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?
+
+The simplest approach, albeit not the fastest, is probably like this:
+
+ $string =~ s/^\s*(.*?)\s*$/$1/;
+
+It would be faster to do this in two steps:
+
+ $string =~ s/^\s+//;
+ $string =~ s/\s+$//;
+
+Or more nicely written as:
+
+ for ($string) {
+ s/^\s+//;
+ s/\s+$//;
+ }
+
+=head2 How do I extract selected columns from a string?
+
+Use substr() or unpack(), both documented in L<perlfunc>.
+
+=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';
+ $text =~ s/\$(\w+)/${$1}/g;
+
+Before version 5 of perl, this had to be done with a double-eval
+substitution:
+
+ $text =~ s/(\$\w+)/$1/eeg;
+
+Which is bizarre enough that you'll probably actually need an EEG
+afterwards. :-)
+
+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.
+
+=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
+
+=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:
+
+ $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.
+
+=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 an array contains a certain element?
+
+There are several ways to approach this. If you are going to make
+this query many times and the values are arbitrary strings, 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;
+ grep (vec($read,$_,1) = 1, @articles);
+
+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.
+
+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?
+
+Here's a shuffling algorithm which works its way through the list,
+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));
+ }
+
+For large arrays, this avoids a lot of the reshuffling:
+
+ srand;
+ @new = ();
+ @old = 1 .. 10000; # just a demo
+ for( @old ){
+ my $r = rand @new+1;
+ push(@new,$new[$r]);
+ $new[$r] = $_;
+ }
+
+=head2 How do I process/modify each element of an array?
+
+Use C<for>/C<foreach>:
+
+ for (@lines) {
+ s/foo/bar/;
+ tr[a-z][A-Z];
+ }
+
+Here's another; let's compute spherical volumes:
+
+ for (@radii) {
+ $_ **= 3;
+ $_ *= (4/3) * 3.14159; # this will be constant folded
+ }
+
+=head2 How do I select a random element from an array?
+
+Use the rand() function (see L<perlfunc/rand>):
+
+ srand; # not needed for 5.004 and later
+ $index = rand @array;
+ $element = $array[$index];
+
+=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 permut() function should work on any list:
+
+ #!/usr/bin/perl -n
+ # permute - tchrist@perl.com
+ permut([split], []);
+ sub permut {
+ my @head = @{ $_[0] };
+ my @tail = @{ $_[1] };
+ unless (@head) {
+ # stop recursing when there are no elements in the head
+ print "@tail\n";
+ } else {
+ # for all elements in @head, move one from @head to @tail
+ # and call permut() on the new @head and @tail
+ my(@newhead,@newtail,$i);
+ foreach $i (0 .. $#head) {
+ @newhead = @head;
+ @newtail = @tail;
+ unshift(@newtail, splice(@newhead, $i, 1));
+ permut([@newhead], [@newtail]);
+ }
+ }
+ }
+
+=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">.
+
+=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 a 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 whole number" unless /^\d+$/;
+ warn "not an integer" unless /^-?\d+$/; # reject +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+))?$/;
+
+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 Tom Christiansen and Nathan Torkington.
+All rights reserved. See L<perlfaq> for distribution information.
+
diff --git a/gnu/usr.bin/perl/pod/perlfaq5.pod b/gnu/usr.bin/perl/pod/perlfaq5.pod
new file mode 100644
index 00000000000..03d5e6a797b
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perlfaq5.pod
@@ -0,0 +1,830 @@
+=head1 NAME
+
+perlfaq5 - Files and Formats ($Revision: 1.22 $, $Date: 1997/04/24 22:44:02 $)
+
+=head1 DESCRIPTION
+
+This section deals with I/O and the "f" issues: filehandles, flushing,
+formats, and footers.
+
+=head2 How do I flush/unbuffer a 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 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, as in the older:
+
+ 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();
+ $sock->print("GET /\015\012");
+ $document = join('', $sock->getlines());
+ print "DOC IS: $document\n";
+
+Note the 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.
+
+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]);
+
+=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. Replacing a sequence
+of bytes with another sequence of the same length is one. 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.
+
+ $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;
+
+=head2 How do I make a temporary file name?
+
+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 IO::File;
+ 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 {
+ my $fh = undef;
+ my $count = 0;
+ until (defined($fh) || $count > 100) {
+ $base_name =~ s/-(\d+)$/"-" . (1 + $1)/e;
+ $fh = IO::File->new($base_name, O_WRONLY|O_EXCL|O_CREAT, 0644)
+ }
+ if (defined($fh)) {
+ return ($fh, $base_name);
+ } else {
+ return ();
+ }
+ }
+ }
+
+Or you could simply use IO::Handle::new_tmpfile.
+
+=head2 How can I manipulate fixed-record-length files?
+
+The most efficient way is using pack() and unpack(). This is faster
+than using substr(). 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|");
+ $_ = <PS>; print;
+ 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";
+ }
+
+=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?
+
+You may have some success with typeglobs, as we always had to use
+in days of old:
+
+ local(*FH);
+
+But while still supported, that isn't the best to go about getting
+local filehandles. Typeglobs have their drawbacks. You may well want
+to use the C<FileHandle> module, which creates new filehandles for you
+(see L<FileHandle>):
+
+ use FileHandle;
+ sub findme {
+ my $fh = FileHandle->new();
+ open($fh, "</etc/hosts") or die "no /etc/hosts: $!";
+ while (<$fh>) {
+ print if /\b127\.(0\.0\.)?1\b/;
+ }
+ # $fh automatically closes/disappears here
+ }
+
+Internally, Perl believes filehandles to be of class IO::Handle. You
+may use that module directly if you'd like (see L<IO::Handle>), or
+one of its more specific derived classes.
+
+Once you have IO::File or FileHandle objects, you can pass them
+between subroutines or store them in hashes as you would any other
+scalar values:
+
+ use FileHandle;
+
+ # Storing filehandles in a hash and array
+ foreach $filename (@names) {
+ my $fh = new FileHandle($filename) or die;
+ $file{$filename} = $fh;
+ push(@files, $fh);
+ }
+
+ # Using the filehandles in the array
+ foreach $file (@files) {
+ print $file "Testing\n";
+ }
+
+ # You have to do the { } ugliness when you're specifying the
+ # filehandle by anything other than a simple scalar variable.
+ print { $files[2] } "Testing\n";
+
+ # Passing filehandles to subroutines
+ sub debug {
+ my $filehandle = shift;
+ printf $filehandle "DEBUG: ", @_;
+ }
+
+ debug($fh, "Testing\n");
+
+=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 the 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
+
+Whoops. You should instead use this, which will fail if the file
+doesn't exist.
+
+ open(FH, "+< /path/name"); # open for update
+
+If this is an issue, try:
+
+ sysopen(FH, "/path/name", O_RDWR|O_CREAT, 0644);
+
+Error checking is left as an exercise for the reader.
+
+=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.
+
+=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
+
+The CPAN module File::Lock offers similar functionality and (if you
+have dynamic loading) won't require you to rebuild perl if your
+flock() can't lock network files.
+
+=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, 0644)
+ 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?
+
+Anyway, this is what to do:
+
+ use Fcntl;
+ sysopen(FH, "numfile", O_RDWR|O_CREAT, 0644) 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.
+
+Don't forget to set binmode() under DOS-like platforms when operating
+on files that have anything other than straight text in them. See the
+docs on open() and on binmode() for more details.
+
+=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];
+ print "file $file updated at ", scalar(localtime($file)), "\n";
+
+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");
+
+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.
+
+In theory a IO::Tee class could be written, but to date we haven't
+seen such.
+
+=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?
+
+You should 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);
+ }
+
+You should look into getting the Term::ReadKey extension from CPAN.
+
+=head2 How do I open a file without blocking?
+
+You need 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 create a file only if it doesn't exist?
+
+You need to use the O_CREAT and O_EXCL flags from the Fcntl module in
+conjunction with sysopen():
+
+ use Fcntl;
+ sysopen(FH, "/tmp/somefile", O_WRONLY|O_EXCL|O_CREAT, 0644)
+ 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!
+
+=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)
+
+Error checking 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.
+
+=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 Every 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.
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
+All rights reserved. See L<perlfaq> for distribution information.
+
diff --git a/gnu/usr.bin/perl/pod/perlfaq6.pod b/gnu/usr.bin/perl/pod/perlfaq6.pod
new file mode 100644
index 00000000000..535e4644551
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perlfaq6.pod
@@ -0,0 +1,605 @@
+=head1 NAME
+
+perlfaq6 - Regexps ($Revision: 1.17 $, $Date: 1997/04/24 22:44:10 $)
+
+=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) /ge;
+
+=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 newlines in your string, or you aren't using the
+correct modifier(s) on your pattern.
+
+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+)(\s+\1)+\b/gi ) {
+ 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.
+
+=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 accented characters?
+
+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?
+
+Strictly speaking, nothing. Stylistically speaking, it's not a good
+way to write maintainable code. That's because you're using these
+constructs not for their return values but rather for their
+side-effects, and side-effects can be mystifying. There's no void
+grep() that's not better written as a C<for> (well, C<foreach>,
+technically) loop.
+
+=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 Tom Christiansen and Nathan Torkington.
+All rights reserved. See L<perlfaq> for distribution information.
+
diff --git a/gnu/usr.bin/perl/pod/perlfaq7.pod b/gnu/usr.bin/perl/pod/perlfaq7.pod
new file mode 100644
index 00000000000..283aa2bb34b
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perlfaq7.pod
@@ -0,0 +1,717 @@
+=head1 NAME
+
+perlfaq7 - Perl Language Issues ($Revision: 1.18 $, $Date: 1997/04/24 22:44:14 $)
+
+=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?
+
+No, 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.
+
+=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.18 $=~/\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 create filehandles you can pass to subroutines, you can use C<*FH>
+or C<\*FH> notation ("typeglobs" - see L<perldata> for more information),
+or create filehandles dynamically using the old FileHandle or the new
+IO::File modules, both part of the standard Perl distribution.
+
+ use Fcntl;
+ use IO::File;
+ my $fh = new IO::File $filename, O_WRONLY|O_APPEND;
+ or die "Can't append to $filename: $!";
+ func($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.
+
+=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 also L<perlsub>, which explains this all in more detail.
+
+=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 "local($foo) = <FILE>;" work right?
+
+C<local()> gives 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 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.
+
+Here's a simple example of a switch based on pattern matching. 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";
+
+ }
+
+=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] ) {
+
+ /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->find("Samy")>) instead. Object notation is explained in
+L<perlobj>.
+
+=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 = ref bless [];
+
+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
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
+All rights reserved. See L<perlfaq> for distribution information.
diff --git a/gnu/usr.bin/perl/pod/perlfaq8.pod b/gnu/usr.bin/perl/pod/perlfaq8.pod
new file mode 100644
index 00000000000..f4d3c12f6f7
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perlfaq8.pod
@@ -0,0 +1,851 @@
+=head1 NAME
+
+perlfaq8 - System Interaction ($Revision: 1.21 $, $Date: 1997/04/24 22:44:19 $)
+
+=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 ($OSTYPE 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
+
+=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.
+
+=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, as in the older
+
+ use FileHandle;
+ DEV->autoflush(1);
+
+and the newer
+
+ use IO::Handle;
+ DEV->autoflush(1);
+
+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]);
+
+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
+
+=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. 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 you then trap. 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, the getpw*() functions described in
+L<perlfunc> provide (read-only) access to 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";
+
+=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 you 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). It 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>).
+
+=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 8 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 .
+
+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 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 (eg, 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.
+
+=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. These
+days, your best bet is to look at the Comm.pl library available from
+CPAN.
+
+=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.
+
+=item VMS
+
+Change to %ENV persist after Perl exits, but directory changes do not.
+
+=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.
+
+=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 .
+
+=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.
+
+=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,
+the question "How do I keep my own module/library directory?"
+
+=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 How do I get one key from the terminal at a time, under POSIX?
+
+ #!/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() }
+
+=head1 AUTHOR AND COPYRIGHT
+
+Copyright (c) 1997 Tom Christiansen and Nathan Torkington.
+All rights reserved. See L<perlfaq> for distribution information.
diff --git a/gnu/usr.bin/perl/pod/perlfaq9.pod b/gnu/usr.bin/perl/pod/perlfaq9.pod
new file mode 100644
index 00000000000..aa942c2da05
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perlfaq9.pod
@@ -0,0 +1,331 @@
+=head1 NAME
+
+perlfaq9 - Networking ($Revision: 1.17 $, $Date: 1997/04/24 22:44:29 $)
+
+=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. Can you help me fix it?
+
+Sure, but you probably can't afford our contracting rates :-)
+
+Seriously, 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 are:
+
+ http://www.perl.com/perl/faq/idiots-guide.html
+ http://www3.pair.com/webthing/docs/cgi/faqs/cgifaq.shtml
+ http://www.perl.com/perl/faq/perl-cgi-faq.html
+ http://www-genome.wi.mit.edu/WWW/faqs/www-security-faq.html
+ http://www.boutell.com/faq/
+
+=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
+.
+
+=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:
+
+ # print HTML from a URL
+ use LWP::Simple;
+ getprint "http://www.sn.no/libwww-perl/";
+
+ # 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 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.
+
+=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 an email 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?
+
+A lot of people are tempted to code this up themselves, so you've
+probably all seen a lot of code involving C<$ENV{CONTENT_LENGTH}> and
+C<$ENV{QUERY_STRING}>. It's true that this can work, but there are
+also a lot of versions of this floating around that are quite simply
+broken!
+
+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).
+
+=head2 How do I check a valid email address?
+
+You can't.
+
+Without sending mail to the address and seeing whether it bounces (and
+even then you face the halting problem), you cannot determine whether
+an email address is valid. Even if you apply the email 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 email
+addresses with a simple regexp, such as
+C</^[\w.-]+\@([\w.-]\.)+\w+$/>. 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 email to
+(say, Bill Clinton or your postmaster), and then makes sure that the
+hostname given can be looked up in DNS. It's not fast, but it works.
+
+Here's an alternative strategy used by many CGI script authors: Check
+the email address with a simple regexp (such as the one above). If
+the regexp matched the address, accept the address. If the regexp
+didn't match the address, request confirmation from the user that the
+email address they entered was correct.
+
+=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 email 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 email address can mean that this generates addresses
+that the company's email system will not accept, so you should ask for
+users' email 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/read mail?
+
+Sending mail: the Mail::Mailer module from CPAN (part of the MailTools
+package) is UNIX-centric, while Mail::Internet uses Net::SMTP which is
+not UNIX-centric. Reading 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;
+
+=head2 How do I find out my hostname/domainname/IP address?
+
+A lot of code has historically cavalierly called the C<`hostname`>
+program. While sometimes expedient, this isn't very portable. 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 Tom Christiansen and Nathan Torkington.
+All rights reserved. See L<perlfaq> for distribution information.
+
diff --git a/gnu/usr.bin/perl/pod/perlform.pod b/gnu/usr.bin/perl/pod/perlform.pod
index cf0bc068f16..7e540b8ff69 100644
--- a/gnu/usr.bin/perl/pod/perlform.pod
+++ b/gnu/usr.bin/perl/pod/perlform.pod
@@ -5,20 +5,20 @@ 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 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
+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 name "STDOUT", and the default format for filehandle
TEMP is name "TEMP". They just look the same. They aren't.
@@ -29,8 +29,8 @@ Output record formats are declared as follows:
FORMLIST
.
-If name is omitted, format "STDOUT" is defined. FORMLIST consists of a
-sequence of lines, each of which may be of one of three types:
+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
@@ -54,7 +54,7 @@ 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 "<", ">", or "|"
+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.
@@ -64,7 +64,7 @@ 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,
-non-truncated values; it should appear by itself on a 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
@@ -72,7 +72,14 @@ 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.
+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
@@ -98,9 +105,9 @@ 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
+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 <perlfunc/write()>.
+It's triggered at the top of each page. See L<perlfunc/write>.
Examples:
@@ -147,22 +154,22 @@ Examples:
.
It is possible to intermix print()s with write()s on the same output
-channel, but you'll have to handle $- ($FORMAT_LINES_LEFT)
+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<$~> ($FORMAT_NAME),
-and the current top of form format name is in C<$^> ($FORMAT_TOP_NAME).
-The current output page number is stored in C<$%> ($FORMAT_PAGE_NUMBER),
-and the number of lines on the page is in C<$=> ($FORMAT_LINES_PER_PAGE).
+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<$|>
-($OUTPUT_AUTOFLUSH). The string output before each top of page (except
-the first) is stored in C<$^L> ($FORMAT_FORMFEED). These variables are
+(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),
+ select((select(OUTF),
$~ = "My_Other_Format",
$^ = "My_Top_Format"
)[0]);
@@ -187,7 +194,7 @@ If you use the English module, you can even read the variable names:
select($ofh);
But you still have those funny select()s. So just use the FileHandle
-module. Now, you can access these special variables using lower-case
+module. Now, you can access these special variables using lowercase
method names instead:
use FileHandle;
@@ -198,25 +205,25 @@ Much better!
=head1 NOTES
-Since the values line may contain arbitrary expressions (for at fields,
+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 =
+ format Ident =
@<<<<<<<<<<<<<<<
&commify($n)
.
To get a real at or caret into the field, do this:
- format Ident =
+ format Ident =
I have an @ here.
"@"
.
To center a whole line of text, do something like this:
- format Ident =
+ format Ident =
@|||||||||||||||||||||||||||||||||||||||||||||||
"Some text line"
.
@@ -233,12 +240,12 @@ on the current number of columns, and then eval() it:
. '$entry' . "\n";
. ".\n";
print $format if $Debugging;
- eval $format;
+ eval $format;
die $@ if $@;
Which would generate a format looking something like this:
- format STDOUT =
+ format STDOUT =
^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
$entry
^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~
@@ -247,7 +254,7 @@ Which would generate a format looking something like this:
Here's a little program that's somewhat like fmt(1):
- format =
+ format =
^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ~~
$_
@@ -257,7 +264,7 @@ Here's a little program that's somewhat like fmt(1):
while (<>) {
s/\s*\n\s*/ /g;
write;
- }
+ }
=head2 Footers
@@ -270,10 +277,10 @@ 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(MESELF, "|-")>
-(see L<perlfunc/open()>) and always write() to MESELF instead of
-STDOUT. Have your child process postprocesses its STDIN to rearrange
-headers and footers however you like. Not very convenient, but doable.
+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
@@ -298,7 +305,7 @@ is to printf(), do this:
$^A = "";
formline($format,@_);
return $^A;
- }
+ }
$string = swrite(<<'END', 1, 2, 3);
Check me out
@@ -306,10 +313,25 @@ is to printf(), do this:
END
print $string;
-=head1 WARNING
+=head1 WARNINGS
+
+The lone dot that ends a format can also prematurely end an email
+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 email, you should indent it so that
+the format-ending dot is not on the left margin; this will prevent
+email 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.) Furthermore,
-lexical aliases will not be compiled correctly: see
-L<perlfunc/my> for other issues.
+variable. (They weren't visible at all before version 5.001.)
+
+Formats are the only part of Perl which 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/gnu/usr.bin/perl/pod/perlfunc.pod b/gnu/usr.bin/perl/pod/perlfunc.pod
index 28b5442e909..aa1e82eac83 100644
--- a/gnu/usr.bin/perl/pod/perlfunc.pod
+++ b/gnu/usr.bin/perl/pod/perlfunc.pod
@@ -14,8 +14,8 @@ 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 only
-ever be one list argument.) For instance, splice() has three scalar
+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
@@ -28,18 +28,18 @@ 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
-parens.) If you use the parens, the simple (but occasionally
+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+3; # Prints 6.
- print(1+2) + 3; # Prints 3.
- print (1+2)+3; # Also prints 3!
- print +(1+2)+3; # Prints 6.
- print ((1+2)+3); # Prints 6.
+ 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:
@@ -48,7 +48,7 @@ example, the third line above produces:
Useless use of integer addition in void context at - line 1.
For functions that can be used in either a scalar or list context,
-non-abortive failure is generally indicated in a scalar context by
+nonabortive failure is generally indicated in a scalar context by
returning the undefined value, and in a list context by returning the
null list.
@@ -56,9 +56,7 @@ Remember the following rule:
=over 8
-=item
-
-I<THERE IS NO GENERAL RULE FOR CONVERTING A LIST INTO A SCALAR!>
+=item I<THERE IS NO GENERAL RULE FOR CONVERTING A LIST INTO A SCALAR!>
=back
@@ -110,7 +108,7 @@ delete, each, exists, keys, values
binmode, close, closedir, dbmclose, dbmopen, die, eof,
fileno, flock, format, getc, print, printf, read, readdir,
-rewinddir, seek, seekdir, select, syscall, sysread,
+rewinddir, seek, seekdir, select, syscall, sysread, sysseek,
syswrite, tell, telldir, truncate, warn, write
=item Functions for fixed length data or records
@@ -119,7 +117,7 @@ pack, read, syscall, sysread, syswrite, unpack, vec
=item Functions for filehandles, files, or directories
--X, chdir, chmod, chown, chroot, fcntl, glob, ioctl, link,
+I<-X>, chdir, chmod, chown, chroot, fcntl, glob, ioctl, link,
lstat, mkdir, open, opendir, readlink, rename, rmdir,
stat, symlink, umask, unlink, utime
@@ -128,7 +126,7 @@ stat, symlink, umask, unlink, utime
caller, continue, die, do, dump, eval, exit, goto, last,
next, redo, return, sub, wantarray
-=item Keywords related to scoping
+=item Keywords related to scoping
caller, import, local, my, package, use
@@ -183,8 +181,8 @@ gmtime, localtime, time, times
=item Functions new in perl5
abs, bless, chomp, chr, exists, formline, glob, import, lc,
-lcfirst, map, my, no, qx, qw, ref, sub*, sysopen, tie, tied, uc,
-ucfirst, untie, use
+lcfirst, map, my, no, prototype, qx, qw, readline, readpipe,
+ref, sub*, sysopen, tie, tied, uc, ucfirst, untie, use
* - C<sub> was a keyword in perl4, but in perl5 it is an
operator which can be used in expressions.
@@ -193,12 +191,10 @@ operator which can be used in expressions.
dbmclose, dbmopen
-
=back
=head2 Alphabetical Listing of Perl Functions
-
=over 8
=item -X FILEHANDLE
@@ -229,7 +225,7 @@ operator may be any of:
-e File exists.
-z File has zero size.
- -s File has non-zero size (returns size).
+ -s File has nonzero size (returns size).
-f File is a plain file.
-d File is a directory.
@@ -252,12 +248,12 @@ operator may be any of:
-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
+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. Also note that, for the superuser,
-C<-r>, C<-R>, C<-w> and C<-W> always return 1, and C<-x> and C<-X> return
+C<-r>, C<-R>, C<-w>, and C<-W> always return 1, and C<-x> and C<-X> return
1 if any execute bit is set in the mode. Scripts run by the superuser may
-thus need to do a stat() in order to determine the actual mode of the
+thus need to do a stat() to determine the actual mode of the
file, or temporarily set the uid to something else.
Example:
@@ -274,17 +270,17 @@ 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 odd characters (>30%)
+characters with the high bit set. If too many odd 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
+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 stat() or lstat() operators) are given the
-special filehandle consisting of a solitary underline, then the stat
+If any of the file tests (or either the stat() or 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
@@ -304,7 +300,10 @@ symbolic link, not the real file.) Example:
=item abs VALUE
+=item abs
+
Returns the absolute value of its argument.
+If VALUE is omitted, uses $_.
=item accept NEWSOCKET,GENERICSOCKET
@@ -314,8 +313,11 @@ 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. (On some machines,
+specified number of seconds have elapsed. If SECONDS is not specified,
+the value stored in $_ 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
@@ -324,14 +326,38 @@ 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
-syscall() interface to access setitimer(2) if your system supports it,
-or else see L</select()> below. It is not advised to intermix alarm()
+syscall() interface to access setitimer(2) if your system supports it,
+or else see L</select()>. It is usually a mistake to intermix alarm()
and sleep() calls.
+If you want to use alarm() to time out a system call you need to use an
+eval/die pair. You can't rely on the alarm causing the system call to
+fail with $! set to EINTR because Perl sets up signal handlers to
+restart system calls on some systems. Using eval/die always works.
+
+ eval {
+ local $SIG{ALRM} = sub { die "alarm\n" }; # NB \n required
+ alarm $timeout;
+ $nread = sysread SOCKET, $buffer, $size;
+ alarm 0;
+ };
+ die if $@ && $@ ne "alarm\n"; # propagate errors
+ if ($@) {
+ # 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 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
@@ -344,9 +370,9 @@ L<perlipc/"Sockets: Client/Server Communication">.
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 DOS
+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
-DOS-damaged C library may mangle your file. The key distinction between
+MS-DOS-damaged C library may mangle your file. The key distinction between
systems that need binmode and those that don't is their text file
formats. Systems like Unix and Plan9 that delimit lines with a single
character, and that encode that character in C as '\n', do not need
@@ -357,10 +383,10 @@ is taken as the name of the filehandle.
=item bless REF
-This function tells the referenced object (passed as REF) that it is now
+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, since a bless() is often the last thing in a constructor.
+convenience, because a 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<perlobj> for more about the
blessing (and blessings) of objects.
@@ -370,8 +396,9 @@ blessing (and blessings) of objects.
=item caller
Returns the context of the current subroutine call. In a scalar context,
-returns TRUE if there is a caller, that is, if we're in a subroutine or
-eval() or require(), and FALSE otherwise. In a list context, returns
+returns the caller's package name if there is a caller, that is, if
+we're in a subroutine or eval() or require(), and the undefined value
+otherwise. In a list context, returns
($package, $filename, $line) = caller;
@@ -379,12 +406,21 @@ 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, $wantargs) = caller($i);
+ ($package, $filename, $line, $subroutine,
+ $hasargs, $wantarray, $evaltext, $is_require) = caller($i);
+
+Here $subroutine may be C<"(eval)"> if the frame is not a subroutine
+call, but an C<eval>. In such a case additional elements $evaltext and
+$is_require are set: $is_require is true if the frame is created by a
+C<require> or C<use> statement, $evaltext contains the text of the
+C<eval EXPR> statement. In particular, for a C<eval BLOCK> statement,
+$filename is C<"(eval)">, but $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 @DB::args to be the
-arguments with which that subroutine was invoked.
+arguments with which the subroutine was invoked.
=item chdir EXPR
@@ -396,10 +432,15 @@ otherwise. See example under die().
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. Returns the number of files successfully changed.
+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
@@ -407,14 +448,14 @@ number. Returns the number of files successfully changed.
=item chomp
-This is a slightly safer version of chop (see below). It removes any
+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 number
-of characters removed. 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
-$_. Example:
+$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 $_. Example:
while (<>) {
chomp; # avoid \n on last field
@@ -468,7 +509,7 @@ Returns the number of files successfully changed.
$cnt = chown $uid, $gid, 'foo', 'bar';
chown $uid, $gid, @filenames;
-Here's an example that looks up non-numeric uids in the passwd file:
+Here's an example that looks up nonnumeric uids in the passwd file:
print "User: ";
chop($user = <STDIN>);
@@ -481,22 +522,28 @@ Here's an example that looks up non-numeric uids in the passwd file:
@ary = <${pattern}>; # expand filenames
chown $uid, $gid, @ary;
-On most systems, you are not allowed to change the ownership of the
+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 "A" in ASCII.
+For example, C<chr(65)> is "A" in ASCII. For the reverse, use L</ord>.
+
+If NUMBER is omitted, uses $_.
=item chroot FILENAME
+=item chroot
+
This function works as the system call by the same name: it makes the
named directory the new root directory for all further pathnames that
begin with a "/" by your process and all of its children. (It doesn't
-change your current working directory is unaffected.) For security
+change your current working directory, which is unaffected.) For security
reasons, this call is restricted to the superuser. If FILENAME is
omitted, does chroot to $_.
@@ -504,19 +551,30 @@ omitted, does chroot to $_.
Closes the file or pipe associated with the file handle, returning TRUE
only if stdio successfully flushes buffers and closes the system file
-descriptor. You don't have to close FILEHANDLE if you are immediately
-going to do another open() on it, since open() will close it for you. (See
+descriptor.
+
+You don't have to close FILEHANDLE if you are immediately going to do
+another open() on it, because open() will close it for you. (See
open().) However, an explicit close on an input file resets the line
-counter ($.), while the implicit close done by open() does not. Also,
-closing a pipe will wait 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 status value of
-the command into C<$?>. Example:
+counter ($.), while the implicit close done by 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 $! will be set to 0.) Also, closing a pipe will
+wait 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
+ open(OUTPUT, '|sort >foo') # pipe to sort
+ or die "Can't start sort: $!";
... # print stuff to output
- close OUTPUT; # wait for sort to finish
- open(INPUT, 'foo'); # get sort's results
+ 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 gives the real filehandle name.
@@ -546,6 +604,11 @@ statement).
Returns the cosine of EXPR (expressed in radians). If EXPR is omitted
takes cosine of $_.
+For the inverse cosine operation, you may use the 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
@@ -554,6 +617,11 @@ 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 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:
@@ -570,36 +638,36 @@ their own password:
die "Sorry...\n";
} else {
print "ok\n";
- }
+ }
-Of course, typing in your own password to whoever asks you
+Of course, typing in your own password to whoever asks you
for it is unwise.
-=item dbmclose ASSOC_ARRAY
+=item dbmclose HASH
[This function has been superseded by the untie() function.]
-Breaks the binding between a DBM file and an associative array.
+Breaks the binding between a DBM file and a hash.
-=item dbmopen ASSOC,DBNAME,MODE
+=item dbmopen HASH,DBNAME,MODE
[This function has been superseded by the tie() function.]
-This binds a dbm(3), ndbm(3), sdbm(3), gdbm(), or Berkeley DB file to an
-associative array. ASSOC is the name of the associative array. (Unlike
-normal 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 umask()).
-If your system only supports the older DBM functions, you may perform only
-one dbmopen() in your program. In older versions of Perl, if your system
-had neither DBM nor ndbm, calling 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
-associative array variables, not set them. If you want to test whether
-you can write, either use file tests or try setting a dummy array entry
-inside an eval(), which will trap the error.
+This binds a dbm(3), ndbm(3), sdbm(3), gdbm(), or Berkeley DB file to a
+hash. HASH is the name of the hash. (Unlike normal 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 umask()). If your system supports
+only the older DBM functions, you may perform only one dbmopen() in your
+program. In older versions of Perl, if your system had neither DBM nor
+ndbm, calling 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 eval(),
+which will trap the error.
Note that functions such as keys() and values() may return huge array
values when used on large DBM files. You may prefer to use the each()
@@ -613,22 +681,35 @@ function to iterate over large DBM files. Example:
dbmclose(%HIST);
See also L<AnyDBM_File> for a more general description of the pros and
-cons of the various dbm apparoches, as well as L<DB_File> for a particularly
+cons of the various dbm approaches, as well as L<DB_File> for a particularly
rich implementation.
=item defined EXPR
-Returns a boolean value saying whether EXPR has a real value
-or not. Many operations return the undefined value under exceptional
-conditions, such as end of file, uninitialized variable, system error
-and such. This function allows you to distinguish between an undefined
-null scalar and a defined null scalar with operations that might return
-a real null string, such as referencing elements of an array. You may
-also check to see if arrays or subroutines exist. Use of defined on
-predefined variables is not guaranteed to produce intuitive results.
+=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.
-When used on a hash array element, it tells you whether the value
-is defined, not whether the key exists in the hash. Use exists() for that.
+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 "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: 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 defined() to check whether a subroutine exists. On
+the other hand, use of 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:
@@ -636,15 +717,12 @@ Examples:
print "$val\n" while defined($val = pop(@ary));
die "Can't readlink $sym: $!"
unless defined($value = readlink $sym);
- eval '@foo = ()' if defined(@foo);
- die "No XYZ package defined" unless defined %_XYZ;
sub foo { defined &$bar ? &$bar(@_) : die "No bar"; }
+ $debugging = 0 unless defined $debugging;
-See also undef().
-
-Note: many folks tend to overuse defined(), and then are surprised to
-discover that the number 0 and the null string are, in fact, defined
-concepts. For example, if you say
+Note: Many folks tend to overuse defined(), and then are surprised to
+discover that the number 0 and "" (the zero-length string) are, in fact,
+defined values. For example, if you say
"ab" =~ /a(.*)b/;
@@ -652,44 +730,69 @@ the pattern match succeeds, and $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 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 only use defined() when you're questioning the integrity
-of what you're trying to do. At other times, a simple comparison to
-0 or "" is what you want.
+it's an admission that it couldn't give you an honest answer. So you
+should use defined() only when you're questioning the integrity of what
+you're trying to do. At other times, a simple comparison to 0 or "" is
+what you want.
+
+Currently, using 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 undef() on these, however, does clear their memory and then report
+them as not defined anymore, but you shoudln'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.
+
+This counterintuitive behaviour of 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 value from its hash array. Returns the deleted
-value, or the undefined value if nothing was deleted. Deleting from
-C<$ENV{}> modifies the environment. Deleting from an array tied to a DBM
-file deletes the entry from the DBM file. (But deleting from a tie()d
-hash doesn't necessarily return anything.)
+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 tie()d hash
+doesn't necessarily return anything.)
-The following deletes all the values of an associative array:
+The following deletes all the values of a hash:
- foreach $key (keys %ARRAY) {
- delete $ARRAY{$key};
+ foreach $key (keys %HASH) {
+ delete $HASH{$key};
}
-(But it would be faster to use the undef() command.) Note that the
-EXPR can be arbitrarily complicated as long as the final operation is
-a hash key lookup:
+And so does this:
+
+ delete @HASH{keys %HASH}
+
+(But both of these are slower than the undef() command.) 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 of an eval(), prints the value of LIST to C<STDERR> and exits with
-the current value of $! (errno). If $! is 0, exits with the value of
-C<($? E<gt>E<gt> 8)> (backtick `command` status). If C<($? E<gt>E<gt> 8)> is 0,
-exits with 255. Inside an eval(), the error message is stuffed into C<$@>,
-and the eval() is terminated with the undefined value; this makes die()
-the way to raise an exception.
+the current value of C<$!> (errno). If C<$!> is 0, exits with the value of
+C<($? E<gt>E<gt> 8)> (backtick `command` status). If C<($? E<gt>E<gt> 8)>
+is 0, exits with 255. Inside an eval(), the error message is stuffed into
+C<$@>, and the eval() is terminated with the undefined value; this makes
+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"
+ 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
@@ -707,6 +810,29 @@ produce, respectively
See also exit() and warn().
+If LIST is empty and $@ already contains a value (typically from a
+previous eval) that value is reused after appending "\t...propagated".
+This is useful for propagating exceptions:
+
+ eval { ... };
+ die unless $@ =~ /Expected exception/;
+
+If $@ is empty then the string "Died" is used.
+
+You can arrange for a callback to be called just before the 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 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
@@ -728,7 +854,7 @@ from a Perl subroutine library.
is just like
- eval `cat stat.pl`;
+ scalar eval `cat stat.pl`;
except that it's more efficient, more concise, keeps track of the
current filename for error messages, and searches all the B<-I>
@@ -774,19 +900,27 @@ Example:
QUICKSTART:
Getopt('f');
-=item each ASSOC_ARRAY
+=item each HASH
+
+When called in a list context, returns a 2-element array consisting of the
+key and value for the next element of a hash, so that you can iterate over
+it. When called in a scalar context, returns the key for only the next
+element in the hash. (Note: Keys may be "0" or "", 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 (0) value), and C<undef> is returned in a
+scalar context. The next call to each() after that will start iterating
+again. There is a single iterator for each hash, shared by all each(),
+keys(), and 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.
-Returns a 2-element array consisting of the key and value for the next
-value of an associative array, so that you can iterate over it.
-Entries are returned in an apparently random order. When the array is
-entirely read, a null array is returned (which when assigned produces a
-FALSE (0) value). The next call to each() after that will start
-iterating again. The iterator can be reset only by reading all the
-elements from the array. You should not add elements to an array while
-you're iterating over it. There is a single iterator for each
-associative array, shared by all each(), keys() and values() function
-calls in the program. The following prints out your environment like
-the printenv(1) program, only in a different order:
+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";
@@ -809,11 +943,11 @@ 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.
-Empty parentheses () may be used to indicate
-the pseudofile formed of the files listed on the command line, i.e.
-C<eof()> is reasonable to use inside a 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:
+Empty parentheses () may be used to indicate 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 (<>) {
@@ -832,7 +966,7 @@ test I<EACH> file in a while (E<lt>E<gt>) loop. Examples:
}
Practical hint: you almost never need to use C<eof> in Perl, because the
-input operators return undef when they run out of data.
+input operators return undef when they run out of data.
=item eval EXPR
@@ -840,17 +974,22 @@ input operators return undef when they run out of data.
EXPR is parsed and executed as if it were a little Perl program. It
is executed in the context of the current Perl program, so that any
-variable settings, subroutine or format definitions remain afterwards.
+variable settings or subroutine and format definitions remain afterwards.
The value returned is the value of the last expression evaluated, or a
-return statement may be used, just as with subroutines.
+return statement may be used, just as with subroutines. The last
+expression is evaluated in scalar or array context, depending on the
+context of the eval.
If there is a syntax error or runtime error, or a die() statement is
executed, an undefined value is returned by eval(), and C<$@> is set to the
error message. If there was no error, C<$@> is guaranteed to be a null
-string. If EXPR is omitted, evaluates $_. The final semicolon, if
-any, may be omitted from the expression.
+string. If EXPR is omitted, evaluates C<$_>. The final semicolon, if
+any, may be omitted from the expression. Beware that using 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 warn() and L<perlvar>.
-Note that, since eval() traps otherwise-fatal errors, it is useful for
+Note that, because eval() traps otherwise-fatal errors, it is useful for
determining whether a particular feature (such as socket() or symlink())
is implemented. It is also Perl's exception trapping mechanism, where
the die operator is used to raise exceptions.
@@ -860,7 +999,7 @@ 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 non-fatal
+ # make divide-by-zero nonfatal
eval { $answer = $a / $b; }; warn $@ if $@;
# same thing, but less efficient
@@ -872,7 +1011,25 @@ Examples:
# a run-time error
eval '$answer ='; # sets $@
-With an eval(), you should be especially careful to remember what's
+When using the 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
+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 foofs here" };
+ print $@ if $@; # prints "bar barfs here"
+ }
+
+With an eval(), you should be especially careful to remember what's
being looked at when:
eval $x; # CASE 1
@@ -884,28 +1041,34 @@ being looked at when:
eval "\$$x++" # CASE 5
$$x++; # CASE 6
-Cases 1 and 2 above behave identically: they run the code contained in the
-variable $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 <$x>, which does
-nothing at all. (Case 4 is preferred for purely visual reasons.) Case 5
-is a place where normally you I<WOULD> like to use double quotes, except
-that in that particular situation, you can just use symbolic references
-instead, as in case 6.
+Cases 1 and 2 above behave identically: they run the code contained in
+the variable $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 '$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
-The exec() function executes a system command I<AND NEVER RETURNS>. Use
-the system() function if you want it to return.
+The exec() function executes a system command I<AND NEVER RETURNS> -
+use system() instead of 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).
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, the argument is checked for shell
-metacharacters. If there are any, the entire argument is passed to
-C</bin/sh -c> for parsing. If there are none, the argument is split
-into words and passed directly to execvp(), which is more efficient.
-Note: exec() and system() do not flush your output buffer, so you may
-need to set C<$|> to avoid lost output. Examples:
+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 execvp(), which is more efficient. Note: exec() and
+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";
@@ -914,7 +1077,7 @@ 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 multi-valued list, even if there is only a single scalar in
+LIST as a multivalued list, even if there is only a single scalar in
the list.) Example:
$shell = '/bin/csh';
@@ -924,6 +1087,10 @@ 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.
+
=item exists EXPR
Returns TRUE if the specified hash key exists in its hash array, even
@@ -933,7 +1100,7 @@ if the corresponding value is undefined.
print "Defined\n" if defined $array{$key};
print "True\n" if $array{$key};
-A hash element can only be TRUE if it's defined, and defined if
+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
@@ -951,11 +1118,20 @@ are called before exit.) Example:
$ans = <STDIN>;
exit 0 if $ans =~ /^[Xx]/;
-See also die(). If EXPR is omitted, exits with 0 status.
+See also die(). If EXPR is omitted, exits with 0 status. The only
+universally portable values for EXPR are 0 for success and 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 exit() to abort a subroutine if there's any chance that
+someone might want to trap whatever error happened. Use die() instead,
+which can be trapped by an eval().
=item exp EXPR
-Returns I<e> (the natural logarithm base) to the power of 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
@@ -980,31 +1156,50 @@ value is taken as the name of the filehandle.
=item flock FILEHANDLE,OPERATION
-Calls flock(2) on FILEHANDLE. See L<flock(2)> for definition of
-OPERATION. Returns TRUE for success, FALSE on failure. Will produce a
-fatal error if used on a machine that doesn't implement either flock(2) or
-fcntl(2). The fcntl(2) system call will be automatically used if flock(2)
-is missing from your system. This makes flock() the portable file locking
-strategy, although it will only lock entire files, not records. Note also
-that some versions of flock() cannot lock things over the network; you
-would need to use the more system-specific fcntl() for that.
+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). flock()
+is Perl's portable file locking interface, although it locks only entire
+files, not records.
+
+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 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 flock() cannot lock things over the
+network; you would need to use the more system-specific 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.
- $LOCK_SH = 1;
- $LOCK_EX = 2;
- $LOCK_NB = 4;
- $LOCK_UN = 8;
+ use Fcntl ':flock'; # import LOCK_* constants
sub lock {
- flock(MBOX,$LOCK_EX);
+ flock(MBOX,LOCK_EX);
# and, in case someone appended
# while we were waiting...
seek(MBOX, 0, 2);
}
sub unlock {
- flock(MBOX,$LOCK_UN);
+ flock(MBOX,LOCK_UN);
}
open(MBOX, ">>/usr/spool/mail/$ENV{'USER'}")
@@ -1021,15 +1216,15 @@ See also L<DB_File> for other flock() examples.
Does a fork(2) system call. Returns the child pid to the parent process
and 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
-autoflush() FileHandle method to avoid duplicate output.
+you may need to set C<$|> ($AUTOFLUSH in English) or call the autoflush()
+method of IO::Handle to avoid duplicate output.
If you 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
+There's also the double-fork trick (error checking on
fork() returns omitted);
unless ($pid = fork) {
@@ -1047,25 +1242,30 @@ fork() returns omitted);
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, the remote server (such as, say, httpd or rsh) won't think
+you're done. You should reopen those to /dev/null if it's any issue.
+
=item format
Declare a picture format with use by the write() function. For
example:
- format Something =
+ format Something =
Test: @<<<<<<<< @||||| @>>>>>
$str, $%, '$' . int($num)
.
$str = "widget";
- $num = $cost/$quantiy;
+ $num = $cost/$quantity;
$~ = 'Something';
write;
See L<perlform> for many details and examples.
-=item formline PICTURE, LIST
+=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
@@ -1080,7 +1280,7 @@ 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, since an "C<@>"
+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.
formline() always returns TRUE. See L<perlform> for other examples.
@@ -1097,7 +1297,7 @@ single-characters, however. For that, try something more like:
system "stty cbreak </dev/tty >/dev/tty 2>&1";
}
else {
- system "stty", '-icanon', 'eol', "\001";
+ system "stty", '-icanon', 'eol', "\001";
}
$key = getc(STDIN);
@@ -1106,24 +1306,26 @@ single-characters, however. For that, try something more like:
system "stty -cbreak </dev/tty >/dev/tty 2>&1";
}
else {
- system "stty", 'icanon', 'eol', '^@'; # ascii null
+ system "stty", 'icanon', 'eol', '^@'; # ASCII null
}
print "\n";
-Determination of whether to whether $BSD_STYLE should be set
-is left as an exercise to the reader.
+Determination of whether $BSD_STYLE should be set
+is left as an exercise to the reader.
+The POSIX::getattr() function can do this more portably on systems
+alleging POSIX compliance.
See also the C<Term::ReadKey> module from your nearest CPAN site;
-details on CPAN can be found on L<perlmod/CPAN>
+details on CPAN can be found on L<perlmod/CPAN>.
=item getlogin
Returns the current login from F</etc/utmp>, if any. If null, use
-getpwuid().
+getpwuid().
- $login = getlogin || (getpwuid($<))[0] || "Kilroy";
+ $login = getlogin || getpwuid($<) || "Kilroy";
-Do not consider getlogin() for authorentication: it is not as
+Do not consider getlogin() for authentication: it is not as
secure as getpwuid().
=item getpeername SOCKET
@@ -1138,10 +1340,12 @@ Returns the packed sockaddr address of other end of the SOCKET connection.
=item getpgrp PID
-Returns the current process group for the specified PID, 0 for the
+Returns the current process group for the specified PID. Use
+a PID of 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.
+group of current process. Note that the POSIX version of getpgrp()
+does not accept a PID argument, so only PID==0 is truly portable.
=item getppid
@@ -1265,23 +1469,37 @@ Returns the socket option requested, or undefined if there is an error.
=item glob EXPR
-Returns the value of EXPR with filename expansions such as a shell
-would do. This is the internal function implementing the <*.*>
-operator, except it's easier to use.
+=item glob
+
+Returns the value of EXPR with filename expansions such as a shell 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, $_ 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 timezone.
+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 $mon has the range 0..11 and $wday has
-the range 0..6. If EXPR is omitted, does C<gmtime(time())>.
+the range 0..6 with sunday as day 0. Also, $year is the number of
+years since 1900, I<not> simply the last two digits of the year.
+
+If EXPR is omitted, does C<gmtime(time())>.
+
+In a scalar context, returns the ctime(3) value:
+
+ $now_string = gmtime; # e.g., "Thu Oct 13 04:54:34 1994"
+
+Also see the timegm() function provided by the Time::Local module,
+and the strftime(3) function available via the POSIX module.
=item goto LABEL
@@ -1292,8 +1510,9 @@ the range 0..6. If EXPR is omitted, does C<gmtime(time())>.
The 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 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,
+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 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 last or die. The author of Perl has never felt the
need to use this form of goto (in Perl, that is--C is another matter).
@@ -1316,6 +1535,10 @@ will be able to tell that this routine was called first.
=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
$_ to each element) and returns the list value consisting of those
elements for which the expression evaluated to TRUE. In a scalar
@@ -1327,23 +1550,33 @@ or equivalently,
@foo = grep {!/^#/} @bar; # weed out comments
-Note that, since $_ is a reference into the list value, it can be used
+Note that, because $_ 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.
+array. Similarly, grep returns aliases into the original list,
+much like the way that L<Foreach Loops>'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
-Interprets EXPR as a hex string and returns the corresponding decimal
-value. (To convert strings that might start with 0 or 0x see
-oct().) If EXPR is omitted, uses $_.
+=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 $_.
+
+ print hex '0xAf'; # prints '175'
+ print hex 'aF'; # same
=item import
-There is no built-in import() function. It is merely an ordinary
+There is no builtin import() function. It is merely an ordinary
method (subroutine) defined (or inherited) by modules that wish to export
names to another module. The use() function calls the import() method
-for the package used. See also L</use>, L<perlmod>, and L<Exporter>.
+for the package used. See also L</use()>, L<perlmod>, and L<Exporter>.
=item index STR,SUBSTR,POSITION
@@ -1351,12 +1584,14 @@ for the package used. See also L</use>, L<perlmod>, and L<Exporter>.
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 0 (or whatever you've set the $[
+the string. The return value is based at 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 -1.
=item int EXPR
+=item int
+
Returns the integer portion of EXPR. If EXPR is omitted, uses $_.
=item ioctl FILEHANDLE,FUNCTION,SCALAR
@@ -1369,7 +1604,7 @@ 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 which
-may help you in this, but it's non-trivial.) SCALAR will be read and/or
+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 ioctl call. (If SCALAR
has no string value but does have a numeric value, that value will be
@@ -1406,7 +1641,7 @@ system:
=item join EXPR,LIST
-Joins the separate strings of LIST or ARRAY into a single string with
+Joins the separate strings of LIST into a single string with
fields separated by the value of EXPR, and returns the string.
Example:
@@ -1414,14 +1649,15 @@ Example:
See L<perlfunc/split>.
-=item keys ASSOC_ARRAY
+=item keys HASH
-Returns a normal array consisting of all the keys of the named
-associative array. (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 values() or each() function produces (given that
-the associative array has not been modified). Here is yet another way
-to print your environment:
+Returns a normal array 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
+values() or 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;
@@ -1435,17 +1671,31 @@ or how about sorted by key:
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:
+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. 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
+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;
@@ -1455,7 +1705,7 @@ 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 the L<perlipc/"Signals"> man page for details.
+use a signal name in quotes. See L<perlipc/"Signals"> for details.
=item last LABEL
@@ -1473,18 +1723,28 @@ C<continue> block, if any, is not executed:
=item lc EXPR
+=item lc
+
Returns an lowercased version of EXPR. This is the internal function
-implementing the \L escape in double-quoted strings.
-Should respect any POSIX setlocale() settings.
+implementing the \L escape in double-quoted strings.
+Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>.
+
+If EXPR is omitted, uses $_.
=item lcfirst EXPR
+=item lcfirst
+
Returns the value of EXPR with the first character lowercased. This is
the internal function implementing the \l escape in double-quoted strings.
-Should respect any POSIX setlocale() settings.
+Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>.
+
+If EXPR is omitted, uses $_.
=item length EXPR
+=item length
+
Returns the length in characters of the value of EXPR. If EXPR is
omitted, returns length of $_.
@@ -1501,9 +1761,9 @@ it succeeded, FALSE otherwise. See example in L<perlipc/"Sockets: Client/Server
=item local EXPR
A local modifies the listed variables to be local to the enclosing block,
-subroutine, C<eval{}> or C<do>. If more than one value is listed, the
-list must be placed in parens. See L<perlsub/"Temporary Values via
-local()"> for details.
+subroutine, C<eval{}>, or C<do>. 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.
But you really probably want to be using my() instead, because local() isn't
what most people think of as "local"). See L<perlsub/"Private Variables
@@ -1512,25 +1772,33 @@ 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 timezone. Typically used as
+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 $mon has the range 0..11 and $wday has
-the range 0..6. If EXPR is omitted, does localtime(time).
+the range 0..6 with sunday as day 0. Also, $year is the number of
+years since 1900, that is, $year is 123 in year 2023.
-In a scalar context, prints out the ctime(3) value:
+If EXPR is omitted, uses the current time (C<localtime(time)>).
- $now_string = localtime; # e.g. "Thu Oct 13 04:54:34 1994"
+In a scalar context, returns the ctime(3) value:
-Also see the F<timelocal.pl> library, and the strftime(3) function available
-via the POSIX modulie.
+ $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 Time::Local module, and the strftime(3) and mktime(3)
+function available via the POSIX module.
=item log EXPR
+=item log
+
Returns logarithm (base I<e>) of EXPR. If EXPR is omitted, returns log
of $_.
@@ -1538,10 +1806,14 @@ of $_.
=item lstat EXPR
+=item lstat
+
Does the same thing as the stat() function, but stats a symbolic link
instead of the file the symbolic link points to. If symbolic links are
unimplemented on your system, a normal stat() is done.
+If EXPR is omitted, stats $_.
+
=item m//
The match operator. See L<perlop>.
@@ -1568,11 +1840,17 @@ is just a funny way to write
$hash{getkey($_)} = $_;
}
+Note that, because $_ 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 1, otherwise
-it returns 0 and sets $! (errno).
+it returns 0 and sets C<$!> (errno).
=item msgctl ID,CMD,ARG
@@ -1606,7 +1884,7 @@ an error.
A "my" declares the listed variables to be local (lexically) to the
enclosing block, subroutine, C<eval>, or C<do/require/use>'d file. If
-more than one value is listed, the list must be placed in parens. See
+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
@@ -1631,42 +1909,54 @@ See the "use" function, which "no" is the opposite of.
=item oct EXPR
+=item oct
+
Interprets EXPR as an octal string and returns the corresponding
-decimal value. (If EXPR happens to start off with 0x, interprets it as
+value. (If EXPR happens to start off with 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 $_.
+If EXPR is omitted, uses $_. This function is commonly used when
+a string such as "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. If the filename
-begins with "<" or nothing, the file is opened for input. If the filename
-begins with ">", the file is opened for output. If the filename begins
-with ">>", the file is opened for appending. You can put a '+' in front
-of the '>' or '<' to indicate that you want both read and write access to
-the file; thus '+<' is usually preferred for read/write updates--the '+>'
-mode would clobber the file first. These correspond to the fopen(3) modes
-of 'r', 'r+', 'w', 'w+', 'a', and 'a+'.
-
-If the filename begins with "|", the filename is interpreted
-as a command to which output is to be piped, and if the filename ends with
-a "|", the filename is interpreted See L<perlipc/"Using open() for IPC">
-for more examples of this. as command which pipes input to us. (You may
-not have a raw open() to a command that pipes both in I<and> out, but see See L<open2>,
-L<open3>, and L<perlipc/"Bidirectional Communication"> for alternatives.)
-
-Opening '-' opens STDIN and opening '>-' opens STDOUT. Open returns
-non-zero upon success, the undefined value otherwise. If the open
+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 '<' or nothing, the file is opened for input.
+If the filename begins with '>', the file is truncated and opened for
+output. If the filename begins with '>>', the file is opened for
+appending. You can put a '+' in front of the '>' or '<' to indicate that
+you want both read and write access to the file; thus '+<' is almost
+always preferred for read/write updates--the '+>' mode would clobber the
+file first. The prefix and the filename may be separated with spaces.
+These various prefixes correspond to the fopen(3) modes of 'r', 'r+', 'w',
+'w+', 'a', and 'a+'.
+
+If the filename begins with "|", the filename is interpreted as a command
+to which output is to be piped, and if the filename ends with a "|", the
+filename is interpreted See L<perlipc/"Using open() for IPC"> for more
+examples of this. as command which pipes input to us. (You may not have
+a raw 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 '-' opens STDIN and opening 'E<gt>-' opens STDOUT. Open returns
+nonzero upon success, the undefined value otherwise. If the open
involved a pipe, the return value happens to be the pid of the
-subprocess.
+subprocess.
If you're unfortunate enough to be running Perl on a system that
distinguishes between text files and binary files (modern operating
@@ -1676,6 +1966,14 @@ and those that don't is their text file formats. Systems like Unix and
Plan9 that delimit lines with a single character, and that encode that
character in C as '\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 which 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;
@@ -1683,12 +1981,16 @@ Examples:
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
+ open(DBASE, '+<dbase.mine') # open for update
+ or die "Can't open 'dbase.mine' for update: $!";
- open(ARTICLE, "caesar <$article |"); # decrypt article
+ open(ARTICLE, "caesar <$article |") # decrypt article
+ or die "Can't start caesar: $!";
- open(EXTRACT, "|sort >/tmp/Tmp$$"); # $$ is our process id
+ open(EXTRACT, "|sort >/tmp/Tmp$$") # $$ is our process id
+ or die "Can't start sort: $!";
# process argument list of files along with any includes
@@ -1714,11 +2016,12 @@ Examples:
}
You may also, in the Bourne shell tradition, specify an EXPR beginning
-with ">&", in which case the rest of the string is interpreted as the
+with "E<gt>&", in which case the rest of the string is interpreted as the
name of a filehandle (or file descriptor, if numeric) which is to be
-duped and opened. You may use & after >, >>, <, +>, +>> and +<. The
+duped and opened. You may use & after E<gt>, E<gt>E<gt>, E<lt>, +E<gt>,
++E<gt>E<gt>, and +E<lt>. The
mode you specify should match the mode of the original filehandle.
-(Duping a filehandle does not take into acount any existing contents of
+(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:
@@ -1746,23 +2049,23 @@ STDERR:
print STDERR "stderr 2\n";
-If you specify "<&=N", where N is a number, then Perl will do an
+If you specify "E<lt>&=N", where N is a number, then Perl will do an
equivalent of C's 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 "-", i.e. either "|-" or "-|", then
+If you open a pipe on the command "-", i.e., either "|-" or "-|", then
there is an implicit fork done, and the return value of open is the pid
of the child within the parent process, and 0 within the child
-process. (Use defined($pid) to determine whether the open was successful.)
+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.
+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]'");
@@ -1773,22 +2076,24 @@ The following pairs are more or less equivalent:
See L<perlipc/"Safe Pipe Opens"> for more examples of this.
-Explicitly closing any piped filehandle causes the parent process to
-wait for the child to finish, and returns the status value in $?.
-Note: on any operation which may do a fork, unflushed buffers remain
-unflushed in both processes, which means you may need to set $| to
+NOTE: On any operation which may do a fork, unflushed buffers remain
+unflushed in both processes, which means you may need to set C<$|> to
avoid duplicate output.
-Using the FileHandle constructor from the FileHandle package,
+Closing any piped filehandle causes the parent process to wait for the
+child to finish, and returns the status value in C<$?>.
+
+Using the constructor from the IO::Handle package (or one of its
+subclasses, such as IO::File or IO::Socket),
you can generate anonymous filehandles which have the scope of whatever
variables hold references to them, and automatically close whenever
and however you leave that scope:
- use FileHandle;
+ use IO::File;
...
sub read_myfile_munged {
my $ALL = shift;
- my $handle = new FileHandle;
+ my $handle = new IO::File;
open($handle, "myfile") or die "myfile: $!";
$first = <$handle>
or return (); # Automatically closed here.
@@ -1798,7 +2103,7 @@ and however you leave that scope:
}
The filename that is passed to open will have leading and trailing
-whitespace deleted. In order to open a file with arbitrary weird
+whitespace deleted. To open a file with arbitrary weird
characters in it, it's necessary to protect any leading and trailing
whitespace thusly:
@@ -1809,7 +2114,7 @@ If you want a "real" C open() (see L<open(2)> on your system), then
you should use the sysopen() function. This is another way to
protect your filenames from interpretation. For example:
- use FileHandle;
+ use IO::Handle;
sysopen(HANDLE, $path, O_RDWR|O_CREAT|O_EXCL, 0700)
or die "sysopen $path: $!";
HANDLE->autoflush(1);
@@ -1822,13 +2127,15 @@ See L</seek()> for some details about mixing reading and writing.
=item opendir DIRHANDLE,EXPR
Opens a directory named EXPR for processing by readdir(), telldir(),
-seekdir(), rewinddir() and closedir(). Returns TRUE if successful.
+seekdir(), rewinddir(), and 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 $_.
+EXPR is omitted, uses $_. For the reverse, see L</chr>.
=item pack TEMPLATE,LIST
@@ -1846,17 +2153,29 @@ follows:
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" order.
- N A long in "network" order.
+ 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.
@@ -1866,20 +2185,30 @@ follows:
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 which gives a repeat
-count. With all types except "a", "A", "b", "B", "h" and "H", and "P" the
+count. With all types except "a", "A", "b", "B", "h", "H", and "P" the
pack function will gobble up that many values from the LIST. A * for the
repeat count means to use however many items are left. The "a" and "A"
types gobble just one value, but pack it as a string of length count,
padding with nulls or spaces as necessary. (When unpacking, "A" strips
trailing spaces and nulls, but "a" does not.) Likewise, the "b" and "B"
fields pack a string that many bits long. The "h" and "H" fields pack a
-string that many nybbles long. The "P" packs a pointer to a structure of
-the size indicated by the length. Real numbers (floats and doubles) are
+string that many nybbles long. The "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 "P" packs a pointer to a structure
+of the size indicated by the length. A NULL pointer is created if the
+corresponding value for "p" or "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
@@ -1887,7 +2216,7 @@ 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.
+float and thence back to double again will lose precision (i.e.,
C<unpack("f", pack("f", $foo)>) will not in general equal $foo).
Examples:
@@ -1928,11 +2257,11 @@ 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 local() operator). All further
unqualified dynamic identifiers will be in this namespace. A package
-statement only affects dynamic variables--including those you've used
+statement affects only 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
+it influences merely 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>
@@ -1946,14 +2275,16 @@ and classes. See L<perlsub> for other scoping issues.
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 $| to flush your WRITEHANDLE
+stdio buffering, so you may need to set C<$|> to flush your WRITEHANDLE
after each command, depending on the application.
-See L<open2>, L<open3>, and L<perlipc/"Bidirectional Communication">
+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
@@ -1966,8 +2297,13 @@ like shift().
=item pos SCALAR
+=item pos
+
Returns the offset of where the last C<m//g> search left off for the variable
-in question. May be modified to change that offset.
+is in question ($_ 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
@@ -1980,9 +2316,9 @@ 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 + or put parens around the arguments.) If FILEHANDLE is
+interpose a + or put parentheses around the arguments.) If FILEHANDLE is
omitted, prints by default to standard output (or to the last selected
-output channel--see select()). If LIST is also omitted, prints $_ to
+output channel--see L</select>). If LIST is also omitted, prints $_ to
STDOUT. 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 a list context, and any
@@ -1990,20 +2326,32 @@ subroutine that you call will have one or more of its expressions
evaluated in a 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 + or
-put parens around all the arguments.
+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
+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 LIST
+=item printf FILEHANDLE FORMAT, LIST
+
+=item printf FORMAT, LIST
+
+Equivalent to C<print FILEHANDLE sprintf(FORMAT, LIST)>. The first argument
+of the list will be interpreted as the 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 printf() when a simple
+print() would do. The print() is more efficient, and less
+error prone.
-=item printf LIST
+=item prototype FUNCTION
-Equivalent to a "print FILEHANDLE sprintf(LIST)". The first argument
-of the list will be interpreted as the printf format.
+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.
=item push ARRAY,LIST
@@ -2029,25 +2377,29 @@ Generalized quotes. See L<perlop>.
=item quotemeta EXPR
-Returns the value of EXPR with with all regular expression
-metacharacters backslashed. This is the internal function implementing
+=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 \Q escape in double-quoted strings.
+If EXPR is omitted, uses $_.
+
=item rand EXPR
=item rand
-Returns a random fractional number between 0 and the value of EXPR.
-(EXPR should be positive.) If EXPR is omitted, returns a value between
-0 and 1. This function produces repeatable sequences unless srand()
-is invoked. See also srand().
+Returns a random fractional number greater than or equal to 0 and less
+than the value of EXPR. (EXPR should be positive.) If EXPR is
+omitted, the value 1 is used. Automatically calls srand() unless
+srand() has already been called. See also srand().
-(Note: if your rand function consistently returns numbers that are too
+(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. As a workaround, you can usually
-multiply EXPR by the correct power of 2 to get the range you want.
-This will make your script unportable, however. It's better to recompile
-if you can.)
+with the wrong number of RANDBITS.)
=item read FILEHANDLE,SCALAR,LENGTH,OFFSET
@@ -2069,20 +2421,43 @@ directory. If there are no more entries, returns an undefined value in
a scalar context or a null list in a list context.
If you're planning to filetest the return values out of a readdir(), you'd
-better prepend the directory in question. Otherwise, since we didn't
+better prepend the directory in question. Otherwise, because we didn't
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 file handle 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 $/ or $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">.
+
=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 $! (errno). If EXPR is
+error, returns the undefined value and sets C<$!> (errno). If EXPR is
omitted, uses $_.
+=item readpipe EXPR
+
+EXPR is interpolated and then 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 $/ or $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
@@ -2090,7 +2465,7 @@ data into variable SCALAR from the specified SOCKET filehandle.
Actually does a C recvfrom(), so that it can returns 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.
+as the system call of the same name.
See L<perlipc/"UDP: Message Passing"> for examples.
=item redo LABEL
@@ -2122,8 +2497,11 @@ themselves about what was just input:
=item ref EXPR
-Returns a TRUE value if EXPR is a reference, FALSE otherwise. The value
-returned depends on the type of thing the reference is a reference to.
+=item ref
+
+Returns a TRUE value if EXPR is a reference, FALSE otherwise. If EXPR
+is not specified, $_ will be used. The value returned depends on the
+type of thing the reference is a reference to.
Builtin types include:
REF
@@ -2133,22 +2511,22 @@ Builtin types include:
CODE
GLOB
-If the referenced object has been blessed into a package, then that package
+If the referenced object has been blessed into a package, then that package
name is returned instead. You can think of ref() as a typeof() operator.
if (ref($r) eq "HASH") {
- print "r is a reference to an associative array.\n";
- }
+ 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 1 for success, 0 otherwise. Will
-not work across filesystem boundaries.
+not work across file system boundaries.
=item require EXPR
@@ -2156,7 +2534,7 @@ not work across filesystem boundaries.
Demands some semantics specified by EXPR, or by $_ if EXPR is not
supplied. If EXPR is numeric, demands that the current version of Perl
-($] or $PERL_VERSION) be equal or greater than EXPR.
+(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
@@ -2190,11 +2568,12 @@ end such a file with "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 bare word, the require assumes a "F<.pm>" extension for you,
-to make it easy to load standard modules. This form of loading of
+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.
-For a yet-more-powerful import facility, see the L</use()> and
+For a yet-more-powerful import facility, see L</use> and
L<perlmod>.
=item reset EXPR
@@ -2206,36 +2585,52 @@ variables and reset ?? 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 (?pattern?) are reset to match again. Only
-resets variables or searches in the current package. Always returns
+omitted, one-match searches (?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 "A-Z" is not recommended since you'll wipe out your
-ARGV and ENV arrays. Only resets package variables--lexical variables
+Resetting "A-Z" is not recommended because you'll wipe out your
+ARGV and ENV arrays. Resets only package variables--lexical variables
are unaffected, but they clean themselves up on scope exit anyway,
-so anymore you probably want to use them instead. See L</my>.
+so you'll probably want to use them instead. See L</my>.
-=item return LIST
+=item return EXPR
-Returns from a subroutine or eval with the value specified. (Note that
-in the absence of a return a subroutine or eval() will automatically
-return the value of the last expression evaluated.)
+=item return
+
+Returns from a subroutine, eval(), or do FILE with the value of the
+given EXPR. Evaluation of EXPR may be in a 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 wantarray()). If no EXPR
+is given, returns an empty list in a list context, an undefined value in
+a 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 a list context, returns a list value consisting of the elements
-of LIST in the opposite order. In a scalar context, returns a string
-value consisting of the bytes of the first element of LIST in the
-opposite order.
+of LIST in the opposite order. In a 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
+ print reverse <>; # line tac, last line first
- undef $/;
- print scalar reverse scalar <>; # byte tac
+ 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
@@ -2252,8 +2647,10 @@ last occurrence at or before that position.
=item rmdir FILENAME
+=item rmdir
+
Deletes the directory specified by FILENAME if it is empty. If it
-succeeds it returns 1, otherwise it returns 0 and sets $! (errno). If
+succeeds it returns 1, otherwise it returns 0 and sets C<$!> (errno). If
FILENAME is omitted, uses $_.
=item s///
@@ -2263,11 +2660,11 @@ The substitution operator. See L<perlop>.
=item scalar EXPR
Forces EXPR to be interpreted in a scalar context and returns the value
-of EXPR.
+of EXPR.
@counts = ( scalar @a, scalar @b, scalar @c );
-There is no equivalent operator to force an expression to
+There is no equivalent operator to force an expression to
be interpolated in a 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
@@ -2275,26 +2672,30 @@ C<(some expression)> suffices.
=item seek FILEHANDLE,POSITION,WHENCE
-Randomly positions the file pointer for FILEHANDLE, just like the fseek()
-call of stdio. FILEHANDLE may be an expression whose value gives the name
-of the filehandle. The values for WHENCE are 0 to set the file pointer to
-POSITION, 1 to set the it to current plus POSITION, and 2 to set it to EOF
-plus offset. You may use the values SEEK_SET, SEEK_CUR, and SEEK_END for
-this from POSIX module. Returns 1 upon success, 0 otherwise.
+Sets FILEHANDLE's position, just like the fseek() call of stdio.
+FILEHANDLE may be an expression whose value gives the name of the
+filehandle. The values for WHENCE are 0 to set the new position to
+POSITION, 1 to set it to the current position plus POSITION, and 2 to
+set it to EOF plus POSITION (typically negative). For WHENCE you may
+use the constants SEEK_SET, SEEK_CUR, and SEEK_END from either the
+IO::Seekable or the POSIX module. Returns 1 upon success, 0 otherwise.
+
+If you want to position file for sysread() or syswrite(), don't use
+seek() -- buffering makes its effect on the file's system position
+unpredictable and non-portable. Use 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 1 (SEEK_CUR) is useful for not moving
-the file pointer:
+stdio's clearerr(3). A WHENCE of 1 (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. First the simple trick listed above to clear the
-filepointer. The 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. Hopefully.
+seek() to reset things. The 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:
@@ -2339,12 +2740,12 @@ actual filehandle. Thus:
Some programmers may prefer to think of filehandles as objects with
methods, preferring to write the last example as:
- use FileHandle;
+ use IO::Handle;
STDERR->autoflush(1);
=item select RBITS,WBITS,EBITS,TIMEOUT
-This calls the select(2) system call with the bitmasks specified, which
+This calls the select(2) system call with the bit masks specified, which
can be constructed using fileno() and vec(), along these lines:
$rin = $win = $ein = '';
@@ -2370,23 +2771,23 @@ The usual idiom is:
($nfound,$timeleft) =
select($rout=$rin, $wout=$win, $eout=$ein, $timeout);
-or to block until something becomes ready just do this
+or to block until something becomes ready just do this
$nfound = select($rout=$rin, $wout=$win, $eout=$ein, undef);
-Most systems do not both to return anything useful in $timeleft, so
+Most systems do not bother to return anything useful in $timeleft, so
calling select() in a scalar context just returns $nfound.
-Any of the bitmasks can also be undef. The timeout, if specified, is
+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 the $timeleft. If not, they always return
$timeleft equal to the supplied $timeout.
-You can effect a 250-microsecond sleep this way:
+You can effect a sleep of 250 milliseconds this way:
select(undef, undef, undef, 0.25);
-B<WARNING>: Do not attempt to mix buffered I/O (like read() or <FH>)
+B<WARNING>: Do not attempt to mix buffered I/O (like read() or E<lt>FHE<gt>)
with select(). You have to use sysread() instead.
=item semctl ID,SEMNUM,CMD,ARG
@@ -2432,7 +2833,9 @@ See L<perlipc/"UDP: Message Passing"> for examples.
Sets the current process group for the specified PID, 0 for the current
process. Will produce a fatal error if used on a machine that doesn't
-implement setpgrp(2).
+implement setpgrp(2). If the arguments are omitted, it defaults to
+0,0. Note that the POSIX version of setpgrp() does not accept any
+arguments, so only setpgrp 0,0 is portable.
=item setpriority WHICH,WHO,PRIORITY
@@ -2456,7 +2859,7 @@ array, returns the undefined value. If ARRAY is omitted, shifts the
@ARGV array in the main program, and the @_ array in subroutines.
(This is determined lexically.) See also unshift(), push(), and pop().
Shift() and unshift() do the same thing to the left end of an array
-that push() and pop() do to the right end.
+that pop() and push() do to the right end.
=item shmctl ID,CMD,ARG
@@ -2488,9 +2891,16 @@ has the same interpretation as in the system call of the same name.
=item sin EXPR
+=item sin
+
Returns the sine of EXPR (expressed in radians). If EXPR is omitted,
returns sine of $_.
+For the inverse sine operation, you may use the POSIX::asin()
+function, or use this relation:
+
+ sub asin { atan2($_[0], sqrt(1 - $_[0] * $_[0])) }
+
=item sleep EXPR
=item sleep
@@ -2498,27 +2908,29 @@ returns sine of $_.
Causes the script to sleep for EXPR seconds, or forever if no EXPR.
May be interrupted by sending the process a SIGALRM. Returns the
number of seconds actually slept. You probably cannot mix alarm() and
-sleep() calls, since sleep() is often implemented using alarm().
+sleep() calls, because sleep() is often implemented using 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.
For delays of finer granularity than one second, you may use Perl's
-syscall() interface to access setitimer(2) if your system supports it,
-or else see L</select()> below.
+syscall() interface to access setitimer(2) if your system supports it,
+or else see L</select()> below.
+
+See also the POSIX module's 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
+SOCKET. DOMAIN, TYPE, and PROTOCOL are specified the same as for the
system call of the same name. You should "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
+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.
@@ -2528,16 +2940,15 @@ error. Returns TRUE if successful.
=item sort LIST
-Sorts the LIST and returns the sorted list value. Nonexistent values
-of arrays are stripped out. If SUBNAME or BLOCK is omitted, sorts
-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 0, depending on how the elements of the array are
-to be ordered. (The <=> and cmp operators are extremely useful in such
-routines.) SUBNAME may be a scalar variable name, in which case the
-value provides the name of the subroutine to use. In place of a
-SUBNAME, you can provide a BLOCK as an anonymous, in-line sort
-subroutine.
+Sorts the LIST and returns the sorted list value. If SUBNAME or BLOCK
+is omitted, sorts 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 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, in which case the value provides the name of the
+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
@@ -2546,6 +2957,12 @@ the subroutine not via @_ but as the package global variables $a and
$b (see example below). They are passed by reference, so don't
modify $a and $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 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
@@ -2555,7 +2972,7 @@ Examples:
@articles = sort {$a cmp $b} @files;
# now case-insensitively
- @articles = sort { uc($a) cmp uc($b)} @files;
+ @articles = sort {uc($a) cmp uc($b)} @files;
# same thing in reversed order
@articles = sort {$b cmp $a} @files;
@@ -2568,12 +2985,12 @@ Examples:
# sort using explicit subroutine name
sub byage {
- $age{$a} <=> $age{$b}; # presuming integers
+ $age{$a} <=> $age{$b}; # presuming numeric
}
@sortedclass = sort byage @class;
- # this sorts the %age associative arrays by value
- # instead of key using an inline function
+ # 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; }
@@ -2586,8 +3003,8 @@ Examples:
print sort @george, 'to', @harry;
# prints AbelAxedCainPunishedcatchaseddoggonetoxyz
- # inefficiently sort by descending numeric compare using
- # the first integer after the first = sign, or the
+ # inefficiently sort by descending numeric compare using
+ # the first integer after the first = sign, or the
# whole record case-insensitively otherwise
@new = sort {
@@ -2600,10 +3017,10 @@ Examples:
# we'll build auxiliary indices instead
# for speed
@nums = @caps = ();
- for (@old) {
+ for (@old) {
push @nums, /=(\d+)/;
push @caps, uc($_);
- }
+ }
@new = @old[ sort {
$nums[$b] <=> $nums[$a]
@@ -2619,7 +3036,7 @@ Examples:
$a->[2] cmp $b->[2]
} map { [$_, /=(\d+)/, uc($_)] } @old;
-If you're and using strict, you I<MUST NOT> declare $a
+If you're using strict, you I<MUST NOT> declare $a
and $b as lexicals. They are package globals. That means
if you're in the C<main> package, it's
@@ -2633,6 +3050,13 @@ 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 $x[1] is less than $x[2] and
+sometimes saying the opposite, for example) the Perl interpreter will
+probably crash and dump core. This is entirely due to and dependent
+upon your system's qsort(3) library routine; this routine often avoids
+sanity checks in the interest of speed.
+
=item splice ARRAY,OFFSET,LENGTH,LIST
=item splice ARRAY,OFFSET,LENGTH
@@ -2643,7 +3067,7 @@ Removes the elements designated by OFFSET and LENGTH from an array, and
replaces them with the elements of LIST, if any. Returns the elements
removed from the array. The array grows or shrinks as necessary. If
LENGTH is omitted, removes everything from OFFSET onward. The
-following equivalencies hold (assuming $[ == 0):
+following equivalences hold (assuming C<$[ == 0>):
push(@a,$x,$y) splice(@a,$#a+1,0,$x,$y)
pop(@a) splice(@a,-1)
@@ -2682,12 +3106,13 @@ value.) The use of implicit split to @_ is deprecated, however.
If EXPR is omitted, splits the $_ 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 is not negative, splits into no more than that many fields
-(though it may split into fewer). If LIMIT is unspecified, trailing null
-fields are stripped (which potential users of pop() would do well to
-remember). If LIMIT is negative, it is treated as if an arbitrarily large
-LIMIT had been specified.
+that the delimiter may be longer than one character.)
+
+If LIMIT is specified and is not negative, splits into no more than
+that many fields (though it may split into fewer). If LIMIT is
+unspecified, trailing null fields are stripped (which potential users
+of 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
@@ -2698,7 +3123,7 @@ characters at each point it matches that way. For example:
produces the output 'h:i:t:h:e:r:e'.
-The LIMIT parameter can be used to partially split a line
+The LIMIT parameter can be used to split a line partially
($login, $passwd, $remainder) = split(/:/, $_, 3);
@@ -2711,17 +3136,17 @@ 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");
+ 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 $header,
+If you had the entire header of a normal Unix email message in $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*/m, $header);
+ %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,
@@ -2739,66 +3164,167 @@ Example:
open(passwd, '/etc/passwd');
while (<passwd>) {
- ($login, $passwd, $uid, $gid, $gcos,
+ ($login, $passwd, $uid, $gid, $gcos,
$home, $shell) = split(/:/);
...
}
-(Note that $shell above will still have a newline on it. See L</chop>,
+(Note that $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 printf conventions of the C
-language. See L<sprintf(3)> or L<printf(3)> on your system for details.
-(The * character for an indirectly specified length is not
-supported, but you can get the same effect by interpolating a variable
-into the pattern.) Some C libraries' implementations of sprintf() can
-dump core when fed ludicrous arguments.
+=item sprintf FORMAT, LIST
+
+Returns a string formatted by the usual printf conventions of the
+C library function sprintf(). See L<sprintf(3)> or L<printf(3)>
+on your system for an explanation of the general principles.
+
+Perl does all of its own sprintf() formatting -- it emulates the C
+function 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 sprintf() are not
+available from Perl.
+
+Perl's 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 octal with "0", 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 ("*") 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.
+
+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 $_.
=item srand EXPR
-Sets the random number seed for the C<rand> operator. If EXPR is omitted,
-does C<srand(time)>. Many folks use an explicit C<srand(time ^ $$)>
-instead. Of course, you'd need something much more random than that for
-cryptographic purposes, since it's easy to guess the current time.
-Checksumming the compressed output of rapidly changing operating system
-status programs is the usual method. Examples are posted regularly to
-the comp.security.unix newsgroup.
+=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 time(). This isn't a particularly good seed,
+so many old programs supply their own seed value (often C<time ^ $$> or
+C<time ^ ($$ + ($$ << 15))>), but that isn't necessary any more.
+
+In fact, it's usually not necessary to call 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 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 Math::TrulyRandom
+module in CPAN.
+
+Do I<not> call 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 rand() function so that 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 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 array giving the status info for a file, either the
-file opened via FILEHANDLE, or named by EXPR. Returns a null list if
-the stat fails. Typically used as follows:
+file opened via FILEHANDLE, or named by EXPR. If EXPR is omitted, it
+stats $_. 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
+Not all fields are supported on all filesystem types. Here are the
meaning of the fields:
- dev device number of filesystem
- ino inode number
- mode file mode (type and permissions)
- nlink number of (hard) links to the file
- uid numeric user ID of file's owner
- gid numer group ID of file's owner
- rdev the device identifier (special files only)
- size total size of file, in bytes
- atime last access time since the epoch
- mtime last modify time since the epoch
- ctime inode change time (NOT creation type!) since the epoch
- blksize preferred blocksize for file system I/O
- blocks actual number of blocks allocated
+ 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.)
@@ -2810,21 +3336,21 @@ last stat or filetest are returned. Example:
print "$file is executable NFS file\n";
}
-(This only works on machines for which the device number is negative under NFS.)
+(This works on machines only for which the device number is negative under NFS.)
=item study SCALAR
=item study
-Takes extra time to study SCALAR ($_ if unspecified) in anticipation of
+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
-runtimes with and without it to see which runs faster. Those loops
+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 study active at a time--if you study a different scalar the first
+one study active at a time -- if you study a different scalar the first
is "unstudied". (The way 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 'k' characters are. From each search string,
@@ -2855,7 +3381,7 @@ runtime, you can build an entire loop as a string and eval that to
avoid recompiling all your patterns all the time. Together with
undefining $/ 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 (@files) for a list of words (@words), and prints
+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;';
@@ -2866,7 +3392,7 @@ out the names of those files that contain a match:
@ARGV = @files;
undef $/;
eval $search; # this screams
- $/ = "\n"; # put back to normal input delim
+ $/ = "\n"; # put back to normal input delimiter
foreach $file (sort keys(%seen)) {
print $file, "\n";
}
@@ -2880,7 +3406,7 @@ out the names of those files that contain a match:
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
+value: the CODE ref of the closure you just created. See L<perlsub> and
L<perlref> for details.
=item substr EXPR,OFFSET,LEN
@@ -2888,11 +3414,16 @@ L<perlref> for details.
=item substr EXPR,OFFSET
Extracts a substring out of EXPR and returns it. First character is at
-offset 0, or whatever you've set $[ to. If OFFSET is negative, starts
+offset 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 which 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 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
@@ -2907,7 +3438,7 @@ Returns 1 for success, 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("","");', $@ eq '');
+ $symlink_exists = (eval {symlink("","")};, $@ eq '');
=item syscall LIST
@@ -2925,9 +3456,20 @@ like numbers.
require 'syscall.ph'; # may need to run h2ph
syscall(&SYS_write, fileno(STDOUT), "hi there\n", 9);
-Note that Perl only supports passing of up to 14 arguments to your system call,
+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, syscall returns -1 and sets C<$!> (errno).
+Note that some system calls can legitimately return -1. The proper
+way to handle such calls is to assign C<$!=0;> before the call and
+check the value of <$!> if syscall returns -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
@@ -2949,17 +3491,44 @@ the value of PERMS specifies the permissions of the newly created
file. If PERMS is omitted, the default value is 0666, which allows
read and write for all. This default is reasonable: see C<umask>.
+The 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 may cause confusion.
-Returns the number of bytes actually read, 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.
+stdio, so mixing this with other kinds of reads, print(), write(),
+seek(), or tell() can cause confusion because stdio usually buffers
+data. Returns the number of bytes actually read, 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 "\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 sysread()),
+print(), write(), seek(), or tell() may cause confusion. FILEHANDLE may
+be an expression whose value gives the name of the filehandle. The
+values for WHENCE are 0 to set the new position to POSITION, 1 to set
+the it to the current position plus POSITION, and 2 to set it to EOF
+plus POSITION (typically negative). For WHENCE, you may use the
+constants SEEK_SET, SEEK_CUR, and SEEK_END from either the 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 "0 but true"; thus sysseek() returns
+TRUE on success and FALSE on failure, yet you can still easily determine
+the new position.
=item system LIST
@@ -2968,9 +3537,46 @@ first, and the parent process waits for the child process to complete.
Note that argument processing varies depending on the number of
arguments. The return value is the exit status of the program as
returned by the 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 merely use backticks, as
-described in L<perlop/"`STRING`">.
+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
+qx//, as described in L<perlop/"`STRING`">.
+
+Because system() and backticks block SIGINT and 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: $?"
+
+Here's a more elaborate example of analysing the return value from
+system() on a Unix system to check for all possibilities, including for
+signals and core dumps.
+
+ $rc = 0xffff & system @args;
+ printf "system(%s) returned %#04x: ", "@args", $rc;
+ if ($rc == 0) {
+ print "ran with normal exit\n";
+ }
+ elsif ($rc == 0xff00) {
+ print "command failed: $!\n";
+ }
+ elsif ($rc > 0x80) {
+ $rc >>= 8;
+ print "ran with non-zero exit status $rc\n";
+ }
+ else {
+ print "ran with ";
+ if ($rc & 0x80) {
+ $rc &= ~0x80;
+ print "core dump from ";
+ }
+ print "signal $rc\n"
+ }
+ $ok = ($rc != 0);
+
+When the arguments get executed via the system shell, results will
+be subject to its quirks and capabilities. See L<perlop/"`STRING`">
+for details.
=item syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET
@@ -2978,16 +3584,23 @@ described in L<perlop/"`STRING`">.
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 prints may cause confusion. Returns the
-number of bytes actually written, or undef if there was an error. An
-OFFSET may be specified to get the write data from some other place than
-the beginning of the string.
+stdio, so mixing this with reads (other than sysread()), print(),
+write(), seek(), or tell() may cause confusion because stdio usually
+buffers data. Returns the number of bytes actually written, or 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 file position for FILEHANDLE. FILEHANDLE may be an
+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.
@@ -3016,14 +3629,13 @@ 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);
+ 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 an associative array should have the following
-methods:
+A class implementing a hash should have the following methods:
TIEHASH classname, LIST
DESTROY this
@@ -3046,7 +3658,7 @@ A class implementing a scalar should have the following methods:
TIESCALAR classname, LIST
DESTROY this
- FETCH this,
+ FETCH this,
STORE this, value
Unlike dbmopen(), the tie() function will not use or require a module
@@ -3062,8 +3674,10 @@ package.
=item time
-Returns the number of non-leap seconds since 00:00:00 UTC, January 1,
-1970. Suitable for feeding to gmtime() and localtime().
+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 gmtime() and localtime().
=item times
@@ -3074,7 +3688,7 @@ seconds, for this process and the children of this process.
=item tr///
-The translation operator. See L<perlop>.
+The translation operator. Same as y///. See L<perlop>.
=item truncate FILEHANDLE,LENGTH
@@ -3086,44 +3700,59 @@ on your system.
=item uc EXPR
+=item uc
+
Returns an uppercased version of EXPR. This is the internal function
implementing the \U escape in double-quoted strings.
-Should respect any POSIX setlocale() settings.
+Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>.
+
+If EXPR is omitted, uses $_.
=item ucfirst EXPR
+=item ucfirst
+
Returns the value of EXPR with the first character uppercased. This is
the internal function implementing the \u escape in double-quoted strings.
-Should respect any POSIX setlocale() settings.
+Respects current LC_CTYPE locale if C<use locale> in force. See L<perllocale>.
+
+If EXPR is omitted, uses $_.
=item umask EXPR
=item umask
-Sets the umask for the process and returns the old one. If EXPR is
-omitted, merely returns current umask.
+Sets the umask for the process to EXPR and returns the previous value.
+If EXPR is omitted, merely returns the current umask. 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 entire array, or a subroutine name (using "&"). (Using undef()
-will probably not do what you expect on most predefined variables or
-DBM list values, so don't do that.) 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. Examples:
+scalar value, an entire array, an entire hash, or a subroutine name (using
+"&"). (Using undef() will probably not do what you expect on most
+predefined variables or DBM list values, so don't do that.) 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'};
+ undef $bar{'blurfl'}; # Compare to: delete $bar{'blurfl'};
undef @ary;
- undef %assoc;
+ undef %hash;
undef &mysub;
- return (wantarray ? () : undef) if $they_blew_it;
+ return (wantarray ? (undef, $errmsg) : undef) if $they_blew_it;
+ select undef, undef, undef, 0.25;
+ ($a, $b, undef, $c) = &foo; # Ignore third value returned
=item unlink LIST
+=item unlink
+
Deletes a list of files. Returns the number of files successfully
deleted.
@@ -3136,11 +3765,13 @@ 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 rmdir instead.
+If LIST is omitted, uses $_.
+
=item unpack TEMPLATE,EXPR
Unpack does the reverse of pack: it takes a string representing a
structure and expands it out into a list value, returning the array
-value. (In a scalar context, it merely returns the first value
+value. (In a scalar context, it returns merely the first value
produced.) The TEMPLATE has the same format as in the pack function.
Here's a subroutine that does substring:
@@ -3153,8 +3784,8 @@ and then there's
sub ordinal { unpack("c",$_[0]); } # same as ord()
-In addition, you may prefix a field with a %<number> to indicate that
-you want a <number>-bit checksum of the items instead of the items
+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:
@@ -3187,12 +3818,26 @@ reverse.
=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 which have changed in
+incompatible ways from older versions of Perl. (We try not to do
+this more than we have to.)
+
The BEGIN forces the require and import to happen at compile time. The
require makes sure the module is loaded into memory if it hasn't been
yet. The import is not a builtin--it's just an ordinary static method
@@ -3200,7 +3845,9 @@ call into the "Module" package to tell the module to import the list of
features back into the current package. The module can implement its
import method any way it likes, though most modules just choose to
derive their import method via inheritance from the Exporter class that
-is defined in the Exporter module. See L<Exporter>.
+is defined in the Exporter module. See L<Exporter>. If no 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:
@@ -3210,6 +3857,13 @@ 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 $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:
@@ -3219,16 +3873,18 @@ are also implemented this way. Currently implemented pragmas are:
use strict qw(subs vars refs);
use subs qw(afunc blurfl);
-These pseudomodules import semantics into the current block scope, unlike
+These pseudo-modules import semantics into the current block scope, unlike
ordinary modules, which import symbols into the current package (which are
effective through the end of the file).
There's a corresponding "no" command that unimports meanings imported
-by use.
+by use, i.e., it calls C<unimport Module LIST> instead of C<import>.
no integer;
no strict 'refs';
+If no 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
@@ -3243,27 +3899,27 @@ to the current time. Example of a "touch" command:
$now = time;
utime $now, $now, @ARGV;
-=item values ASSOC_ARRAY
+=item values HASH
-Returns a normal array consisting of all the values of the named
-associative array. (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 keys() or each() function would produce
-on the same array. See also keys(), each(), and sort().
+Returns a normal array 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 keys() or each() function would produce on the same hash. As a side
+effect, it resets HASH's iterator. See also keys(), each(), and sort().
=item vec EXPR,OFFSET,BITS
Treats the string in EXPR as a vector of unsigned integers, and
-returns the value of the bitfield specified by OFFSET. BITS specifies
+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. vec() may also be
-assigned to, in which case parens are needed to give the expression
+vector. This must be a power of two from 1 to 32. 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 vec() can also be manipulated with the logical
-operators |, & and ^, which will assume a bit vector operation is
+operators |, &, and ^, which will assume a bit vector operation is
desired when both operands are strings.
To transform a bit vector into a string or array of 0's and 1's, use these:
@@ -3277,20 +3933,20 @@ If you know the exact length in bits, it can be used in place of the *.
Waits for a child process to terminate and returns the pid of the
deceased process, or -1 if there are no child processes. The status is
-returned in $?.
+returned in C<$?>.
=item waitpid PID,FLAGS
Waits for a particular child process to terminate and returns the pid
of the deceased process, or -1 if there is no such child process. The
-status is returned in $?. If you say
+status is returned in C<$?>. If you say
- use POSIX "wait_h";
+ use POSIX ":sys_wait_h";
...
waitpid(-1,&WNOHANG);
then you can do a non-blocking wait for any process. Non-blocking wait
-is only available on machines supporting either the waitpid(2) or
+is available on machines supporting either the waitpid(2) or
wait4(2) system calls. However, waiting for a particular pid with
FLAGS of 0 is implemented everywhere. (Perl emulates the system call
by remembering the status values of processes that have exited but have
@@ -3300,14 +3956,47 @@ not been harvested by the Perl script yet.)
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.
+for a scalar. Returns the undefined value if the context is looking
+for no value (void context).
- return wantarray ? () : undef;
+ 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 die(), but doesn't exit or
-on an exception.
+Produces a message on STDERR just like die(), but doesn't exit or throw
+an exception.
+
+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 die()). Most
+handlers must therefore make arrangements to actually display the
+warnings that they are not prepared to deal with, by calling 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 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
@@ -3317,9 +4006,9 @@ on an exception.
Writes a formatted record (possibly multi-line) to the specified file,
using the format associated with that file. By default the format for
-a file is the one having the same name is the filehandle, but the
+a file is the one having the same name as the filehandle, but the
format for the current output channel (see the select() function) may be set
-explicitly by assigning the name of the format to the $~ variable.
+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
@@ -3327,9 +4016,9 @@ 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 $^ variable while the filehandle is
+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 $-, which can be set to 0 to force a new page.
+variable C<$->, which can be set to 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
@@ -3341,6 +4030,6 @@ Note that write is I<NOT> the opposite of read. Unfortunately.
=item y///
-The translation operator. See L<perlop>.
+The translation operator. Same as tr///. See L<perlop>.
=back
diff --git a/gnu/usr.bin/perl/pod/perlguts.pod b/gnu/usr.bin/perl/pod/perlguts.pod
index 07509bcc046..20a11ac45cc 100644
--- a/gnu/usr.bin/perl/pod/perlguts.pod
+++ b/gnu/usr.bin/perl/pod/perlguts.pod
@@ -8,7 +8,9 @@ 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 Datatypes
+=head1 Variables
+
+=head2 Datatypes
Perl has three typedefs that handle Perl's three main data types:
@@ -20,31 +22,33 @@ Each typedef has specific routines that manipulate the various data types.
=head2 What is an "IV"?
-Perl uses a special typedef IV which is large enough to hold either an
-integer or a pointer.
+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 SV's
+=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 four routines are:
+The five routines are:
SV* newSViv(IV);
SV* newSVnv(double);
SV* newSVpv(char*, int);
+ SV* newSVpvf(const char*, ...);
SV* newSVsv(SV*);
-To change the value of an *already-existing* SV, there are five routines:
+To change the value of an *already-existing* SV, there are six routines:
void sv_setiv(SV*, IV);
void sv_setnv(SV*, double);
- void sv_setpvn(SV*, char*, int)
void sv_setpv(SV*, char*);
+ void sv_setpvn(SV*, char*, int)
+ void sv_setpvf(SV*, const char*, ...);
void sv_setsv(SV*, SV*);
Notice that you can choose to specify the length of the string to be
@@ -52,7 +56,16 @@ assigned by using C<sv_setpvn> 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.
+with a NUL character. The arguments of C<sv_setpvf> are processed like
+C<sprintf>, and the formatted output becomes the value.
+
+All SVs that will contain strings should, but need not, 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:
@@ -67,9 +80,9 @@ 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<na>. Remember,
however, that Perl allows arbitrary strings of data that may both contain
-NUL's and not be terminated by a NUL.
+NULs and might not be terminated by a NUL.
-If you simply want to know if the scalar value is TRUE, you can use:
+If you want to know if the scalar value is TRUE, you can use:
SvTRUE(SV*)
@@ -80,7 +93,9 @@ Perl to allocate more memory for your SV, you can use the macro
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.
+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.
@@ -107,18 +122,20 @@ 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_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 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.
+yourself. The third function processes its arguments like C<sprintf> and
+appends the formatted output. The fourth 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.
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("varname", FALSE);
+ SV* perl_get_sv("package::varname", FALSE);
This returns NULL if the variable does not exist.
@@ -144,18 +161,18 @@ Take this code:
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
+return a real value, or undef otherwise. Instead it has returned a NULL
pointer which, somewhere down the line, will cause a segmentation violation,
-or just weird results. Change the zero to C<&sv_undef> in the first line and
-all will be well.
+bus error, or just weird results. Change the zero to C<&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 the section on B<MORTALITY>.
+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. Since a scalar can be both a number and a string,
+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.
@@ -170,23 +187,23 @@ pointer in an SV, you can use the following three macros instead:
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 just use the C<Sv*V> macros.
+In general, though, it's best to use the C<Sv*V> macros.
-=head2 Working with AV's
+=head2 Working with AVs
-There are two ways to create and load an AV. The first method just creates
-an empty AV:
+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 SV's:
+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 SV's can be destroyed, if so desired.
+AV has been created, the SVs can be destroyed, if so desired.
-Once the AV has been created, the following operations are possible on AV's:
+Once the AV has been created, the following operations are possible on AVs:
void av_push(AV*, SV*);
SV* av_pop(AV*);
@@ -200,63 +217,83 @@ to these new elements.
Here are some other functions:
- I32 av_len(AV*); /* Returns highest index value in array */
-
+ I32 av_len(AV*);
SV** av_fetch(AV*, I32 key, I32 lval);
- /* Fetches value at key offset, but it stores an undef value
- at the offset if lval is non-zero */
SV** av_store(AV*, I32 key, SV* val);
- /* Stores val at offset key */
-Take note that C<av_fetch> and C<av_store> return C<SV**>'s, not C<SV*>'s.
+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*);
- /* Clear out all elements, but leave the array */
void av_undef(AV*);
- /* Undefines the array, removing all elements */
void av_extend(AV*, I32 key);
- /* Extend the array to a total of key elements */
+
+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("varname", FALSE);
+ AV* perl_get_av("package::varname", FALSE);
This returns NULL if the variable does not exist.
-=head2 Working with HV's
+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 HV's:
+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. The C<val>
-argument contains the SV pointer to the scalar being stored, and C<hash> is
-the pre-computed 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.
+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*>. In order 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.
+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*);
- /* Clears all entries in hash table */
void hv_undef(HV*);
- /* Undefines the hash table */
+
+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
@@ -284,11 +321,11 @@ specified below.
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("varname", FALSE);
+ HV* perl_get_hv("package::varname", FALSE);
This returns NULL if the variable does not exist.
-The hash algorithm, for those who are interested, is:
+The hash algorithm is defined in the C<PERL_HASH(hash, key, klen)> macro:
i = klen;
hash = 0;
@@ -296,18 +333,72 @@ The hash algorithm, for those who are interested, is:
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 the following command:
+To create a reference, use either of the following functions:
+
+ SV* newRV_inc((SV*) thing);
+ SV* newRV_noinc((SV*) thing);
- SV* newRV((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>.
-The C<thing> argument can be any of an C<SV*>, C<AV*>, or C<HV*>. Once
-you have a reference, you can use the following macro to dereference the
-reference:
+Once you have a reference, you can use the following macro to dereference
+the reference:
SvRV(SV*)
@@ -318,8 +409,8 @@ To determine if an SV is a reference, you can use the following macro:
SvROK(SV*)
-To actually discover what the reference refers to, you must use the following
-macro and then check the value returned.
+To discover what type of value the reference refers to, use the following
+macro and then check the return value.
SvTYPE(SvRV(SV*))
@@ -328,10 +419,14 @@ 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_PVMG Blessed Scalar
+ 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
@@ -345,134 +440,113 @@ 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 the section on L<Stashes>
-for information on converting class names into stashes.
+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 classname is non-null, the SV is blessed into the specified class.
-SV is returned.
+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 rv. SV is blessed
-if classname is non-null.
+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 pointer (I<not a string!>) into an SV whose reference is rv.
-SV is blessed if classname is non-null.
+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 rv.
-Set length to 0 to let Perl calculate the string length.
-SV is blessed if classname is non-null.
+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);
int sv_isa(SV* sv, char* name);
int sv_isobject(SV* sv);
-=head1 Creating New Variables
+=head2 Creating New Variables
-To create a new Perl variable, which can be accessed from your Perl script,
-use the following routines, depending on the variable type.
+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("varname", TRUE);
- AV* perl_get_av("varname", TRUE);
- HV* perl_get_hv("varname", TRUE);
+ 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 bits that may be OR'ed with the TRUE argument to enable
-certain extra features. Those bits are:
-
- 0x02 Marks the variable as multiply defined, thus preventing the
- "Indentifier <varname> used only once: possible typo" warning.
- 0x04 Issues a "Had to create <varname> unexpectedly" warning if
- the variable didn't actually exist. This is useful if
- you expected the variable to already exist and want to propagate
- this warning back to the user.
-
-If the C<varname> argument does not contain a package specifier, it is
-created in the current package.
-
-=head1 XSUB's 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 timezone'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 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 IV's, 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.
-
-For more information, consult L<perlxs>.
-
-=head1 Mortality
-
-In Perl, values are normally "immortal" -- that is, they are not freed unless
-explicitly done so (via the Perl C<undef> call or other routines in Perl
-itself).
-
-Add cruft about reference counts.
- int SvREFCNT(SV* sv);
- void SvREFCNT_inc(SV* sv);
- void SvREFCNT_dec(SV* sv);
-
-In the above example with C<tzname>, we needed to create two new SV's to push
-onto the argument stack, that being the two strings. However, we don't want
-these new SV's to stick around forever because they will eventually be
-copied into the SV's that hold the two scalar variables.
-
-An SV (or AV or HV) that is "mortal" acts in all ways as a normal "immortal"
-SV, AV, or HV, but is only valid in the "current context". When the Perl
-interpreter leaves the current context, the mortal SV, AV, or HV is
-automatically freed. Generally the "current context" means a single
-Perl statement.
+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:
@@ -480,34 +554,22 @@ To create a mortal variable, use the functions:
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, the third creates a mortal copy of an existing 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 SV's -- AV's and HV's can be made mortal
-by passing their address (and casting them to C<SV*>) to the C<sv_2mortal> or
-C<sv_mortalcopy> routines.
+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.
->From Ilya:
-Beware that the sv_2mortal() call is eventually equivalent to
-svREFCNT_dec(). A value can happily be mortal in two different contexts,
-and it will be svREFCNT_dec()ed twice, once on exit from these
-contexts. It can also be mortal twice in the same context. This means
-that you should be very careful to make a value mortal exactly as many
-times as it is needed. The value that go to the Perl stack I<should>
-be mortal.
+=head2 Stashes and Globs
-You should be careful about creating mortal variables. It is possible for
-strange things to happen should you make the same value mortal within
-multiple contexts.
-
-=head1 Stashes
-
-A stash is a hash table (associative array) 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 called a
-GV (for Glob Value). This GV in turn contains references to the various
-objects of that name, including (but not limited to) the following:
+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
@@ -517,11 +579,11 @@ objects of that name, including (but not limited to) the following:
Format
Subroutine
-Perl stores various stashes in a separate GV structure (for global
-variable) but represents them with an HV structure. The keys in this
-larger GV are the various package names; the values are the C<GV*>'s
-which are stashes. It may help to think of a stash purely as an HV,
-and that the term "GV" means the global variable hash.
+There is a single stash called "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 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:
@@ -546,8 +608,8 @@ then use the following to get the package name itself:
char* HvNAME(HV* stash);
-If you need to return a blessed value to your Perl script, you can use the
-following function:
+If you need to bless or re-bless an object you can use the following
+function:
SV* sv_bless(SV*, HV* stash)
@@ -557,13 +619,51 @@ as any other SV.
For more information on references and blessings, consult L<perlref>.
-=head1 Magic
+=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.]
-# Version 6, 1995/1/27
-
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>.
@@ -594,12 +694,12 @@ 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
-overriden, and multiple instances of the same type of magic can be
+overridden, and multiple instances of the same type of magic can be
associated with an SV.
-The C<name> and C<namlem> arguments are used to associate a string with
-the magic, typically the name of a variable. C<namlem> is stored in the
-C<mg_len> field and if C<name> is non-null and C<namlem> >= 0 a malloc'd
+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
@@ -610,7 +710,7 @@ 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
+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>:
@@ -665,94 +765,343 @@ 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 magicalness
- ------- ------ -------------------
- \0 vtbl_sv Regexp???
- A vtbl_amagic Operator Overloading
- a vtbl_amagicelem Operator Overloading
- c 0 Used in Operator Overloading
- B vtbl_bm Boyer-Moore???
+ 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
- g vtbl_mglob Regexp /g flag???
+ 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
- L 0 (but sets RMAGICAL) Perl Module/Debugger???
- l vtbl_dbline Debugger?
- 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 Signal Hash
- s vtbl_sigelem Signal Hash 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 ???
- v vtbl_vec Vector
- x vtbl_substr Substring???
- * vtbl_glob GV???
- # vtbl_arylen Array Length
- . vtbl_pos $. scalar variable
- ~ Reserved for extensions, but multiple extensions may clash
-
-When an upper-case and lower-case letter both exist in the table, then the
-upper-case letter is used to represent some kind of composite type (a list
-or a hash), and the lower-case letter is used to represent an element of
+ 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.
+
=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.
+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 upper-case letter, then the mg_obj is copied to C<nsv>, but
-the mg_type field is changed to be the lower-case letter.
+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.
-=head1 Double-Typed SV's
+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]
-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.
+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.
-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[]>.
+=head2 Localizing changes
-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:
+Perl has a very handy construction
- SvIOK_on
- SvNOK_on
- SvPOK_on
- SvROK_on
+ {
+ local $var = 2;
+ ...
+ }
-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.
+This construction is I<approximately> equivalent to
-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:
+ {
+ my $oldvar = $var;
+ $var = 2;
+ ...
+ $var = $oldvar;
+ }
- extern int dberror;
- extern char *dberror_list;
+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.
- SV* sv = perl_get_sv("dberror", TRUE);
- sv_setiv(sv, (IV) dberror);
- sv_setpv(sv, dberror_list[dberror]);
- SvIOK_on(sv);
+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.
-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>.
+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)>
-=head1 Calling Perl Routines from within C Programs
+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(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 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:
@@ -787,26 +1136,30 @@ functions:
XPUSH*()
POP*()
-For more information, consult L<perlcall>.
+For a detailed description of calling conventions from C to Perl,
+consult L<perlcall>.
-=head1 Memory Allocation
+=head2 Memory Allocation
-It is strongly 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
-more quickly satisfy allocation requests.
-However, on some platforms, it may cause spurious malloc or free errors.
+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 (Larry has switched to using a run-time memory checker),
-so this argument can be any number.
+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 second argument C<pointer> 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>,
@@ -835,6 +1188,212 @@ 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 reflect 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 is 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. Aat 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 compilications 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
@@ -845,11 +1404,12 @@ extensions.
=item AvFILL
-See C<av_len>.
+Same as C<av_len>.
=item av_clear
-Clears an array, making it empty.
+Clears an array, making it empty. Does not free the memory used by the
+array itself.
void av_clear _((AV* ar));
@@ -866,6 +1426,9 @@ 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 av_len
@@ -876,8 +1439,9 @@ Returns the highest index in the array. Returns -1 if the array is empty.
=item av_make
-Creats 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.
+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));
@@ -890,7 +1454,8 @@ empty.
=item av_push
-Pushes an SV onto the end of the array.
+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));
@@ -903,33 +1468,42 @@ Shifts an SV off the beginning of the array.
=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, otherwise it can be
-dereferenced to get the original C<SV*>.
+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.
+Undefines the array. Frees the memory used by the array itself.
void av_undef _((AV* ar));
=item av_unshift
-Unshift an SV onto the beginning of the array.
+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>.
+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.
+the type. May fail on overlapping copies. See also C<Move>.
(void) Copy( s, d, n, t );
@@ -948,27 +1522,40 @@ Returns the stash of the CV.
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. See C<DBsub>.
+Single-stepping is automatically turned on after every step. This is the C
+variable which corresponds to Perl's $DB::single variable. See C<DBsub>.
=item 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. See C<DBsingle>.
+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<DBsingle>.
The sub name can be found by
SvPV( GvSV( DBsub ), na )
+=item 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<DBsingle>.
+
=item dMARK
-Declare a stack marker for the XSUB. See C<MARK> and C<dORIGMARK>.
+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 dowarn
+
+The C variable which corresponds to Perl's $^W warning variable.
+
=item dSP
-Declares a stack pointer for the XSUB. See C<SP>.
+Declares a stack pointer variable, C<sp>, for the XSUB. See C<SP>.
=item dXSARGS
@@ -976,6 +1563,11 @@ 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 ENTER
Opening bracket on a callback. See C<LEAVE> and L<perlcall>.
@@ -997,7 +1589,7 @@ L<perlcall>.
=item G_ARRAY
-Used to indicate array context. See C<GIMME> and L<perlcall>.
+Used to indicate array context. See C<GIMME_V>, C<GIMME> and L<perlcall>.
=item G_DISCARD
@@ -1010,8 +1602,14 @@ Used to force a Perl C<eval> wrapper around a callback. See L<perlcall>.
=item GIMME
-The XSUB-writer's equivalent to Perl's C<wantarray>. Returns C<G_SCALAR> or
-C<G_ARRAY> for scalar or array context.
+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
@@ -1019,7 +1617,63 @@ Indicates that no arguments are being sent to a callback. See L<perlcall>.
=item G_SCALAR
-Used to indicate scalar context. See C<GIMME> and L<perlcall>.
+Used to indicate scalar context. See C<GIMME_V>, C<GIMME>, and L<perlcall>.
+
+=item G_VOID
+
+Used to indicate void context. See C<GIMME_V> 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
+accessable 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 gv_stashpv
@@ -1039,9 +1693,76 @@ Returns a pointer to the stash for a specified package. See C<gv_stashpv>.
Return the SV from the GV.
-=item he_free
+=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 (type C<U32>) stored in the hash entry.
+
+ 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.
+
+ 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.
+
+ 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<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.
+
+ 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
-Releases a hash entry from an iterator. See C<hv_iternext>.
+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
@@ -1049,37 +1770,92 @@ 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<lken> is the length of the key. The
-C<flags> value will normally be zero; if set to G_DISCARD then null will be
+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<lken> is the length of the key.
+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<lken> is the length of the key. If C<lval> is set then the fetch will be
+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));
+Note that hv_iterinit I<currently> returns the number of I<buckets> in
+the hash and I<not> the number of keys (as indicated in the Advanced
+Perl Programming book). This may change in future. Use the HvKEYS(hv)
+macro to find the number of keys in a hash.
+
=item hv_iterkey
Returns the key from the current position of the hash iterator. See
@@ -1087,6 +1863,14 @@ 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>.
@@ -1122,13 +1906,36 @@ Returns the package name of a stash. See C<SvSTASH>, C<CvSTASH>.
=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 pre-computed hash
+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, otherwise it can be dereferenced to get the
-original C<SV*>.
+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.
@@ -1144,7 +1951,7 @@ character or digit.
=item isALPHA
-Returns a boolean indicating whether the C C<char> is an ascii alphanumeric
+Returns a boolean indicating whether the C C<char> is an ascii alphabetic
character.
int isALPHA (char c)
@@ -1176,7 +1983,12 @@ Returns a boolean indicating whether the C C<char> is an uppercase character.
=item items
Variable which is setup by C<xsubpp> to indicate the number of items on the
-stack. See L<perlxs>.
+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
@@ -1186,7 +1998,7 @@ Closing bracket on a callback. See C<ENTER> and L<perlcall>.
=item MARK
-Stack marker for the XSUB. See C<dMARK>.
+Stack marker variable for the XSUB. See C<dMARK>.
=item mg_clear
@@ -1240,7 +2052,7 @@ Do magic after a value is assigned to the SV. See C<sv_magic>.
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.
+the type. Can do overlapping moves. See also C<Copy>.
(void) Move( s, d, n, t );
@@ -1270,64 +2082,73 @@ memory is zeroed with C<memzero>.
=item newAV
-Creates a new AV. The refcount is set to 1.
+Creates a new AV. The reference count is set to 1.
AV* newAV _((void));
=item newHV
-Creates a new HV. The refcount is set to 1.
+Creates a new HV. The reference count is set to 1.
HV* newHV _((void));
-=item newRV
+=item newRV_inc
-Creates an RV wrapper for an SV. The refcount for the original SV is
+Creates an RV wrapper for an SV. The reference count for the original SV is
incremented.
- SV* newRV _((SV* ref));
+ 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. The C<len> parameter indicates the number of bytes of
-pre-allocated string space the SV should have. The refcount for the new SV
-is set to 1.
+preallocated string space the SV should have. The reference count for the
+new SV is set to 1.
SV* newSV _((STRLEN len));
=item newSViv
-Creates a new SV and copies an integer into it. The refcount for the SV is
-set to 1.
+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 refcount for the SV is
-set to 1.
+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 refcount for the SV is
-set to 1. If C<len> is zero then Perl will compute the length.
+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 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 one. If C<classname> is non-null then the new SV will
+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
-refcount is 1.
+reference count is 1.
SV* newSVrv _((SV* rv, char* classname));
=item newSVsv
-Creates a new SV which is an exact duplicate of the orignal SV.
+Creates a new SV which is an exact duplicate of the original SV.
SV* newSVsv _((SV* old));
@@ -1408,6 +2229,12 @@ 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>.
@@ -1416,7 +2243,7 @@ Releases a Perl interpreter. See L<perlembed>.
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.
+set and the variable does not exist then NULL is returned.
AV* perl_get_av _((char* name, I32 create));
@@ -1424,7 +2251,7 @@ set and the variable does not exist then null is returned.
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.
+set and the variable does not exist then NULL is returned.
CV* perl_get_cv _((char* name, I32 create));
@@ -1432,7 +2259,7 @@ set and the variable does not exist then null is returned.
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.
+set and the variable does not exist then NULL is returned.
HV* perl_get_hv _((char* name, I32 create));
@@ -1440,7 +2267,7 @@ set and the variable does not exist then null is returned.
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.
+set and the variable does not exist then NULL is returned.
SV* perl_get_sv _((char* name, I32 create));
@@ -1544,7 +2371,8 @@ The XSUB-writer's interface to the C C<realloc> function, with 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>.
+This is always the proper type for the XSUB.
+See L<perlxs/"The RETVAL Variable">.
=item safefree
@@ -1659,8 +2487,8 @@ ends.
=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 refcount of the
-SV is unaffected.
+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));
@@ -1677,13 +2505,28 @@ C<len> indicates number of bytes to copy.
void sv_catpvn _((SV* sv, char* ptr, STRLEN len));
+=item sv_catpvf
+
+Processes its arguments like C<sprintf> and appends the formatted output
+to an SV.
+
+ void sv_catpvf _((SV* sv, const char* pat, ...));
+
=item sv_catsv
-Concatentates the string from SV C<ssv> onto the end of the string in SV
+Concatenates the string from SV C<ssv> onto the end of the string in SV
C<dsv>.
void sv_catsv _((SV* dsv, SV* ssv));
+=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>.
@@ -1696,6 +2539,12 @@ Set the length of the string which is in the SV. See C<SvCUR>.
SvCUR_set (SV* sv, int val )
+=item sv_dec
+
+Auto-decrement of the value in the SV.
+
+ void sv_dec _((SV* sv));
+
=item SvEND
Returns a pointer to the last character in the string which is in the SV.
@@ -1703,12 +2552,32 @@ See C<SvCUR>. Access the character as
*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 SvGROW
-Expands the character buffer in the SV.
+Expands the character buffer in the SV. 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 SvIOK
Returns a boolean indicating whether the SV contains an integer.
@@ -1727,6 +2596,12 @@ Tells an SV that it is an integer.
SvIOK_on (SV* sv)
+=item SvIOK_only
+
+Tells an SV that it is an integer and disables all other OK bits.
+
+ SvIOK_on (SV* sv)
+
=item SvIOKp
Returns a boolean indicating whether the SV contains an integer. Checks the
@@ -1768,6 +2643,12 @@ 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.
@@ -1789,7 +2670,7 @@ Returns a boolean indicating whether the value is an SV.
=item sv_newmortal
-Creates a new SV which is mortal. The refcount of the SV is set to 1.
+Creates a new SV which is mortal. The reference count of the SV is set to 1.
SV* sv_newmortal _((void));
@@ -1835,6 +2716,12 @@ Tells an SV that it is a double.
SvNOK_on (SV* sv)
+=item SvNOK_only
+
+Tells an SV that it is a double and disables all other OK bits.
+
+ SvNOK_on (SV* sv)
+
=item SvNOKp
Returns a boolean indicating whether the SV contains a double. Checks the
@@ -1872,6 +2759,12 @@ Tells an SV that it is a string.
SvPOK_on (SV* sv)
+=item SvPOK_only
+
+Tells an SV that it is a string and disables all other OK bits.
+
+ SvPOK_on (SV* sv)
+
=item SvPOKp
Returns a boolean indicating whether the SV contains a character string.
@@ -1895,19 +2788,19 @@ Returns a pointer to the string in the SV. The SV must contain a string.
=item SvREFCNT
-Returns the value of the object's refcount.
+Returns the value of the object's reference count.
int SvREFCNT (SV* sv);
=item SvREFCNT_dec
-Decrements the refcount of the given SV.
+Decrements the reference count of the given SV.
void SvREFCNT_dec (SV* sv)
=item SvREFCNT_inc
-Increments the refcount of the given SV.
+Increments the reference count of the given SV.
void SvREFCNT_inc (SV* sv)
@@ -1935,6 +2828,35 @@ Dereferences an RV to return the SV.
SV* SvRV (SV* sv);
+=item SvTAINT
+
+Taints an SV if tainting is enabled
+
+ SvTAINT (SV* sv);
+
+=item SvTAINTED
+
+Checks to see if an SV is tainted. Returns TRUE if it is, FALSE if not.
+
+ 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.
+
+ SvTAINTED_off (SV* sv);
+
+=item SvTAINTED_on
+
+Marks an SV as tainted.
+
+ SvTAINTED_on (SV* sv);
+
=item sv_setiv
Copies an integer into the given SV.
@@ -1960,31 +2882,41 @@ bytes to be copied.
void sv_setpvn _((SV* sv, char* ptr, STRLEN len));
+=item sv_setpvf
+
+Processes its arguments like C<sprintf> and sets an SV to the formatted
+output.
+
+ void sv_setpvf _((SV* sv, const char* pat, ...));
+
=item sv_setref_iv
-Copies an integer into an SV, optionally blessing the SV. The SV must be an
-RV. 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 refcount of 1.
+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 an SV, optionally blessing the SV. The SV must be an
-RV. 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 refcount of 1.
+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 an SV, optionally blessing the SV. The SV must be an
-RV. If the C<pv> argument is NULL then C<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 refcount of 1.
+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<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));
@@ -1995,11 +2927,12 @@ Note that C<sv_setref_pvn> copies the string while this copies the pointer.
=item sv_setref_pvn
-Copies a string into an SV, optionally blessing the SV. The lenth of the
-string must be specified with C<n>. The SV must be an RV. The C<classname>
+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 refcount of 1.
+a reference count of 1.
SV* sv_setref_pvn _((SV *rv, char *classname, char* pv, I32 n));
@@ -2008,9 +2941,7 @@ Note that C<sv_setref_pv> copies the pointer while this copies the string.
=item sv_setsv
Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
-(B<NOTE:> If C<ssv> has the C<SVs_TEMP> bit set, C<sv_setsv> may simply steal
-the string from C<ssv> and give it to C<dsv>, leaving C<ssv> empty.
-Caveat caller.)
+The source SV may be destroyed if it is mortal.
void sv_setsv _((SV* dsv, SV* ssv));
@@ -2068,16 +2999,32 @@ C<svtype> enum. Test these flags with the C<SvTYPE> macro.
=item SvUPGRADE
-Used to upgrade an SV to a more complex form. See C<svtype>.
+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_undef
This is the C<undef> SV. Always refer to this as C<&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 sv_usepvn
Tells an SV to use C<ptr> to find its string value. Normally the string is
-stored inside the SV; this allows the SV to use an outside string. The
+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.
@@ -2092,7 +3039,7 @@ This is the C<true> SV. See C<sv_no>. Always refer to this as C<&sv_yes>.
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>.
+L<perlxs/"Using XS With C++">.
=item toLOWER
@@ -2138,37 +3085,110 @@ Push an SV onto the stack, extending the stack if necessary. See C<PUSHs>.
XPUSHs(sv)
+=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(x);
+ XSRETURN(int x);
=item XSRETURN_EMPTY
-Return from an XSUB immediately.
+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<false> from an XSUB immediately.
+Return C<&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<undef> from an XSUB immediately.
+Return C<&sv_undef> from an XSUB immediately. Uses C<XST_mUNDEF>.
XSRETURN_UNDEF;
=item XSRETURN_YES
-Return C<true> from an XSUB immediately.
+Return C<&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<&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<&sv_undef> into the specified position C<i> on the stack.
+
+ XST_mUNDEF( int i );
+
+=item XST_mYES
+
+Place C<&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
@@ -2178,17 +3198,17 @@ destination, C<n> is the number of items, and C<t> is the type.
=back
-=head1 AUTHOR
+=head1 EDITOR
-Jeff Okamoto <okamoto@corp.hp.com>
+Jeff Okamoto <F<okamoto@corp.hp.com>>
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, and Spider Boardman.
+Bowers, Matthew Green, Tim Bunce, Spider Boardman, Ulrich Pfeifer, and
+Stephen McCamant.
-API Listing by Dean Roehrich <roehrich@cray.com>.
+API Listing by Dean Roehrich <F<roehrich@cray.com>>.
=head1 DATE
-Version 20: 1995/12/14
-
+Version 31.8: 1997/5/17
diff --git a/gnu/usr.bin/perl/pod/perlipc.pod b/gnu/usr.bin/perl/pod/perlipc.pod
index ac2c5fd584c..030463c7a01 100644
--- a/gnu/usr.bin/perl/pod/perlipc.pod
+++ b/gnu/usr.bin/perl/pod/perlipc.pod
@@ -1,6 +1,6 @@
=head1 NAME
-perlipc - Perl interprocess communication (signals, fifos, pipes, safe subprocceses, sockets, and semaphores)
+perlipc - Perl interprocess communication (signals, fifos, pipes, safe subprocesses, sockets, and semaphores)
=head1 DESCRIPTION
@@ -14,23 +14,23 @@ 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 an another process, or
+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
+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.
-Notice how all we do is set with a global variable and then raise an
-exception. That's because on most systems libraries are not
-re-entrant, so calling any print() functions (or even anything that needs to
-malloc(3) more memory) could in theory trigger a memory fault
-and subsequent core dump.
+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
@@ -45,14 +45,14 @@ indexed by name to get the number:
$signo{$name} = $i;
$signame[$i] = $name;
$i++;
- }
+ }
-So to check whether signal 17 and SIGALRM were the same, just do this:
+So to check whether signal 17 and SIGALRM were the same, do just this:
print "signal #17 = $signame[17]\n";
- if ($signo{ALRM}) {
+ 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
@@ -65,15 +65,15 @@ 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 send a hang-up signal to all
-processes in the current process group I<except for> the current process
-itself:
+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';
@@ -83,11 +83,11 @@ itself:
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.
+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:
@@ -95,29 +95,31 @@ handlers:
$SIG{INT} = sub { die "\nOutta here!\n" };
But that will be problematic for the more complicated handlers that need
-to re-install themselves. Because Perl's signal mechanism is currently
-based on the signal(3) function from the C library, you may somtimes be so
+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 {
- $SIG{CHLD} = \&REAPER; # loathe sysV
+ 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 "wait_h";
- sub REAPER {
+ use POSIX ":sys_wait_h";
+ sub REAPER {
my $child;
- $SIG{CHLD} = \&REAPER; # loathe sysV
while ($child = waitpid(-1,WNOHANG)) {
$Kid_Status{$child} = $?;
- }
+ }
+ $SIG{CHLD} = \&REAPER; # still loathe sysV
}
$SIG{CHLD} = \&REAPER;
# do something that forks...
@@ -132,11 +134,11 @@ using longjmp() or throw() in other languages.
Here's an example:
- eval {
+ eval {
local $SIG{ALRM} = sub { die "alarm clock restart" };
- alarm 10;
+ alarm 10;
flock(FH, 2); # blocking write lock
- alarm 0;
+ alarm 0;
};
if ($@ and $@ !~ /alarm clock restart/) { die }
@@ -149,7 +151,7 @@ examples in it.
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
+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
@@ -158,22 +160,22 @@ 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')
+ 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.
+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, newsreader, finger program, etc.) tries to read
+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 the new signature. We'll use the pipe-checking file test B<-p>
+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
@@ -183,15 +185,15 @@ to find out whether anyone (or anything) has accidentally removed our fifo.
while (1) {
unless (-p $FIFO) {
unlink $FIFO;
- system('mknod', $FIFO, 'p')
+ 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 sigs
+ sleep 2; # to avoid dup signals
}
@@ -199,10 +201,10 @@ to find out whether anyone (or anything) has accidentally removed our fifo.
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 a child process you
+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")
+ 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";
@@ -215,8 +217,8 @@ And here's how to start up a child process you intend to read from:
while (<STATUS>) {
next if /^(tcp|udp)/;
print;
- }
- close SPOOLER || die "bad netstat: $! $?";
+ }
+ 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
@@ -248,7 +250,7 @@ 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 just return a quick end of file, writers
+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:
@@ -256,6 +258,57 @@ handle. Consider:
print FH "bang\n";
close FH;
+=head2 Filehandles
+
+Both the main process and the child process share the same STDIN,
+STDOUT and STDERR filehandles. If both processes try to access them
+at once, strange things can happen. You may 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 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;
+
+=back
+
=head2 Safe Pipe Opens
Another interesting approach to IPC is making your single program go
@@ -272,13 +325,13 @@ you opened whatever your kid writes to his STDOUT.
use English;
my $sleep_count = 0;
- do {
+ 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
@@ -286,17 +339,17 @@ you opened whatever your kid writes to his STDOUT.
close(KID_TO_WRITE) || warn "kid exited $?";
} else { # child
($EUID, $EGID) = ($UID, $GID); # suid progs only
- open (FILE, "> /safe/file")
+ 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
-straigh-forward, but you can't use a pipe open or backticks safely.
+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.
@@ -308,7 +361,7 @@ Here's a safe backtick or pipe open for read:
if ($pid) { # parent
while (<KID_TO_READ>) {
# do something interesting
- }
+ }
close(KID_TO_READ) || warn "kid exited $?";
} else { # child
@@ -316,7 +369,7 @@ Here's a safe backtick or pipe open for read:
exec($program, @options, @args)
|| die "can't exec program: $!";
# NOTREACHED
- }
+ }
And here's a safe pipe open for writing:
@@ -328,7 +381,7 @@ And here's a safe pipe open for writing:
if ($pid) { # parent
for (@data) {
print KID_TO_WRITE;
- }
+ }
close(KID_TO_WRITE) || warn "kid exited $?";
} else { # child
@@ -336,14 +389,14 @@ And here's a safe pipe open for writing:
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 L<SEE ALSO> section.
+F<modules> file mentioned below in the SEE ALSO section.
-=head2 Bidirectional Communication
+=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
@@ -351,7 +404,7 @@ 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
+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.
@@ -378,17 +431,17 @@ Here's an example of using open2():
print Writer "stuff\n";
$got = <Reader>;
-The problem with this is that Unix buffering is going to really
-ruin your day. Even though your C<Writer> filehandle is autoflushed,
+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 actually give it back to you
-in a similarly quick fashion. In this case, we could, because we
+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
+unless you yourself wrote the program on the other end of the
double-ended pipe.
-A solution to this is the non-standard F<Comm.pl> library. It uses
+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';
@@ -399,18 +452,18 @@ pseudo-ttys to make your program behave more reasonably:
}
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 hopefully its
+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 L<SEE ALSO> section below.
+in the SEE ALSO section below.
=head1 Sockets: Client/Server Communication
-While not limited to Unix-derived operating systems (e.g. WinSock on PCs
+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 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
+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
@@ -426,6 +479,14 @@ 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 TCP Clients and Servers
Use Internet-domain sockets when you want to do client-server
@@ -449,9 +510,9 @@ Here's a sample TCP client using Internet-domain sockets:
$proto = getprotobyname('tcp');
socket(SOCK, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
connect(SOCK, $paddr) || die "connect: $!";
- while ($line = <SOCK>) {
+ while (defined($line = <SOCK>)) {
print $line;
- }
+ }
close (SOCK) || die "close: $!";
exit;
@@ -470,12 +531,14 @@ instead.
use Socket;
use Carp;
- sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }
+ 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,
+ 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: $!";
@@ -490,16 +553,16 @@ instead.
my($port,$iaddr) = sockaddr_in($paddr);
my $name = gethostbyaddr($iaddr,AF_INET);
- logmsg "connection from $name [",
- inet_ntoa($iaddr), "]
+ logmsg "connection from $name [",
+ inet_ntoa($iaddr), "]
at port $port";
- print CLIENT "Hello there, $name, it's now ",
+ print Client "Hello there, $name, it's now ",
scalar localtime, "\n";
- }
+ }
And here's a multithreaded version. It's multithreaded in that
-like most typical servers, it spawns (forks) a slave server to
+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.
@@ -511,12 +574,14 @@ go back to service a new client.
use Carp;
sub spawn; # forward declaration
- sub logmsg { print "$0 $$: @_ at ", scalar localtime, "\n" }
+ 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,
+ 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: $!";
@@ -526,38 +591,38 @@ go back to service a new client.
my $waitedpid = 0;
my $paddr;
- sub REAPER {
- $SIG{CHLD} = \&REAPER; # loathe sysV
+ 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)
+ for ( $waitedpid = 0;
+ ($paddr = accept(Client,Server)) || $waitedpid;
+ $waitedpid = 0, close Client)
{
- next if $waitedpid;
+ 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), "]
+ logmsg "connection from $name [",
+ inet_ntoa($iaddr), "]
at port $port";
- spawn sub {
+ spawn sub {
print "Hello there, $name, it's now ", scalar localtime, "\n";
- exec '/usr/games/fortune'
+ exec '/usr/games/fortune'
or confess "can't exec fortune: $!";
};
- }
+ }
sub spawn {
my $coderef = shift;
- unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
+ unless (@_ == 0 && $coderef && ref($coderef) eq 'CODE') {
confess "usage: spawn CODEREF";
}
@@ -567,15 +632,15 @@ go back to service a new client.
return;
} elsif ($pid) {
logmsg "begat $pid";
- return; # i'm the parent
+ return; # I'm the parent
}
- # else i'm the child -- go spawn
+ # 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,
@@ -601,11 +666,11 @@ differ from the system on which it's being run:
use Socket;
my $SECS_of_70_YEARS = 2208988800;
- sub ctime { scalar localtime(shift) }
+ sub ctime { scalar localtime(shift) }
- my $iaddr = gethostbyname('localhost');
- my $proto = getprotobyname('tcp');
- my $port = getservbyname('time', 'tcp');
+ my $iaddr = gethostbyname('localhost');
+ my $proto = getprotobyname('tcp');
+ my $port = getservbyname('time', 'tcp');
my $paddr = sockaddr_in(0, $iaddr);
my($host);
@@ -627,10 +692,10 @@ differ from the system on which it's being run:
=head2 Unix-Domain TCP Clients and Servers
-That's fine for Internet-domain clients and servers, but what local
+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
+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
@@ -640,7 +705,7 @@ 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:
@@ -652,13 +717,13 @@ Here's a sample Unix-domain client:
$rendezvous = shift || '/tmp/catsock';
socket(SOCK, PF_UNIX, SOCK_STREAM, 0) || die "socket: $!";
- connect(SOCK, sockaddr_un($remote)) || die "connect: $!";
- while ($line = <SOCK>) {
+ connect(SOCK, sockaddr_un($rendezvous)) || die "connect: $!";
+ while (defined($line = <SOCK>)) {
print $line;
- }
+ }
exit;
-And here's a corresponding server.
+And here's a corresponding server.
#!/usr/bin/perl -Tw
require 5.002;
@@ -681,17 +746,17 @@ And here's a corresponding server.
$SIG{CHLD} = \&REAPER;
- for ( $waitedpid = 0;
- accept(Client,Server) || $waitedpid;
- $waitedpid = 0, close Client)
+ for ( $waitedpid = 0;
+ accept(Client,Server) || $waitedpid;
+ $waitedpid = 0, close Client)
{
next if $waitedpid;
logmsg "connection on $NAME";
- spawn sub {
+ 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(),
@@ -710,7 +775,326 @@ 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.
-=head2 UDP: Message Passing
+=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);
+ 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\n\n";
+ 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>:
+
+ shell_prompt$ 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
+is one of the cornerstones of the Unix philosophy, and good software
+engineering as well, which is probably why it's spread to other systems
+as well.)
+
+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.
+
+The C<kill> at the end of the parent's block is there to eliminate the
+child process as soon as the server we connect to closes its end.
+
+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
+
+Setting up 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 or in the perlipc(1) 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
@@ -719,11 +1103,11 @@ 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 just use TCP to start
+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
-above. However, instead of checking one host at a time, the UDP version
+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.
@@ -734,8 +1118,8 @@ with TCP, you'd have to use a different socket handle for each host.
use Socket;
use Sys::Hostname;
- my ( $count, $hisiaddr, $hispaddr, $histime,
- $host, $iaddr, $paddr, $port, $proto,
+ my ( $count, $hisiaddr, $hispaddr, $histime,
+ $host, $iaddr, $paddr, $port, $proto,
$rin, $rout, $rtime, $SECS_of_70_YEARS);
$SECS_of_70_YEARS = 2208988800;
@@ -781,8 +1165,7 @@ 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.
+Here's a small example showing shared memory usage.
$IPC_PRIVATE = 0;
$IPC_RMID = 0;
@@ -808,7 +1191,7 @@ Here's an example of a semaphore:
die if !defined($key);
print "$key\n";
-Put this code in a separate file to be run in more that one process
+Put this code in a separate file to be run in more than one process.
Call the file F<take>:
# create a semaphore
@@ -832,7 +1215,7 @@ Call the file F<take>:
semop($key,$opstring) || die "$!";
-Put this code in a separate file to be run in more that one process
+Put this code in a separate file to be run in more than one process.
Call this file F<give>:
# 'give' the semaphore
@@ -852,32 +1235,24 @@ Call this file F<give>:
semop($key,$opstring) || die "$!";
-=head1 WARNING
-
-The SysV IPC code above was written long ago, and it's definitely clunky
-looking. It should at the very least be made to C<use strict> and
-C<require "sys/ipc.ph">. Better yet, perhaps someone should create an
-C<IPC::SysV> module the way we have the C<Socket> module for normal
-client-server communications.
-
-(... time passes)
-
-Voila! Check out the IPC::SysV modules written by Jack Shirazi. You can
-find them at a CPAN store near you.
+The SysV IPC code above was written long ago, and it's definitely
+clunky looking. It should at the very least be made to C<use strict>
+and C<require "sys/ipc.ph">. Better yet, check out the IPC::SysV modules
+on CPAN.
=head1 NOTES
If you are running under version 5.000 (dubious) or 5.001, you can still
use most of the examples in this document. You may have to remove the
C<use strict> and some of the my() statements for 5.000, and for both
-you'll have to load in version 1.2 of the F<Socket.pm> module, which
-was/is/shall-be included in I<perl5.001o>.
+you'll have to load in version 1.2 or older of the F<Socket.pm> module, which
+is included in I<perl5.002>.
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
-that you should check the return values fo these functions. Always begin
+that you should check the return values of 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 pound-bang line for servers:
@@ -892,26 +1267,42 @@ B<-T> taint checking flag to the pound-bang line for servers:
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 filedescriptors over a local UDP datagram socket if you
+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.
-Because few vendors provide C libraries that are safely
-re-entrant, the prudent programmer will do little else within
-a handler beyond die() to raise an exception and longjmp(3) out.
+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 perilous problems will be addressed in a
+future release of Perl.
=head1 AUTHOR
Tom Christiansen, with occasional vestiges of Larry Wall's original
-version.
+version and suggestions from the Perl Porters.
=head1 SEE ALSO
-Besides the obvious functions in L<perlfunc>, you should also check out
-the F<modules> file at your nearest CPAN site. (See L<perlmod> or best
-yet, the F<Perl FAQ> for a description of what CPAN is and where to get it.)
+There's a lot more to networking than this, but this should get you
+started.
+
+For intrepid programmers, the classic textbook I<Unix Network Programming>
+by 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
+(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/gnu/usr.bin/perl/pod/perllocale.pod b/gnu/usr.bin/perl/pod/perllocale.pod
new file mode 100644
index 00000000000..e1bf5f070df
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perllocale.pod
@@ -0,0 +1,800 @@
+=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
+very naE<iuml>ve to think that C<A-Za-z> defines all the "letters". 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 be able 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 the locales which 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, 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 which 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>, either by yourself, or by the person who set
+up your system account, at the time the application is started.
+
+=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 it is used without an
+explicit comparison function because it uses C<cmp> by default.
+
+B<Note:> C<eq> and C<ne> are unaffected by the 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 returns with S<C<no locale>> or on reaching the
+end of the enclosing block.
+
+Note that 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, 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 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 use this in a subsequent 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 that 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 which 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 the implementation of 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)>.
+For the locales available in your system, also consult L<setlocale(3)>
+and see whether it leads you to the list of the 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 de_DE ru_RU
+ en de ru
+ english german russian
+ english.iso88591 german.iso88591 russian.iso88595
+
+Sadly, even though the calling interface for setlocale() has been
+standardized, the names of the locales and the directories where
+the configuration is, have not. The basic form of the name is
+I<language_country/territory>B<.>I<codeset>, but the
+latter parts are not always present.
+
+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 and the second by
+the POSIX standard. What they define is the B<default locale> in which
+every program starts in the absence of locale information in its
+environment. (The 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 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 formatting variable names such as
+C<decimal_point> and C<thousands_sep>; the values are the corresponding
+values. See L<POSIX (3)/localeconv> for a longer example, which lists
+all the categories an implementation might be expected to provide; some
+provide more and others fewer, however. Note that you don't need C<use
+locale>: as a function with the job of querying the locale, localeconv()
+always observes the current locale.
+
+Here's a simple-minded example program which rewrites its command line
+parameters as integers formatted correctly 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 = 3 unless $grouping;
+
+ # Format command line params for current locale
+ for (@ARGV) {
+ $_ = int; # Chop non-integer part
+ 1 while
+ s/(\d)(\d{$grouping}($|$thousands_sep))/$1$thousands_sep$2/;
+ print "$_";
+ }
+ print "\n";
+
+=head1 LOCALE CATEGORIES
+
+The subsections which follow describe basic locale categories. As well
+as these, there are some combination categories which allow the
+manipulation of more than one basic category at a time. See
+L<"ENVIRONMENT"> for a discussion of these.
+
+=head2 Category LC_COLLATE: Collation
+
+When in the scope of S<C<use locale>>, Perl looks to the C<LC_COLLATE>
+environment variable to determine the application's notions on the
+collation (ordering) of characters. ('b' follows 'a' in Latin
+alphabets, but where do 'E<aacute>' and 'E<aring>' belong?)
+
+Here is a code snippet that will tell you what are the alphanumeric
+characters in the current locale, in the locale 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 which 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 which ignores space characters completely, and
+which folds case.
+
+If you have a single string which 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 their 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. 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 it 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. And 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, as 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
+
+When 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 translating
+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 <\U> in double-quoted strings
+and in 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 (unaccented) 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
+
+When in the scope of S<C<use locale>>, Perl obeys the C<LC_NUMERIC>
+locale information, which controls 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.)
+
+Note that 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, though voluminous and complex, does not quite
+meet your requirements: currency formatting is a hard nut to crack.
+
+=head2 LC_TIME
+
+The 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 the 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 which
+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 which are not part of the standard Perl distribution.
+
+=head1 SECURITY
+
+While 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 which 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 which 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 which takes the trouble to use the information in
+C<LC_MONETARY> may format debits as if they were credits and vice versa
+if that locale has been subverted. Or it make may 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 maliciously be modified presents
+similar challenges. Similarly, they are not specific to Perl: any
+programming language which allows you to write programs which take
+account of their environment exposes you to these issues.
+
+Perl cannot protect you from all of the 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 which become locale-dependent, and
+which may be untrustworthy in consequence. Here is a summary of the
+tainting behavior of operators and functions which 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 <\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 an array-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 it is 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 <\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 very similar program which is locale-aware:
+
+ #/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> when 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) is 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 which 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 it is
+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 (see
+L<The setlocale function>) was always in force, even if the program
+environment suggested otherwise. By default, Perl still behaves this
+way so as to maintain 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 that was available, that is, C<\w> did understand what
+are 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 which 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 the 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 system environments 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: maybe some bug fixes 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.
+
+Last update: Wed Jan 22 11:04:58 EST 1997
diff --git a/gnu/usr.bin/perl/pod/perllol.pod b/gnu/usr.bin/perl/pod/perllol.pod
index 11632e0c978..1de3b1ad749 100644
--- a/gnu/usr.bin/perl/pod/perllol.pod
+++ b/gnu/usr.bin/perl/pod/perllol.pod
@@ -12,11 +12,11 @@ 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 $LoL[3][2]. Here's
+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 = (
+ @LoL = (
[ "fred", "barney" ],
[ "george", "jane", "elroy" ],
[ "homer", "marge", "bart" ],
@@ -27,7 +27,7 @@ a declaration of the array:
Now you should be very careful that the outer bracket type
is a round one, that is, parentheses. That's because you're assigning to
-an @list, so you need parens. If you wanted there I<not> to be an @LoL,
+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
@@ -39,10 +39,10 @@ but rather just a reference to it, you could do something more like this:
print $ref_to_LoL->[2][2];
-Notice that the outer bracket type has changed, and so our access syntax
+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, $LoL[2] is not an
+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]
@@ -54,8 +54,8 @@ instead of having to write these:
$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 array.
-But you need not do so for the very first one if it's a scalar containing
+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
@@ -72,7 +72,7 @@ each line is a row and each word an element. If you're trying to develop an
while (<>) {
@tmp = split;
push @LoL, [ @tmp ];
- }
+ }
You might also have loaded that from a function:
@@ -81,7 +81,7 @@ You might also have loaded that from a function:
}
Or you might have had a temporary variable sitting around with the
-list in it.
+list in it.
for $i ( 1 .. 10 ) {
@tmp = somefunc($i);
@@ -93,8 +93,8 @@ 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.
+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:
@@ -104,58 +104,58 @@ declarations to make it happy:
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 )
+ for $i ( 0 .. 10 ) {
$line = <>;
$LoL[$i] = [ split ' ', $line ];
- }
+ }
or even just
my (@LoL, $i);
- for $i ( 0 .. 10 )
+ for $i ( 0 .. 10 ) {
$LoL[$i] = [ split ' ', <> ];
- }
+ }
-You should in general be leary of using potential list functions
-in a scalar context without explicitly stating such.
+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 )
+ 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 ];
- }
+ }
-Actually, if you were using strict, you'd not only have to declare $ref_to_LoL as
-you had to declare @LoL, but you'd I<also> having to initialize it to a
-reference to an empty list. (This was a bug in 5.001m that's been fixed
-for the 5.002 release.)
+Actually, if you were using strict, you'd have to declare not only
+$ref_to_LoL as you had to declare @LoL, but you'd I<also> having to
+initialize it to a reference to an empty list. (This was a bug in
+perl version 5.001m that's been fixed for the 5.002 release.)
my $ref_to_LoL = [];
while (<>) {
push @$ref_to_LoL, [ split ];
- }
+ }
Ok, now you can add new rows. What about adding new columns? If you're
-just dealing with matrices, it's often easiest to use simple assignment:
+dealing with just matrices, it's often easiest to use simple assignment:
for $x (1 .. 10) {
for $y (1 .. 10) {
@@ -165,19 +165,19 @@ just dealing with matrices, it's often easiest to use simple assignment:
for $x ( 3, 7, 9 ) {
$LoL[$x][20] += func2($x);
- }
+ }
-It doesn't matter whether those elements are already
+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 just wanted to append to a row, you'd have
+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> just say:
+Notice that I I<couldn't> say just:
push $LoL[0], "wilma", "betty"; # WRONG!
@@ -186,22 +186,22 @@ 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 only want one
+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
-just say
+say
print @LoL; # WRONG
-because you'll just get references listed, and perl will never
-automatically dereference things for you. Instead, you have to
+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.
+set of subscripts.
for $aref ( @LoL ) {
print "\t [ @$aref ],\n";
@@ -221,7 +221,7 @@ or maybe even this. Notice the inner loop.
}
}
-As you can see, it's getting a bit complicated. That's why
+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 ) {
@@ -231,7 +231,7 @@ sometimes is easier to take a temporary on your way through:
}
}
-Hm... that's still a bit ugly. How about this:
+Hmm... that's still a bit ugly. How about this:
for $i ( 0 .. $#LoL ) {
$aref = $LoL[$i];
@@ -243,7 +243,7 @@ Hm... that's still a bit ugly. How about this:
=head1 Slices
-If you want to get at a slide (part of a row) in a multidimensional
+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.
@@ -254,10 +254,10 @@ Here's how to do one operation using a loop. We'll assume an @LoL
variable as before.
@part = ();
- $x = 4;
+ $x = 4;
for ($y = 7; $y < 13; $y++) {
push @part, $LoL[$x][$y];
- }
+ }
That same loop could be replaced with a slice operation:
@@ -266,16 +266,16 @@ That same loop could be replaced with a slice operation:
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? Hm... here's the simple way:
+$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; $x <= 12; $y++) {
+ for ($starty = $y = 7; $y <= 12; $y++) {
$newLoL[$x - $startx][$y - $starty] = $LoL[$x][$y];
}
- }
+ }
-We can reduce some of the looping through slices
+We can reduce some of the looping through slices
for ($x = 4; $x <= 8; $x++) {
push @newLoL, [ @{ $LoL[$x] } [ 7..12 ] ];
@@ -293,13 +293,13 @@ 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,
+ my ($x_lo, $x_hi,
$y_lo, $y_hi) = @_;
- return map {
- [ @{ $lrr->[$_] } [ $y_lo .. $y_hi ] ]
+ return map {
+ [ @{ $lrr->[$_] } [ $y_lo .. $y_hi ] ]
} $x_lo .. $x_hi;
- }
+ }
=head1 SEE ALSO
@@ -308,6 +308,6 @@ perldata(1), perlref(1), perldsc(1)
=head1 AUTHOR
-Tom Christiansen <tchrist@perl.com>
+Tom Christiansen <F<tchrist@perl.com>>
Last udpate: Sat Oct 7 19:35:26 MDT 1995
diff --git a/gnu/usr.bin/perl/pod/perlmod.pod b/gnu/usr.bin/perl/pod/perlmod.pod
index 80a40362466..4d0ad2d449d 100644
--- a/gnu/usr.bin/perl/pod/perlmod.pod
+++ b/gnu/usr.bin/perl/pod/perlmod.pod
@@ -1,28 +1,29 @@
=head1 NAME
-perlmod - Perl modules (packages)
+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 others variables. In fact, apart from certain
-magical variables, there's really no such thing as a global variable in
-Perl. 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 (the same scope
-as the local() operator). 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
-as assumed. That is, C<$::sail> is equivalent to C<$main::sail>.
+from stomping on each other's variables. In fact, apart from certain
+magical variables, there's really no such thing as a global variable
+in Perl. 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 affects
+only 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 influences merely 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
@@ -39,10 +40,10 @@ 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, the
-identifiers STDIN, STDOUT, STDERR, ARGV, ARGVOUT, ENV, INC and SIG are
+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 built-in 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
+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 translation.
@@ -62,23 +63,26 @@ 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>.
-See L<perlsub> for other scoping issues related to my() and local(),
-or L<perlref> regarding closures.
+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 associative
-array of that name appended with two colons. The main symbol table's
-name is thus C<%main::>, or C<%::> for short. Likewise the nested package
-mentioned earlier is named C<%OUTER::INNER::>.
+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 associative array 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:
+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'};
+ 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. Here is F<dumpvar.pl> from the Perl library:
@@ -112,16 +116,19 @@ instance. Here is F<dumpvar.pl> from the Perl library:
}
Note that even though the subroutine is compiled in package C<dumpvar>,
-the name of the subroutine is qualified so that its name is inserted
-into package C<main>.
+the name of the subroutine is qualified so that its name is inserted into
+package C<main>. While popular many years ago, this is now considered
+very poor style; in general, you should be writing modules and using the
+normal export mechanism instead of hammering someone else's namespace,
+even main's.
Assignment to a typeglob performs an aliasing operation, i.e.,
*dick = *richard;
-causes variables, subroutines and file handles accessible via the
-identifier C<richard> to also be accessible via the symbol C<dick>. If
-you only want to alias a particular variable or subroutine, you can
+causes variables, subroutines, and file handles accessible via the
+identifier C<richard> to also 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;
@@ -140,12 +147,12 @@ thing.
# now use %hashsym normally, and you
# will affect the caller's %another_hash
my %nhash = (); # do what you want
- return \%nhash;
+ return \%nhash;
}
-On return, the reference wil overwrite the hash slot in the
+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 refernces cheaply
+is a somewhat tricky way of passing around references cheaply
when you won't want to have to remember to dereference variables
explicitly.
@@ -154,6 +161,29 @@ 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 (one prototyped to
+take no arguments and to return a constant expression), which is
+subject to optimization at compile-time. This isn't. See L<perlsub>
+for details on 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 which is 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
@@ -161,13 +191,14 @@ 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.
+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
@@ -176,6 +207,11 @@ 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.
@@ -184,9 +220,9 @@ and C<END> work just as they do in B<awk>, as a degenerate case.
There is no special class syntax in Perl, but a package may function
as a class if it provides subroutines that function as methods. Such a
package may also derive some of its methods from another class package
-by listing the other package name in its @ISA array.
+by listing the other package name in its @ISA array.
-For more on this, see L<perlobj>.
+For more on this, see L<perltoot> and L<perlobj>.
=head2 Perl Modules
@@ -198,18 +234,70 @@ 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 Fred, create
-a file called Fred.pm and put this at the start of it:
+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.
+ };
- package Fred;
- require Exporter;
- @ISA = qw(Exporter);
- @EXPORT = qw(func1 func2);
- @EXPORT_OK = qw($sally @listabob %harry func3);
+ # 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 I<Perl Modules File> for details on
+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
@@ -252,9 +340,9 @@ 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();
+ $here = Cwd::getcwd();
- use Cwd; # import names from Cwd::
+ use Cwd; # import names from Cwd::
$here = getcwd();
require Cwd; # make Cwd:: accessible
@@ -275,795 +363,16 @@ 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
-just say C<use POSIX> to get it all.
+say just C<use POSIX> to get it all.
-For more information on writing extension modules, see L<perlxs>
+For more information on writing extension modules, see L<perlxstut>
and L<perlguts>.
-=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 (AKA 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.
-
-=head1 THE PERL MODULE LIBRARY
-
-A number of modules are included the 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, so is far from bullet proof.
-
-=head2 Pragmatic Modules
-
-They work somewhat like pragmas in that they tend to affect the compilation of
-your program, and thus will usually only work well when used within a
-C<use>, or C<no>. 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.
-
-The following programs are defined (and have their own documentation).
-
-=over 12
-
-=item diagnostics
-
-Pragma to produce enhanced diagnostics
-
-=item integer
-
-Pragma to compute arithmetic in integer instead of double
-
-=item less
-
-Pragma to request less of something from the compiler
-
-=item overload
-
-Pragma for overloading operators
-
-=item sigtrap
-
-Pragma to enable stack backtrace on unexpected signals
-
-=item strict
-
-Pragma to restrict unsafe constructs
-
-=item subs
-
-Pragma to predeclare sub 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 Carp
-
-warn of errors (from perspective of caller)
-
-=item Config
-
-access Perl configuration option
-
-=item Cwd
-
-get pathname of current working directory
-
-=item DB_File
-
-Perl access to Berkeley DB
-
-=item Devel::SelfStubber
-
-generate stubs for a SelfLoading module
-
-=item DynaLoader
-
-Dynamically load C libraries into Perl code
-
-=item English
-
-use nice English (or awk) names for ugly punctuation variables
-
-=item Env
-
-perl module that imports environment variables
-
-=item Exporter
-
-provide inport/export controls for Perl modules
-
-=item ExtUtils::Liblist
-
-determine libraries to use and how to use them
-
-=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::Miniperl
-
-!!!GOOD QUESTION!!!
-
-=item Fcntl
-
-load the C Fcntl.h defines
-
-=item File::Basename
-
-parse file specifications
-
-=item File::CheckTree
-
-run many filetest checks on a tree
-
-=item File::Find
-
-traverse a file tree
-
-=item FileHandle
-
-supply object methods for filehandles
-
-=item File::Path
-
-create or remove a series of directories
-
-=item Getopt::Long
-
-extended getopt processing
-
-=item Getopt::Std
-
-Process single-character switches with switch clustering
-
-=item I18N::Collate
-
-compare 8-bit scalar data according to the current locale
-
-=item IPC::Open2
-
-a process for both reading and writing
-
-=item IPC::Open3
-
-open a process for reading, writing, and error handling
-
-=item Net::Ping
-
-check a host for upness
-
-=item POSIX
-
-Perl interface to IEEE Std 1003.1
-
-=item SelfLoader
-
-load functions only on demand
-
-=item Safe
-
-Creation controlled compartments in which perl code can be evaluated.
-
-=item Socket
-
-load the C socket.h defines and structure manipulators
-
-=item Test::Harness
-
-run perl standard test scripts with statistics
-
-=item Text::Abbrev
-
-rceate an abbreviation table from a list
-
-=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 get
-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 size, 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 unbunded 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
-
-Some of the reguster CPAN sites as of this writing include the following.
-You should try to choose one close to you:
-
-=over
-
-=item *
-ftp://ftp.sterling.com/programming/languages/perl/
-
-=item *
-ftp://ftp.sedl.org/pub/mirrors/CPAN/
-
-=item *
-ftp://ftp.uoknor.edu/mirrors/CPAN/
-
-=item *
-ftp://ftp.delphi.com/pub/mirrors/packages/perl/CPAN/
-
-=item *
-ftp://uiarchive.cso.uiuc.edu/pub/lang/perl/CPAN/
-
-=item *
-ftp://ftp.cis.ufl.edu/pub/perl/CPAN/
-
-=item *
-ftp://ftp.switch.ch/mirror/CPAN/
-
-=item *
-ftp://ftp.sunet.se/pub/lang/perl/CPAN/
-
-=item *
-ftp://ftp.ci.uminho.pt/pub/lang/perl/
-
-=item *
-ftp://ftp.cs.ruu.nl/pub/PERL/CPAN/
-
-=item *
-ftp://ftp.demon.co.uk/pub/mirrors/perl/CPAN/
-
-=item *
-ftp://ftp.rz.ruhr-uni-bochum.de/pub/programming/languages/perl/CPAN/
-
-=item *
-ftp://ftp.leo.org/pub/comp/programming/languages/perl/CPAN/
-
-=item *
-ftp://ftp.pasteur.fr/pub/computing/unix/perl/CPAN/
-
-=item *
-ftp://ftp.ibp.fr/pub/perl/CPAN/
-
-=item *
-ftp://ftp.funet.fi/pub/languages/perl/CPAN/
-
-=item *
-ftp://ftp.tekotago.ac.nz/pub/perl/CPAN/
-
-=item *
-ftp://ftp.mame.mu.oz.au/pub/perl/CPAN/
-
-=item *
-ftp://coombs.anu.edu.au/pub/perl/
-
-=item *
-ftp://dongpo.math.ncu.edu.tw/perl/CPAN/
-
-=item *
-ftp://ftp.lab.kdd.co.jp/lang/perl/CPAN/
-
-=item *
-ftp://ftp.is.co.za/programming/perl/CPAN/
-
-=back
-
-For an up-to-date listing of CPAN sites,
-see http://www.perl.com/perl/ or 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 5 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 .pm file is required to
-exist.
-
-=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: die "Invalid" unless ref $ref eq 'FOO'.
-Generally you can delete the "eq 'FOO'" part with no harm at all.
-Let the objects look after themselves! Generally, avoid hardwired
-class names as far as possible.
-
-Avoid $r-E<gt>Class::func() where using @ISA=qw(... Class ...) and
-$r-E<gt>func() would work (see perlbot man page for more details).
-
-Use autosplit so little used or newly added functions won't be a
-burden to programs which 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 sub-class' test? If you say
-"@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: $obj = new YOURCLASS;
-into: $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 C<-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 which need less strictness. Always use C<-w>. Always use C<-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., $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 $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.
-
-=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 informally group or categorise a module.
-A module should have a very good reason 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 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.
-
-=item Adding a Copyright Notice.
-
-How you choose to licence 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 License (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 simply state something 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 valid floating point
-number with at least two digits after the decimal (ie hundredths,
-e.g, $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 it's location in your announcement.
-
-Some notes about ftp archives: Please use a long descriptive file
-name which 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 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
-(see 2.2 above) Otherwise try to add a mechanism to revert to the
-old behaviour if people rely on it. Document incompatible changes.
-
-=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 the perl applications which 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 which 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?)
-
-=back
+=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/gnu/usr.bin/perl/pod/perlmodlib.pod b/gnu/usr.bin/perl/pod/perlmodlib.pod
new file mode 100644
index 00000000000..cfb281dcc7b
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perlmodlib.pod
@@ -0,0 +1,1094 @@
+=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 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 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 which 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 which 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 which 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
+(see 2.2 above) 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 the perl applications which 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 which 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/gnu/usr.bin/perl/pod/perlobj.pod b/gnu/usr.bin/perl/pod/perlobj.pod
index 81c6c962468..7428334ee2f 100644
--- a/gnu/usr.bin/perl/pod/perlobj.pod
+++ b/gnu/usr.bin/perl/pod/perlobj.pod
@@ -4,10 +4,13 @@ perlobj - Perl objects
=head1 DESCRIPTION
-First of all, you need to understand what references are in Perl. See
-L<perlref> for that.
+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>.
-Here are three very simple definitions that you should find reassuring.
+If you're still with us, then
+here are three very simple definitions that you should find reassuring.
=over 4
@@ -24,7 +27,7 @@ with object references.
=item 3.
A method is simply a subroutine that expects an object reference (or
-a package name, for static methods) as the first argument.
+a package name, for class methods) as the first argument.
=back
@@ -41,11 +44,11 @@ constructor:
package Critter;
sub new { bless {} }
-The C<{}> constructs a reference to an anonymous hash containing no
+The C<{}> constructs a reference to an anonymous hash containing no
key/value pairs. 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, since the referenced object itself knows that
-it has been blessed, and its reference to it could have been returned
+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 {
@@ -64,8 +67,9 @@ that wish to call methods in the class as part of the construction:
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
+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 {
@@ -78,7 +82,7 @@ so that your constructors may be inherited:
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
+method used will be of whatever $class we blessed the
object into:
sub new {
@@ -93,17 +97,17 @@ object into:
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
-only be accessed through the class's methods.
+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 only
-belong to one class at a time. (Although of course it's free to
+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.)
A clarification: Perl objects are blessed. References are not. Objects
know which package they belong to. References do not. The bless()
-function simply uses the reference in order to find the object. Consider
+function uses the reference to find the object. Consider
the following example:
$a = {};
@@ -111,13 +115,13 @@ the following example:
bless $a, BLAH;
print "\$b is a ", ref($b), "\n";
-This reports $b as being a BLAH, so obviously bless()
+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 just use a package as a class by putting method
+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
@@ -126,7 +130,7 @@ 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.
+through @ISA are known as base classes of the current class.
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
@@ -137,10 +141,12 @@ that is called on behalf of the missing method.
If neither a method nor an AUTOLOAD routine is found in @ISA, then one
last try is made for the method (or an AUTOLOAD routine) in a class
-called UNIVERSAL. If that doesn't work, Perl finally gives up and
+called UNIVERSAL. (Several commonly used methods are automatically
+supplied in the UNIVERSAL class; see L<"Default UNIVERSAL methods"> for
+more details.) If that doesn't work, Perl finally gives up and
complains.
-Perl classes only do method inheritance. Data inheritance is left
+Perl classes do only method inheritance. 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
@@ -153,17 +159,18 @@ 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 or package it is being invoked on. There are just two
-types of methods, which we'll call static and virtual, in honor of
-the two C++ method types they most closely resemble.
+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 static method expects a class name as the first argument. It
+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 static
-methods. Many static methods simply ignore their first argument, since
+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, since
-static methods follow the inheritance tree just like ordinary virtual
-methods.) Another typical use for static methods is to look up an
+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 {
@@ -171,7 +178,7 @@ object by name:
$objtable{$name};
}
-A virtual method expects an object reference as its first argument.
+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.
@@ -191,9 +198,9 @@ 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 static or virtual methods.
-We'll use the two methods defined above, the static method to lookup
-an object reference and the virtual method to print out its attributes.
+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';
@@ -220,7 +227,7 @@ 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 parens of
+especially when the first word is "new".) Thus, the parentheses of
new Critter ('Barney', 1.5, 70)
@@ -242,8 +249,8 @@ 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 merely
-wish to specify that Perl should I<START> looking for a method in a
+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:
@@ -251,13 +258,13 @@ name with the package like this:
$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 pseudoclass,
+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 explicitly name it:
+to name it explicitly:
$self->SUPER::display('Height', 'Weight');
-Please note that the C<SUPER::> construct is I<only> meaningful within the
+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
@@ -267,6 +274,56 @@ 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
@@ -277,9 +334,9 @@ your class. It will automatically be called at the appropriate moment,
and you can do any extra cleanup you need to do.
Perl doesn't do nested destruction for you. If your constructor
-reblessed a reference from one of your base classes, your DESTROY may
-need to call DESTROY for any base classes that need it. But this only
-applies to reblessed objects--an object reference that is merely
+re-blessed a reference from one of your base classes, your DESTROY may
+need to call DESTROY for any base classes that need it. But this applies
+to only re-blessed objects--an object reference that is merely
I<CONTAINED> in the current object will be freed and destroyed
automatically when the current object is freed.
@@ -288,19 +345,19 @@ automatically when the current object is freed.
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. The left side of -E<gt> is not so
-limited, because it's an infix operator, not a postfix operator.
+limited, because it's an infix operator, not a postfix operator.
-That means that below, A and B are equivalent to each other, and C and D
-are equivalent, but AB and CD are different:
+That means that in the following, A and B are equivalent to each other, and
+C and D are equivalent, but A/B and C/D are different:
- A: method $obref->{"fieldname"}
+ A: method $obref->{"fieldname"}
B: (method $obref)->{"fieldname"}
- C: $obref->{"fieldname"}->method()
+ C: $obref->{"fieldname"}->method()
D: method {$obref->{"fieldname"}}
=head2 Summary
-That's about all there is to it. Now you just need to go off and buy a
+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.
@@ -315,12 +372,12 @@ 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:
+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
@@ -334,7 +391,7 @@ node such as one might use in a sophisticated tree structure:
$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
@@ -349,7 +406,7 @@ 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
+ #!/usr/bin/perl
package Subtle;
sub new {
@@ -357,12 +414,12 @@ two-phased garbage collection:
$test = \$test;
warn "CREATING " . \$test;
return bless \$test;
- }
+ }
sub DESTROY {
my $self = shift;
warn "DESTROYING $self";
- }
+ }
package main;
@@ -372,7 +429,7 @@ two-phased garbage collection:
my $b = Subtle->new;
$$a = 0; # break selfref
warn "leaving block";
- }
+ }
warn "just exited block";
warn "time to die...";
@@ -390,12 +447,12 @@ When run as F</tmp/test>, the following output is produced:
DESTROYING Subtle=SCALAR(0x8e57c) during global destruction.
Notice that "global destruction" bit there? That's the thread
-garbage collector reaching the unreachable.
+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
+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.
@@ -405,6 +462,8 @@ at a future date.
=head1 SEE ALSO
-You should also check out L<perlbot> for other object tricks, traps, and tips,
-as well as L<perlmod> for some style guides on constructing both modules
+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/gnu/usr.bin/perl/pod/perlop.pod b/gnu/usr.bin/perl/pod/perlop.pod
index 483a686ebb6..17728df9d3e 100644
--- a/gnu/usr.bin/perl/pod/perlop.pod
+++ b/gnu/usr.bin/perl/pod/perlop.pod
@@ -8,7 +8,7 @@ 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
+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)
@@ -16,7 +16,7 @@ operate on scalar values only, not array values.
nonassoc ++ --
right **
right ! ~ \ and unary + and -
- left =~ !~
+ left =~ !~
left * / % x
left + - .
left << >>
@@ -27,7 +27,7 @@ operate on scalar values only, not array values.
left | ^
left &&
left ||
- nonassoc ..
+ nonassoc .. ...
right ?:
right = += -= *= etc.
left , =>
@@ -42,8 +42,8 @@ In the following sections, these operators are covered in precedence order.
=head2 Terms and List Operators (Leftward)
-Any TERM is of highest precedence of Perl. These includes variables,
-quote and quotelike operators, any expression in parentheses,
+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
@@ -56,7 +56,7 @@ 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 look at the left side of operator or the right side of it.
+whether you are looking at the left side or the right side of the operator.
For example, in
@ary = (1, 3, sort 4, 2);
@@ -66,7 +66,7 @@ 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 parens:
+Note that you have to be careful with parentheses:
# These evaluate exit before doing the print:
print($foo, exit); # Obviously not what you want.
@@ -81,14 +81,14 @@ Also note that
print ($foo & 255) + 1, "\n";
-probably doesn't do what you expect at first glance. See
+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
+well as subroutine and method calls, and the anonymous
constructors C<[]> and C<{}>.
-See also L<Quote and Quotelike Operators> toward the end of this section,
+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
@@ -104,16 +104,16 @@ 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 Autoincrement and Autodecrement
+=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 autoincrement operator has a little extra built-in magic to it. If
+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 only been used in string contexts since it was set, and
+variable has been used in only string contexts since it was set, and
has a value that is not null 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:
@@ -123,7 +123,7 @@ character within its range, with carry:
print ++($foo = 'Az'); # prints 'Ba'
print ++($foo = 'zz'); # prints 'aaa'
-The autodecrement operator is not magical.
+The auto-decrement operator is not magical.
=head2 Exponentiation
@@ -134,7 +134,7 @@ internally.)
=head2 Symbolic Unary Operators
-Unary "!" performs logical negation, i.e. "not". See also C<not> for a lower
+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
@@ -144,12 +144,13 @@ 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.
+Unary "~" performs bitwise negation, i.e., 1's complement.
+(See also L<Integer Arithmetic>.)
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<List Operators>.)
+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
@@ -166,9 +167,8 @@ supposed to be searched, substituted, or translated 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 translation, it is interpreted as a search pattern at run
-time. This is less efficient than an explicit search, since the pattern
-must be compiled every time the expression is evaluated--unless you've
-used C</o>.)
+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.
@@ -179,12 +179,17 @@ Binary "*" multiplies two numbers.
Binary "/" divides two numbers.
-Binary "%" computes the modulus of the 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).
Binary "x" is the repetition operator. In a scalar context, it
returns a string consisting of the left operand repeated the number of
times specified by the right operand. In a list context, if the left
-operand is a list in parens, it repeats the list.
+operand is a list in parentheses, it repeats the list.
print '-' x 80; # print row of dashes
@@ -205,12 +210,12 @@ 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.
+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.
+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
@@ -240,20 +245,20 @@ but, because * is higher precedence than ||:
rand (10) * 20; # (rand 10) * 20
rand +(10) * 20; # rand (10 * 20)
-See also L<"List Operators">.
+See also L<"Terms and List Operators (Leftward)">.
=head2 Relational Operators
-Binary "<" returns true if the left argument is numerically less than
+Binary "E<lt>" returns true if the left argument is numerically less than
the right argument.
-Binary ">" returns true if the left argument is numerically greater
+Binary "E<gt>" returns true if the left argument is numerically greater
than the right argument.
-Binary "<=" returns true if the left argument is numerically less than
+Binary "E<lt>=" returns true if the left argument is numerically less than
or equal to the right argument.
-Binary ">=" returns true if the left argument is numerically greater
+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
@@ -276,8 +281,9 @@ the right argument.
Binary "!=" returns true if the left argument is numerically not equal
to the right argument.
-Binary "<=>" returns -1, 0, or 1 depending on whether the left argument is numerically
-less than, equal to, or greater than 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.
@@ -288,15 +294,21 @@ 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>.)
=head2 Bitwise Or and Exclusive Or
Binary "|" returns its operators ORed together bit by bit.
+(See also L<Integer Arithmetic>.)
Binary "^" returns its operators XORed together bit by bit.
+(See also L<Integer Arithmetic>.)
=head2 C-style Logical And
@@ -340,12 +352,12 @@ operators depending on the context. In a 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<for (1..10)> loops and for doing
slice operations on arrays. Be aware that under the current implementation,
-a temporary array is created, so you'll burn a lot of memory if you
+a temporary array is created, so you'll burn a lot of memory if you
write something like this:
for (1 .. 1_000_000) {
# code
- }
+ }
In a scalar context, ".." returns a boolean value. The operator is
bistable, like a flip-flop, and emulates the line-range (comma) operator
@@ -380,11 +392,11 @@ As a scalar operator:
As a list operator:
for (101 .. 200) { print; } # print $_ 100 times
- @foo = @foo[$[ .. $#foo]; # an expensive no-op
+ @foo = @foo[0 .. $#foo]; # an expensive no-op
@foo = @foo[$#foo-4 .. $#foo]; # slice last 5 items
The range operator (in a list context) makes use of the magical
-autoincrement algorithm if the operands are strings. You
+auto-increment algorithm if the operands are strings. You
can say
@alphabet = ('A' .. 'Z');
@@ -409,11 +421,11 @@ 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,
+ 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.
+or 3rd argument, whichever is selected.
$a = $ok ? $b : $c; # get a scalar
@a = $ok ? @b : @c; # get an array
@@ -439,8 +451,8 @@ 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:
+might trigger, such as from tie(). Other assignment operators work similarly.
+The following are recognized:
**= += *= &= <<= &&=
-= /= |= >>= ||=
@@ -475,7 +487,7 @@ argument and returns that value. This is just like C's comma operator.
In a list context, it's just the list argument separator, and inserts
both its arguments into the list.
-The => digraph is mostly just a synonym for the comma operator. It's useful for
+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.
@@ -490,7 +502,7 @@ operators without the need for extra parentheses:
open HANDLE, "filename"
or die "Can't open: $!\n";
-See also discussion of list operators in L<List Operators (Leftward)>.
+See also discussion of list operators in L<Terms and List Operators (Leftward)>.
=head2 Logical Not
@@ -501,14 +513,14 @@ It's the equivalent of "!" except for the very low precedence.
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
+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 means that it short-circuits: i.e. the right
+precedence. This means that it short-circuits: i.e., the right
expression is evaluated only if the left expression is false.
Binary "xor" returns the exclusive-OR of the two surrounding expressions.
@@ -526,16 +538,16 @@ Address-of operator. (But see the "\" operator for taking a reference.)
=item unary *
-Dereference-address operator. (Perl's prefix dereferencing
+Dereference-address operator. (Perl's prefix dereferencing
operators are typed: $, @, %, and &.)
=item (TYPE)
-Type casting operator.
+Type casting operator.
=back
-=head2 Quote and Quotelike Operators
+=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
@@ -543,7 +555,7 @@ 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
+the same character fore and aft, but the 4 sorts of brackets
(round, angle, square, curly) will all nest.
Customary Generic Meaning Interpolates
@@ -555,16 +567,25 @@ the same character fore and aft, but the 4 sorts of brackets
s{}{} Substitution yes
tr{}{} Translation no
+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>, which 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:
- \t tab
- \n newline
- \r return
- \f form feed
- \b backspace
- \a alarm (bell)
- \e escape
+ \t tab (HT, TAB)
+ \n newline (LF, 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
@@ -575,6 +596,9 @@ are interpolated, as are the following sequences:
\E end case modification
\Q quote regexp metacharacters till \E
+If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u>
+and <\U> is taken from the current locale. See L<perllocale>.
+
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
@@ -582,13 +606,13 @@ 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, backquotes
+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 Quotelike Operators
+=head2 Regexp Quote-Like Operators
-Here are the quotelike operators that apply to pattern
+Here are the quote-like operators that apply to pattern
matching and related activities.
=over 8
@@ -597,16 +621,16 @@ matching and related activities.
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 only want to see the first occurrence of
+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.
This usage is vaguely deprecated, and may be removed in some future
version of Perl.
-=item m/PATTERN/gimosx
+=item m/PATTERN/cgimosx
-=item /PATTERN/gimosx
+=item /PATTERN/cgimosx
Searches a string for a pattern match, and in a scalar context returns
true (1) or false (''). If no string is specified via the C<=~> or
@@ -614,20 +638,24 @@ 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 which apply
+when C<use locale> is in effect.
Options are:
- g Match globally, i.e. find all occurrences.
+ 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 Only compile pattern once.
+ 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. This is particularly useful for matching Unix path names
-that contain "/", to avoid LTS (leaning toothpick syndrome).
+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
@@ -644,7 +672,7 @@ successfully executed regular expression is used instead.
If used in a context that requires a list value, a pattern match returns a
list consisting of the subexpressions matched by the parentheses in the
-pattern, i.e. ($1, $2, $3...). (Note that here $1 etc. are also set, and
+pattern, i.e., (C<$1>, $2, $3...). (Note that here $1 etc. are also set, and
that this differs from Perl 4's behavior.) If the match fails, a null
array is returned. If the match succeeds, but there were no parentheses,
a list value of (1) is returned.
@@ -667,8 +695,8 @@ Examples:
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
+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
@@ -679,35 +707,93 @@ If there are no parentheses, it returns a list of all the matched
strings, as if there were parentheses around the whole pattern.
In a scalar context, C<m//g> iterates through the string, returning TRUE
-each time it matches, and FALSE when it eventually runs out of
-matches. (In other words, it remembers where it left off last time and
-restarts the search at that point. You can actually find the current
-match position of a string using the pos() function--see L<perlfunc>.)
-If you modify the string in any way, the match position is reset to the
-beginning. Examples:
+each time it matches, and FALSE when it eventually runs out of matches.
+(In other words, it remembers where it left off last time and restarts
+the search at that point. You can actually find the current match
+position of a string or set it 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 Perl 5
- while ($paragraph = <>) {
+ $/ = ""; $* = 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. Backslashes are ignored, unless
-followed by the delimiter or another backslash, in which case the
-delimiter or backslash is interpolated.
+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/
@@ -718,6 +804,7 @@ 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 qx/STRING/
@@ -731,7 +818,25 @@ with $/ or $INPUT_RECORD_SEPARATOR).
$today = qx{ date };
-See L<I/O Operators> for more discussion.
+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.
+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.
+
+Also realize that using this operator frequently leads to unportable
+programs.
+
+See L<"I/O Operators"> for more discussion.
=item qw/STRING/
@@ -745,43 +850,50 @@ 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 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 (0).
+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 a scalar variable, an array element, a hash element, or an assignment
-to one of those, i.e. an lvalue.)
+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 only want the pattern compiled once the first time
+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 a null 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 which 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.
+ g Replace globally, i.e., all occurrences.
i Do case-insensitive pattern matching.
m Treat string as multiple lines.
- o Only compile pattern once.
+ 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). If
-backquotes are used, the replacement string is a command to execute
-whose output will be used as the actual replacement text. If 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.
+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 interpreter as a full-fledged Perl expression
and eval()ed right then and there. It is, however, syntax checked at
@@ -823,11 +935,11 @@ Examples:
s/([^ ]*) *([^ ]*)/$2 $1/; # reverse 1st two fields
-Note the use of $ instead of \ in the last example. Unlike
-B<sed>, we only use the \<I<digit>> form in the left hand side.
-Anywhere else it's $<I<digit>>.
+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 just use a C</g> to get all the changes
+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
@@ -846,12 +958,12 @@ Translates 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 translated. (The
-string specified with =~ must be a scalar variable, an array element,
-or an assignment to one of those, i.e. an lvalue.) 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/>.
+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.)
+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:
@@ -914,7 +1026,7 @@ an eval():
=head2 I/O Operators
-There are several I/O operators you should know about.
+There are several I/O operators you should know about.
A string is 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
@@ -929,19 +1041,19 @@ 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
+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 included, so it's never false until end of file, at
-which time an undefined value is returned). 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> loop, the value is
-automatically assigned to the variable C<$_>. The assigned value is
-then tested to see if it is defined. (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:
+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<$_>. The assigned value is then tested to see if it is defined.
+(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; }
@@ -949,13 +1061,13 @@ write.) Anyway, the following lines are equivalent to each other:
print while defined($_ = <STDIN>);
print while <STDIN>;
-The filehandles STDIN, STDOUT and STDERR are predefined. (The
-filehandles C<stdin>, C<stdout> and C<stderr> will also work except in
+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 <FILEHANDLE> is used in a context that is looking for a list, a
+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.
@@ -974,7 +1086,7 @@ of filenames. The loop
is equivalent to the following Perl-like pseudo code:
- unshift(@ARGV, '-') if $#ARGV < $[;
+ unshift(@ARGV, '-') unless @ARGV;
while ($ARGV = shift) {
open(ARGV, $ARGV);
while (<ARGV>) {
@@ -984,9 +1096,9 @@ is equivalent to the following Perl-like pseudo code:
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 <ARGV>, which is magical. (The pseudo code above doesn't work
-because it treats <ARGV> as non-magical.)
+$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<$.>)
@@ -994,7 +1106,7 @@ continue as if the input were one big happy file. (But see example
under 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. If
-you want to pass switches into your script, you can use one of the
+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], /^-/) {
@@ -1013,7 +1125,7 @@ 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. <$foo>), then that variable contains the name of the
+variable (e.g., E<lt>$fooE<gt>), then that variable contains the name of the
filehandle to input from, or a reference to the same. For example:
$fh = \*STDIN;
@@ -1025,7 +1137,7 @@ 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. One level of
$ 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 version of Perl, programmers would insert curly
+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
@@ -1050,11 +1162,11 @@ 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 just 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
+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 only evaluates its (embedded) argument when it is starting a new
+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 a scalar context, however, the operator returns the next value
@@ -1069,11 +1181,11 @@ than
$file = <blurch*>;
because the latter will alternate between returning a filename and
-returning FALSE.
+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 notatin.
+to become confused with the indirect filehandle notation.
@files = glob("$dir/*.[ch]");
@files = glob($files[$i]);
@@ -1090,19 +1202,19 @@ 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
+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 pre-compute the number that
+the compiler will precompute the number that
expression represents so that the interpreter
won't have to.
-=head2 Integer arithmetic
+=head2 Integer Arithmetic
By default Perl assumes that it must do most of its arithmetic in
floating point. But by saying
@@ -1111,9 +1223,35 @@ floating point. But by saying
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
+countermand this by saying
no integer;
which lasts until the end of that BLOCK.
+The bitwise operators ("&", "|", "^", "~", "<<", and ">>") always
+produce integral results. 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.
+
+=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.
+
+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.
diff --git a/gnu/usr.bin/perl/pod/perlovl.pod b/gnu/usr.bin/perl/pod/perlovl.pod
deleted file mode 100644
index 208456d239e..00000000000
--- a/gnu/usr.bin/perl/pod/perlovl.pod
+++ /dev/null
@@ -1,15 +0,0 @@
-=head1 NAME
-
-perlovl - overload perl mathematical functions [superseded]
-
-=head1 DESCRIPTION
-
-This man page has been superseded by L<overload>.
-
-=head1 WARNING
-
-The old interface involving %OVERLOAD is deprecated and will go away
-RSN. Convert your scripts to
-use overload ...;
-style.
-
diff --git a/gnu/usr.bin/perl/pod/perlpod.pod b/gnu/usr.bin/perl/pod/perlpod.pod
index 6566ffb357d..6a578caec35 100644
--- a/gnu/usr.bin/perl/pod/perlpod.pod
+++ b/gnu/usr.bin/perl/pod/perlpod.pod
@@ -31,18 +31,21 @@ use however it pleases. Currently recognized commands are
=back
=cut
=pod
+ =for X
+ =begin X
+ =end X
The "=pod" directive does nothing beyond telling the compiler to lay
-off of through the next "=cut". It's useful for adding another
-paragraph to the doc if you're mixing up code and pod a lot.
+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.
-Head1 and head2 produce first and second level headings, with the text on
-the same paragraph as "=headn" forming the heading description.
+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, 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 indention.
+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
@@ -51,11 +54,48 @@ 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 you the first =item type to decide how to format the list.
+formatters use the first "=item" type to decide how to format the list.
-And don't forget, when using any command, that that command lasts up until
+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 blank lines after each command to end it's paragraph.
+can see the empty lines after each command to end its paragraph.
Some examples of lists include:
@@ -92,24 +132,34 @@ 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
+ C<code> literal code
L<name> A link (cross reference) to name
- L<name> manpage
- L<name/ident> item in manpage
- L<name/"sec"> section in other manpage
- L<"sec"> section in this manpage
+ 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
F<file> Used for filenames
X<index> An index entry
- Z<> A zero-width character
+ 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>
+
+=back
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
+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.
@@ -134,22 +184,53 @@ B<pod2html>, B<pod2latex>, and B<pod2fm>.
=head1 Embedding Pods in Perl Modules
You can embed pod documentation in your Perl scripts. Start your
-documentation with a =head1 command at the beg, and end it with
-an =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 a blank line there before
-the first pod directive.
+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 blank line there, then the translators wouldn't
+If you had not had that empty line there, then the translators wouldn't
have seen it.
+=head1 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.
+
+=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">
diff --git a/gnu/usr.bin/perl/pod/perlre.pod b/gnu/usr.bin/perl/pod/perlre.pod
index 5446746e910..14892a88460 100644
--- a/gnu/usr.bin/perl/pod/perlre.pod
+++ b/gnu/usr.bin/perl/pod/perlre.pod
@@ -5,18 +5,40 @@ perlre - Perl regular expressions
=head1 DESCRIPTION
This page describes the syntax of regular expressions in Perl. For a
-description of how to actually I<use> regular expressions in matching
+description of how to I<use> regular expressions in matching
operations, plus various examples of the same, see C<m//> and C<s///> in
L<perlop>.
-The matching operations can
-have various modifiers, some of which relate to the interpretation of
-the regular expression inside. These are:
+The matching operations can have various modifiers. The modifiers
+which relate to the interpretation of the regular expression inside
+are listed below. For the modifiers that alter the behaviour of the
+operation, see L<perlop/"m//"> and L<perlop/"s//">.
- i Do case-insensitive pattern matching.
- m Treat string as multiple lines.
- s Treat string as single line.
- x Extend your pattern's legibility with whitespace and comments.
+=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.
+
+=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
@@ -24,13 +46,15 @@ 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 not
-backslashed or within a character class. You can use this to break up
+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. Taken together, these features go a
-long way towards making Perl 5 a readable language. See the C comment
-deletion code in L<perlop>.
+just as in ordinary Perl code. This also means that if you want real
+whitespace or C<#> characters in the pattern that you'll have to either
+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. See the C comment deletion code in L<perlop>.
=head2 Regular Expressions
@@ -51,8 +75,8 @@ meanings:
() Grouping
[] Character class
-By default, the "^" character is guaranteed to match only at the
-beginning of the string, the "$" character only at the end (or before the
+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
@@ -60,10 +84,10 @@ 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 deprecated in Perl 5.)
+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 tells Perl to pretend
+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.
@@ -83,12 +107,10 @@ 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 without causing the rest of the pattern not to match.
-The standard quantifiers are all "greedy", in that they match as many
-occurrences as possible (given a particular starting location) without
-causing the pattern to fail. If you want it to match the minimum number
-of times possible, follow the quantifier with a "?" after any of them.
-Note that the meanings don't change, just the "gravity":
+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
@@ -97,15 +119,15 @@ Note that the meanings don't change, just the "gravity":
{n,}? Match at least n times
{n,m}? Match at least n but not more than m times
-Since patterns are processed as double quoted strings, the following
+Because patterns are processed as double quoted strings, the following
also work:
- \t tab
- \n newline
- \r return
- \f form feed
- \a alarm (bell)
- \e escape (think troff)
+ \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
@@ -114,7 +136,10 @@ also work:
\L lowercase till \E (think vi)
\U uppercase till \E (think vi)
\E end case modification (think vi)
- \Q quote regexp metacharacters till \E
+ \Q quote (disable) regexp metacharacters till \E
+
+If C<use locale> is in effect, the case map used by C<\l>, C<\L>, C<\u>
+and <\U> is taken from the current locale. See L<perllocale>.
In addition, Perl defines the following:
@@ -126,48 +151,58 @@ In addition, Perl defines the following:
\D Match a non-digit character
Note that C<\w> matches a single alphanumeric character, not a whole
-word. To match a word you'd need to say C<\w+>. 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).
+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)
- \G Match only where previous m//g left off
+ \A Match at only beginning of string
+ \Z Match at only end of string (or before newline at the end)
+ \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 and a C<\W> on the other side of it (in
+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(?!\n)>.
+you can use C<\Z(?!\n)>. The C<\G> assertion can be used to chain global
+matches (using C<m//g>), as described in
+L<perlop/"Regexp Quote-Like Operators">.
-When the bracketing construct C<( ... )> is used, \<digit> matches the
+It is also useful when writing C<lex>-like scanners, when you have several
+regexps which 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 \<digit> notation can on rare occasion work
+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 $<digit> (and C<$`>, C<$&>, and C<$'>)
+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 ?.
+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 parens before
+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. ($0 used to return the same thing, but not any
+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:
@@ -179,28 +214,40 @@ everything after the matched string. Examples:
$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 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.
+
You will note that all 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 \\, \(, \), \<, \>, \{, or \} is always
-interpreted as a literal character, not a metacharacter. This makes it
-simple to quote a string that you want to use for a pattern but that
-you are afraid might contain metacharacters. Simply quote all the
+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 the
non-alphanumeric characters:
$pattern =~ s/(\W)/\\$1/g;
-You can also use the built-in quotemeta() function to do this.
-An even easier way to quote metacharacters right in the match operator
-is to say
+Now it is much more common to see either the quotemeta() function or
+the \Q escape sequence used to disable the metacharacters special
+meanings like this:
/$unquoted\Q$quoted\E$unquoted/
-Perl 5 defines a consistent extension syntax for regular expressions.
-The syntax is a pair of parens with a question mark as the first thing
-within the parens (this was a syntax error in Perl 4). The character
-after the question mark gives the function of the extension. Several
-extensions are already supported:
+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
@@ -211,7 +258,7 @@ whitespace formatting, a simple C<#> will suffice.
=item (?:regexp)
-This groups things like "()" but doesn't make backrefences like "()" does. So
+This groups things like "()" but doesn't make backreferences like "()" does. So
split(/\b(?:a|b|c)\b/)
@@ -235,7 +282,7 @@ use this for lookbehind: C</(?!foo)bar/> will not find an occurrence of
"bar" that is preceded by something which is not "foo". 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
+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)...|^..?)bar/>. Sometimes it's still
easier just to say:
@@ -248,7 +295,7 @@ easier just to say:
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 merely need to include C<(?i)> at the front of the
+insensitive ones need to include merely C<(?i)> at the front of the
pattern. For example:
$pattern = "foobar";
@@ -291,7 +338,7 @@ 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 had the
+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."
@@ -330,7 +377,7 @@ 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: 53147>, number is <>.
+ Beginning is <I have 2 numbers: 53147>, number is <>.
Here are some variants, most of which don't work:
@@ -370,11 +417,10 @@ 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 in
-order to know which variety of success you will achieve.
+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 nondigits not
+tricker. Imagine you'd like to find a sequence of non-digits not
followed by "123". You might try to write that as
$_ = "ABC123";
@@ -401,23 +447,23 @@ This prints
3: got AB
4: got ABC
-You might have expected test 3 to fail because it just seems to a more
+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
-nondigits, you have something that's not 123?" If the pattern matcher had
+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.
+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.
+in the hope of matching the complete regular expression.
-Well now,
+Well now,
the pattern really, I<really> wants to succeed, so it uses the
-standard regexp backoff-and-retry and lets C<\D*> expand to just "AB" this
+standard regexp 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.
@@ -460,7 +506,7 @@ 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 which normally function as metacharacters to be interpreted
-literally by prefixing them with a "\" (e.g. "\." matches a ".", not any
+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.
@@ -470,13 +516,17 @@ in C<[]>, which will match any one of the characters in 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 the characters between "a" and "z",
-inclusive.
+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 hexidecimal digits, matches the
+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>).
@@ -500,7 +550,7 @@ Subpatterns are numbered based on the left to right order of their
opening parenthesis. Note that 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", since subpattern 1
+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.
@@ -512,7 +562,7 @@ Some people get too used to writing things like
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 right-hand side of a C<s///> is a double-quoted string. C<\1> 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>
@@ -528,3 +578,7 @@ 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 SEE ALSO
+
+"Mastering Regular Expressions" (see L<perlbook>) by Jeffrey Friedl.
diff --git a/gnu/usr.bin/perl/pod/perlref.pod b/gnu/usr.bin/perl/pod/perlref.pod
index d528bc87974..6aa086088d9 100644
--- a/gnu/usr.bin/perl/pod/perlref.pod
+++ b/gnu/usr.bin/perl/pod/perlref.pod
@@ -7,40 +7,49 @@ perlref - Perl references and nested data structures
Before release 5 of Perl it was difficult to represent complex data
structures, because all references had to be symbolic, and even that was
difficult to do when you wanted to refer to a variable rather than a
-symbol table entry. Perl 5 not only makes it easier to use symbolic
+symbol table entry. Perl not only makes it easier to use symbolic
references to variables, but lets you have "hard" references to any piece
-of data. Any scalar may hold a hard reference. Since arrays and hashes
+of data. 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. 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.)
-
-A symbolic reference contains the name of a variable, just as a
-symbolic link in the filesystem merely contains the name of a file.
-The C<*glob> notation is a kind of symbolic reference. Hard references
-are more like hard links in the file system: merely another way
-at getting at the same underlying object, irrespective of its name.
-
-"Hard" 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 scalar. It doesn't magically start being an array or a hash
-unless you tell it so explicitly by dereferencing it.
-
-References can be constructed several ways.
+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, like in the following paragraph, it usually is 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.
+
+References can be constructed 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 works in C.) Note
-that this typically creates I<ANOTHER> reference to a variable, since
+(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:
@@ -49,8 +58,13 @@ reference that the backslash returned. Here are some examples:
$arrayref = \@ARGV;
$hashref = \%ENV;
$coderef = \&handler;
- $globref = \*STDOUT;
+ $globref = \*foo;
+It isn't possible to create a true reference to an IO handle (filehandle or
+dirhandle) using the backslash operator. See the explanation of the
+*foo{THING} syntax below. (However, you're apt to find Perl code
+out there using globrefs as though they were IO handles, which is
+grandfathered into continued functioning.)
=item 2.
@@ -60,17 +74,20 @@ brackets:
$arrayref = [1, 2, ['a', 'b', 'c']];
Here we've constructed a reference to an anonymous array of three elements
-whose final element is itself reference to another anonymous array of three
+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, $arrayref-E<gt>[2][1] would have
+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!
+ @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.
@@ -126,8 +143,8 @@ 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 provides a different
-mechanism to do that already--see L<perlobj>.
+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
@@ -157,7 +174,7 @@ 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 only applies to lexical variables, by the way. Dynamic variables
+This applies to only 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.
@@ -176,27 +193,62 @@ named new(), but don't have to be:
=item 6.
References of the appropriate type can spring into existence if you
-dereference them in a context that assumes they exist. Since we haven't
+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.
-References to filehandles can be created by taking a reference to
-a typeglob. This is currently the best way to pass filehandles into or
+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.
+
+The use of *foo{IO} is the best way to pass bareword filehandles into or
out of subroutines, or to store them in larger data structures.
- 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>;
}
+Beware, though, that you can't do this with a routine which is going to
+open the filehandle for you, because *HANDLE{IO} will be undef if HANDLE
+hasn't been used yet. Use \*HANDLE for that sort of thing instead.
+
+Using \*HANDLE (or *HANDLE) is another way to use and store non-bareword
+filehandles (before perl version 5.002 it was the only way). The two
+methods are largely interchangeable, you can do
+
+ splutter(\*STDOUT);
+ $rec = get_rec(\*STDIN);
+
+with the above subroutine definitions.
+
=back
That's it for creating references. By now you're probably dying to
@@ -207,9 +259,9 @@ are several basic methods.
=item 1.
-Anywhere you'd put an identifier 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:
+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);
@@ -230,28 +282,28 @@ However, a "simple scalar" includes an identifier that itself uses method
=item 2.
-Anywhere you'd put an identifier 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:
+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 you use FileHandle
+ $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
+ &{ $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 parens instead of braces. That's not the case.
+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:
@@ -266,14 +318,15 @@ it's presumably referencing. That would be case 3.
=item 3.
-The case of individual array elements arises often enough that it gets
-cumbersome to use method 2. As a form of syntactic sugar, the two
-lines like that above can be written:
+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";
- $hashref->{"KEY"} = "VALUE";
+ $arrayref->[0] = "January"; # Array element
+ $hashref->{"KEY"} = "VALUE"; # Hash element
+ $coderef->(1,2,3); # Subroutine call
-The left side of the array can be any expression returning a reference,
+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:
@@ -317,7 +370,7 @@ reference is pointing to. See L<perlfunc>.
The bless() operator may be used to associate a reference with a package
functioning as an object class. See L<perlobj>.
-A typeglob may be dereferenced the same way a reference can, since
+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.
@@ -332,7 +385,7 @@ 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 yeilds @{[$n + 5]} widgets\n";
+ print "That yields @{[$n + 5]} widgets\n";
=head2 Symbolic references
@@ -364,7 +417,7 @@ 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
+block. An inner block may countermand that with
no strict 'refs';
@@ -377,15 +430,15 @@ invisible to this mechanism. For example:
{
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 5.001 is that the brackets
-around a symbolic reference behave more like quotes, just as they
+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 ";
@@ -402,7 +455,7 @@ and even
print ${ push } . "over";
will have the same effect. (This would have been a syntax error in
-5.000, though Perl 4 allowed it in the spaceless form.) Note that this
+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:
@@ -416,7 +469,7 @@ subscripting a hash. So now, instead of writing
$array{ "aaa" }{ "bbb" }{ "ccc" }
-you can just write
+you can write just
$array{ aaa }{ bbb }{ ccc }
@@ -433,7 +486,7 @@ makes it more than a bareword:
$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, since the
+But it will no longer warn you about using lowercase words, because the
string is effectively quoted.
=head1 WARNING
@@ -443,8 +496,8 @@ 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 attemping. You might want to do something
+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;
diff --git a/gnu/usr.bin/perl/pod/perlrun.pod b/gnu/usr.bin/perl/pod/perlrun.pod
index 4f6294cc69b..a847133bb9a 100644
--- a/gnu/usr.bin/perl/pod/perlrun.pod
+++ b/gnu/usr.bin/perl/pod/perlrun.pod
@@ -33,7 +33,7 @@ Contained in the file specified by the first filename on the command line.
=item 3.
-Passed in implicitly via standard input. This only works if there are
+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.
@@ -44,13 +44,13 @@ 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 __END__ token.)
+of the script using the C<__END__> token.)
-As of Perl 5, the #! line is always examined for switches as the line is
-being parsed. Thus, if you're on a machine that only allows 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.
+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
@@ -62,13 +62,18 @@ 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 perl $0 -S ${1+"$@"}'
- if 0;
+ eval 'exec /usr/bin/perl $0 -S ${1+"$@"}'
+ if $running_under_some_shell;
to let Perl see the B<-p> switch.
@@ -81,12 +86,90 @@ 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 partway through before finding a syntax error.)
+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 .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.
+
+=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 Switches
A single-character switch may be combined with the following switch, if
@@ -100,7 +183,7 @@ Switches include:
=item B<-0>[I<digits>]
-specifies the record separator (C<$/>) as an octal number. If there are
+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
@@ -109,7 +192,7 @@ 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 since there is no
+The value 0777 will cause Perl to slurp files whole because there is no
legal character with that value.
=item B<-a>
@@ -133,7 +216,7 @@ An alternate delimiter may be specified using B<-F>.
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,
-since these are considered as occurring outside the execution of
+because these are considered as occurring outside the execution of
your program.
=item B<-d>
@@ -146,47 +229,47 @@ 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<number>
+=item B<-D>I<letters>
-=item B<-D>I<list>
+=item B<-D>I<number>
sets debugging flags. To watch how it executes your script, use
-B<-D14>. (This only works if debugging is compiled into your
-Perl.) Another nice value is B<-D1024>, which lists your compiled
-syntax tree. And B<-D512> displays compiled regular expressions. As an
-alternative specify a list of letters instead of numbers (e.g. B<-D14> is
+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 Label Stack Processing
- 8 t Trace Execution
- 16 o Operator Node Construction
- 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
- 1024 x Syntax Tree Dump
- 2048 u Tainting Checks
- 4096 L Memory Leaks (not supported anymore)
- 8192 H Hash Dump -- usurps values()
- 16384 X Scratchpad Allocation
- 32768 D Cleaning Up
+ 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 (not supported anymore)
+ 8192 H Hash dump -- usurps values()
+ 16384 X Scratchpad allocation
+ 32768 D Cleaning up
=item B<-e> I<commandline>
-may be used to enter one line of script.
+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.
+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.
+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
+pattern may be surrounded by C<//>, C<"">, or C<''>, otherwise it will be
put in single quotes.
=item B<-h>
@@ -231,23 +314,24 @@ 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.
-You can use C<eof> without parenthesis to locate the end of each input file,
-in case you want to append to each file, or reset line numbering (see
+You can use C<eof> without parenthesis 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>).
=item B<-I>I<directory>
Directories specified by B<-I> are prepended to the search path for
-modules (@INC), and also tells the C preprocessor where to search 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 the line terminator when used with B<-n> or
-B<-p>, and second, it assigns "C<$\>" to have the value of I<octnum> so that
-any print statements will have that line terminator added back on. If
+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:
@@ -259,7 +343,7 @@ separator if the B<-l> switch is followed by a B<-0> switch:
gnufind / -print0 | perl -ln0e 'print "found $_" if -p'
-This sets $\ to newline and then sets $/ to the null character.
+This sets C<$\> to newline and then sets C<$/> to the null character.
=item B<-m>[B<->]I<module>
@@ -279,7 +363,7 @@ 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 built-in syntactic sugar means you can also say
+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
@@ -297,8 +381,10 @@ B<awk>:
}
Note that the lines are not printed by default. See B<-p> to have
-lines printed. Here is an efficient way to delete all files older than
-a week:
+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;'
@@ -317,11 +403,14 @@ makes it iterate over filename arguments somewhat like B<sed>:
while (<>) {
... # your script goes here
} continue {
- print;
+ print or die "-p destination: $!\n";
}
-Note that the lines are printed automatically. To suppress printing
-use the B<-n> switch. A B<-p> overrides a B<-n> switch.
+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.
@@ -329,9 +418,9 @@ the implicit loop, just as in awk.
=item B<-P>
causes your script to be run through the C preprocessor before
-compilation by Perl. (Since both comments and cpp directives begin
+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".)
+recognized by the C preprocessor such as "if", "else", or "define".)
=item B<-s>
@@ -347,12 +436,30 @@ prints "true" if and only if the script is invoked with a B<-xyz> switch.
=item B<-S>
makes Perl use the PATH environment variable to search for the
-script (unless the name of the script starts with a slash). Typically
-this is used to emulate #! startup on machines that don't support #!,
-in the following manner:
+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 file 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 -S $0 $*"
+ eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
if $running_under_some_shell;
The system ignores the first line and feeds the script to /bin/sh,
@@ -364,15 +471,15 @@ 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. A better construct than C<$*> would be C<${1+"$@"}>, which
handles embedded spaces and such in the filenames, but doesn't work if
-the script is being interpreted by csh. In order to start up sh rather
+the script is being interpreted by csh. 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:
+will work under any of csh, sh, or Perl, such as the following:
eval '(exit $?0)' && eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'
& eval 'exec /usr/bin/perl -S $0 $argv:q'
- if 0;
+ if $running_under_some_shell;
=item B<-T>
@@ -398,7 +505,9 @@ Perl.
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.
+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>
@@ -415,27 +524,115 @@ Prints to STDOUT the value of the named configuration variable.
=item B<-w>
-prints warnings about identifiers that are mentioned only once, and
+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 readonly 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.
-See L<perldiag> and L<perltrap>.
+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 (but only one group of switches, as with normal #!
-processing). If a directory name is specified, Perl will switch to
-that directory before running the script. The B<-x> switch only
-controls the the disposal of leading garbage. The script must be
+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(). 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 your perl executable was built with B<-DDEBUGGING_MSTATS>,
+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/gnu/usr.bin/perl/pod/perlsec.pod b/gnu/usr.bin/perl/pod/perlsec.pod
index ccae6e82a9d..73884790b0f 100644
--- a/gnu/usr.bin/perl/pod/perlsec.pod
+++ b/gnu/usr.bin/perl/pod/perlsec.pod
@@ -4,144 +4,334 @@ perlsec - Perl security
=head1 DESCRIPTION
-Perl is designed to make it easy to write secure setuid and setgid
-scripts. Unlike shells, which are based on multiple substitution
-passes on each line of the script, Perl uses a more conventional
-evaluation scheme with fewer hidden "gotchas". Additionally, since the
-language has more built-in functionality, it has to rely less upon
-external (and possibly untrustworthy) programs to accomplish its
-purposes.
+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.
-Beyond the obvious problems that stem from giving special privileges to
-such flexible systems as scripts, on many operating systems, setuid
-scripts are inherently insecure right from the start. This is because
-that between the time that the kernel opens up the file to see what to
-run, and when the now setuid interpreter it ran turns around and reopens
-the file so it can interpret it, things may have changed, especially if
-you have symbolic links on your system.
+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.
-Fortunately, sometimes this kernel "feature" can be disabled.
-Unfortunately, there are two ways to disable it. The system can simply
-outlaw scripts with the setuid bit set, which doesn't help much.
-Alternately, it can simply ignore the setuid bit 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.
+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. 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.
-If, however, the kernel setuid script feature isn't disabled, Perl will
-complain loudly that your setuid script is insecure. You'll need to
-either disable the kernel setuid script feature, or put a C wrapper around
-the script. See the program B<wrapsuid> in the F<eg> directory of your
-Perl distribution for how to go about doing this.
-
-There are some systems on which setuid scripts are free of this inherent
-security bug. For example, recent releases of Solaris are like this. On
-such systems, when the kernel passes the name of the setuid script to open
-to the interpreter, rather than using a pathname subject to mettling, it
-instead passes /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.
-
-When executing a setuid script, or when you have turned on taint checking
-explicitly using the B<-T> flag, Perl takes special precautions to
-prevent you from falling into any obvious traps. (In some ways, a Perl
-script is more secure than the corresponding C program.) Any command line
-argument, environment variable, or input is marked as "tainted", and may
-not be used, directly or indirectly, in any command that invokes a
-subshell, or in any command that modifies files, directories, or
-processes. Any variable that is set within an expression that has
-previously referenced a tainted value also becomes tainted (even if it is
-logically impossible for the tainted value to influence the variable).
For example:
- $foo = shift; # $foo is tainted
- $bar = $foo,'bar'; # $bar is also tainted
- $xxx = <>; # Tainted
+ $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
- $abc = 'abc'; # Not tainted
+ $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
- system "echo $foo"; # Insecure
- system "/bin/echo", $foo; # Secure (doesn't use sh)
- system "echo $bar"; # Insecure
- system "echo $abc"; # Insecure until PATH set
+ $path = $ENV{'PATH'}; # $path now tainted
$ENV{'PATH'} = '/bin:/usr/bin';
- $ENV{'IFS'} = '' if $ENV{'IFS'} ne '';
+ delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
- $path = $ENV{'PATH'}; # Not tainted
- system "echo $abc"; # Is secure now!
+ $path = $ENV{'PATH'}; # $path now NOT tainted
+ system "echo $data"; # Is secure now!
- open(FOO,"$foo"); # OK
- open(FOO,">$foo"); # Not OK
+ open(FOO, "< $arg"); # OK - read-only file
+ open(FOO, "> $arg"); # Not OK - trying to write
- open(FOO,"echo $foo|"); # Not OK, but...
- open(FOO,"-|") || exec 'echo', $foo; # OK
+ open(FOO,"echo $arg|"); # Not OK, but...
+ open(FOO,"-|")
+ or exec 'echo', $arg; # OK
- $zzz = `echo $foo`; # Insecure, zzz tainted
+ $shout = `echo $arg`; # Insecure, $shout now tainted
- unlink $abc,$foo; # Insecure
- umask $foo; # Insecure
+ unlink $data, $arg; # Insecure
+ umask $arg; # Insecure
- exec "echo $foo"; # Insecure
- exec "echo", $foo; # Secure (doesn't use sh)
- exec "sh", '-c', $foo; # Considered secure, alas
+ exec "echo $arg"; # Insecure
+ exec "echo", $arg; # Secure (doesn't use the shell)
+ exec "sh", '-c', $arg; # Considered secure, alas!
-The taintedness is associated with each scalar value, so some elements
-of an array can be tainted, and others not.
+ @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 PATH". Note that you
-can still write an insecure system call or exec, but only by explicitly
-doing something like the last example above. You can also bypass the
-tainting mechanism by referencing subpatterns--Perl presumes that if
-you reference a substring using $1, $2, etc, you knew what you were
-doing when you wrote the pattern:
-
- $ARGV[0] =~ /^-P(\w+)$/;
- $printer = $1; # Not tainted
-
-This is fairly secure since C<\w+> doesn't match shell metacharacters.
-Use of C</.+/> would have been insecure, but Perl doesn't check for that,
-so you must be careful with your patterns. This is the I<ONLY> mechanism
-for untainting user supplied filenames if you want to do file operations
-on them (unless you make C<$E<gt>> equal to C<$E<lt>> ).
-
-For "Insecure $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 the world.
-A frequently voiced gripe is that you can get this message even
-if the pathname to an executable is fully qualified. But Perl can't
-know that the executable in question isn't going to execute some other
-program depending on the PATH.
+can still write an insecure B<system> or B<exec>, but only by explicitly
+doing something like the last 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.
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 after setting C<$E<gt> = $E<lt>>. (Remember group IDs,
-too!) Perl doesn't prevent you from opening tainted filenames for reading,
+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.
-This gives us a reasonably safe way to open a file or pipe: just reset the
-id set to the original IDs. Here's a way to do backticks reasonably
-safely. Notice how the exec() is not called with a string that the shell
-could expand. By the time we get to the exec(), tainting is turned off,
-however, so be careful what you call and what you pass it.
+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.
- die unless defined $pid = open(KID, "-|");
+ use English;
+ die "Can't fork: $!" unless defined $pid = open(KID, "-|");
if ($pid) { # parent
while (<KID>) {
# do something
- }
+ }
close KID;
} else {
- $> = $<;
- $) = $(; # BUG: initgroups() not called
- exec 'program', 'arg1', 'arg2';
- die "can't exec program: $!";
- }
-
-For those even more concerned about safety, see the I<Safe> and I<Safe CGI>
-modules at a CPAN site near you. See L<perlmod> for a list of CPAN sites.
+ my @temp = ($EUID, $EGID);
+ $EUID = $UID;
+ $EGID = $GID; # XXX: initgroups() not called
+ # Make sure privs are really gone
+ ($EUID, $EGID) = @temp;
+ die "Can't drop privileges" unless
+ $UID == $EUID and
+ $GID eq $EGID; # String test
+ $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.
+
+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." You should see a lawyer to be sure your licence's wording will
+stand up in court.
diff --git a/gnu/usr.bin/perl/pod/perlstyle.pod b/gnu/usr.bin/perl/pod/perlstyle.pod
index e4a5aab41fd..bfc94a9eaa9 100644
--- a/gnu/usr.bin/perl/pod/perlstyle.pod
+++ b/gnu/usr.bin/perl/pod/perlstyle.pod
@@ -6,13 +6,13 @@ perlstyle - Perl style guide
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.
+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 <use sigtrap> and even <use diagnostics> pragmas may also prove
+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
@@ -32,7 +32,7 @@ Opening curly on same line as keyword, if possible, otherwise line up.
=item *
-Space before the opening curly of a multiline BLOCK.
+Space before the opening curly of a multi-line BLOCK.
=item *
@@ -64,7 +64,7 @@ Uncuddled elses.
=item *
-No space between function name and its opening paren.
+No space between function name and its opening parenthesis.
=item *
@@ -76,7 +76,7 @@ Long lines broken after an operator (except "and" and "or").
=item *
-Space after last paren matching on current line.
+Space after last parenthesis matching on current line.
=item *
@@ -88,7 +88,7 @@ Omit redundant punctuation as long as clarity doesn't suffer.
=back
-Larry has his reasons for each of these things, but he doen't claim that
+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:
@@ -117,7 +117,7 @@ is better than
$verbose && print "Starting analysis\n";
-since the main point isn't whether the user typed B<-v> or not.
+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
@@ -135,7 +135,7 @@ 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
-parens in the wrong place.
+parentheses in the wrong place.
=item *
@@ -154,13 +154,13 @@ the middle. Just "outdent" it a little to make it more visible:
=item *
Don't be afraid to use loop labels--they're there to enhance
-readability as well as to allow multi-level loop breaks. See the
+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
+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.
@@ -169,7 +169,7 @@ the system() function instead.
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<$]> ($PERL_VERSION in C<English>) to see if it
+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.
@@ -178,7 +178,7 @@ determined by the B<Configure> program when Perl was installed.
Choose mnemonic identifiers. If you can't remember what mnemonic means,
you've got a problem.
-=item *
+=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
@@ -189,20 +189,20 @@ 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
-filesystems' representations of module names as files that must fit into a
-few sparse bites.
+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:
+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
+ $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->as_string().
+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.
@@ -216,9 +216,9 @@ 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 punctuational
+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 parens.
+functions or list operators to avoid excessive ampersands and parentheses.
=item *
@@ -227,12 +227,12 @@ 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.
+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;
+ $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: $!";
diff --git a/gnu/usr.bin/perl/pod/perlsub.pod b/gnu/usr.bin/perl/pod/perlsub.pod
index b308298858a..16babd2092c 100644
--- a/gnu/usr.bin/perl/pod/perlsub.pod
+++ b/gnu/usr.bin/perl/pod/perlsub.pod
@@ -22,8 +22,8 @@ To import subroutines:
To call subroutines:
- NAME(LIST); # & is optional with parens.
- NAME LIST; # Parens optional if predeclared/imported.
+ NAME(LIST); # & is optional with parentheses.
+ NAME LIST; # Parentheses optional if predeclared/imported.
&NAME; # Passes current @_ to subroutine.
=head1 DESCRIPTION
@@ -47,21 +47,33 @@ there's really no difference from the language's perspective.)
Any arguments passed to the routine come in as the array @_. Thus if you
called a function with two arguments, those would be stored in C<$_[0]>
-and C<$_[1]>. The array @_ is a local array, but its values are implicit
-references (predating L<perlref>) to the actual scalar parameters. The
-return value of the subroutine is the value of the last expression
-evaluated. Alternatively, a return statement may be used to specify the
-returned value and exit the subroutine. If you return one or more arrays
-and/or hashes, these will be flattened together into one large
-indistinguishable list.
+and C<$_[1]>. The array @_ 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 @_ 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 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 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 the sections below on 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">.
+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:
@@ -81,7 +93,7 @@ Example:
sub get_line {
$thisline = $lookahead; # GLOBAL VARIABLES!!
- LINE: while ($lookahead = <STDIN>) {
+ LINE: while (defined($lookahead = <STDIN>)) {
if ($lookahead =~ /^[ \t]/) {
$thisline .= $lookahead;
}
@@ -105,13 +117,13 @@ Use array assignment to a local list to name your formal arguments:
}
This also has the effect of turning call-by-reference into call-by-value,
-since the assignment copies the values. Otherwise a function is free to
-do in-place modifications of @_ and change its callers values.
+because the assignment copies the values. Otherwise a function is free to
+do in-place modifications of @_ and change its caller's values.
upcase_in($v1, $v2); # this changes $v1 and $v2
sub upcase_in {
- for (@_) { tr/a-z/A-Z/ }
- }
+ 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
@@ -119,17 +131,17 @@ argument were actually literal and you tried to change it, you'd take a
upcase_in("frederick");
-It would be much safer if the upcase_in() function
+It would be much safer if the 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/ }
- # wantarray checks if we were called in list context
+ 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 @_
@@ -149,13 +161,14 @@ 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 @a and
made @b an empty list. See L</"Pass by Reference"> for alternatives.
-A subroutine may be called using the "&" prefix. The "&" is optional in
-Perl 5, and so are the parens if the subroutine has been predeclared.
-(Note, however, that the "&" is I<NOT> optional when you're just naming
-the subroutine, such as when it's used as an argument to defined() or
-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.)
+A subroutine may be called using the "&" prefix. The "&" is optional
+in modern Perls, and so are the parentheses if the subroutine has been
+predeclared. (Note, however, that the "&" is I<NOT> optional when
+you're just naming the subroutine, such as when it's used as an
+argument to defined() or 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 "&" form, the argument list is optional, and if omitted, no @_ array is
@@ -170,7 +183,7 @@ new users may wish to avoid.
&foo(); # the same
&foo; # foo() get current args, like foo(@_) !!
- foo; # like foo() IFF sub foo pre-declared, else "foo"
+ foo; # like foo() IFF sub foo predeclared, else "foo"
Not only does the "&" form make the argument list optional, but it also
disables any prototype checking on the arguments you do provide. This
@@ -187,11 +200,12 @@ Synopsis:
my @oof = @bar; # declare @oof lexical, and init it
A "my" declares the listed variables to be confined (lexically) to the
-enclosing block, subroutine, C<eval>, or C<do/require/use>'d file. If
-more than one value is listed, the list must be placed in parens. All
-listed elements must be legal lvalues. Only alphanumeric identifiers may
-be lexically scoped--magical builtins like $/ must currently be localized with
-"local" instead.
+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 $/ must currently be localized with "local" instead.
Unlike dynamic variables created by the "local" statement, lexical
variables declared with "my" are totally hidden from the outside world,
@@ -216,7 +230,7 @@ this is used to name the parameters to a subroutine. Examples:
my $arg = shift; # name doesn't matter
$arg **= 1/3;
return $arg;
- }
+ }
The "my" is simply a modifier on something you might assign to. So when
you do assign to the variables in its argument list, the "my" doesn't
@@ -225,11 +239,11 @@ change whether those variables is viewed as a scalar or an array. So
my ($foo) = <STDIN>;
my @FOO = <STDIN>;
-both supply a list context to the righthand side, while
+both supply a list context to the right-hand side, while
my $foo = <STDIN>;
-supplies a scalar context. But the following only declares one variable:
+supplies a scalar context. But the following declares only one variable:
my $foo, $bar = 1;
@@ -243,13 +257,56 @@ the current statement. Thus,
my $x = $x;
-can be used to initialize the new $x with the value of the old $x, and
+can be used to initialize the new $x with the value of the old $x, and
the expression
my $x = 123 and $x == 123
is false unless the old $x happened to have the value 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 $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 $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 "my", then it is lexically
+scoped instead. Thus in the loop
+
+ for my $i (1, 2, 3) {
+ some_function();
+ }
+
+the scope of $i extends to the end of the loop, but not beyond it, and
+so the value of $i is unavailable in 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
@@ -263,8 +320,9 @@ otherwise. An inner block may countermand this with S<"no strict 'vars'">.
A 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 C<use strict 'vars'>. The actual initialization doesn't happen
-until run time, so gets executed every time through a loop.
+quiet 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 "my" are not part of any package and are therefore
never fully qualified with the package name. In particular, you're not
@@ -284,9 +342,9 @@ lexical of the same name is also visible:
That will print out 20 and 10.
-You may declare "my" variables at the outer most scope of a file to
-totally hide any such identifiers from the outside world. This is similar
-to a C's static variables at the file level. To do this with a subroutine
+You may declare "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). If a block (such as
an eval(), function, or C<package>) wants to create a private subroutine
that cannot be called from outside that block, it can declare a lexical
@@ -297,7 +355,7 @@ variable containing an anonymous sub reference:
&$secret_sub();
As long as the reference is never returned by any function within the
-module, no outside module can see the subroutine, since its name is not in
+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
$some_pack::secret_version or anything; it's just $secret_version,
unqualified and unqualifiable.
@@ -314,35 +372,35 @@ 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;
+ 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
+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 my()
+all in the main program, you'll need to arrange for the my()
to be executed early, either by putting the whole block above
-your pain program, or more likely, merely placing a BEGIN
+your main program, or more likely, placing merely a BEGIN
sub around it to make sure it gets executed before your program
starts to run:
sub BEGIN {
- my $secret_val = 0;
+ my $secret_val = 0;
sub gimme_another {
return ++$secret_val;
- }
- }
+ }
+ }
See L<perlrun> about the BEGIN function.
=head2 Temporary Values via local()
B<NOTE>: In general, you should be using "my" instead of "local", because
-it's faster and safer. Execeptions to this include the global punctuation
+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 "local" though, as do
other variables whose current value must be visible to called
@@ -359,18 +417,18 @@ Synopsis:
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
+ local *merlyn = \$randal; # just alias $merlyn, not @merlyn etc
A local() modifies its listed variables to be local to the enclosing
-block, (or subroutine, C<eval{}> or C<do>) and I<the any called from
+block, (or subroutine, C<eval{}>, or C<do>) and I<any called from
within that block>. A local() just gives temporary values to global
(meaning package) variables. This is known as dynamic scoping. Lexical
scoping is done with "my", which works more like C's auto declarations.
If more than one variable is given to local(), they must be placed in
-parens. All listed elements must be legal lvalues. This operator works
+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
+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
@@ -380,9 +438,9 @@ subroutine. Examples:
for $i ( 0 .. 9 ) {
$digits{$i} = $i;
- }
+ }
# assume this function uses global %digits hash
- parse_num();
+ parse_num();
# now temporarily add to %digits hash
if ($base12) {
@@ -392,7 +450,7 @@ subroutine. Examples:
}
# old %digits restored here
-Because local() is a run-time command, and so gets executed every time
+Because 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
@@ -405,12 +463,48 @@ as a scalar or an array. So
local($foo) = <STDIN>;
local @FOO = <STDIN>;
-both supply a list context to the righthand side, while
+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..]
+
+
=head2 Passing Symbol Table Entries (typeglobs)
[Note: The mechanism described in this section was originally the only
@@ -422,12 +516,12 @@ 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 "type glob", since the
+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 type glob produces a scalar value that represents
-all the objects of that name, including any filehandle, format or
+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 "*" value was assigned to it. Example:
@@ -442,22 +536,23 @@ whatever "*" value was assigned to it. Example:
Note that scalars are already passed by reference, so you can modify
scalar arguments without using this mechanism by referring explicitly
-to $_[0] etc. You can modify all the elements of an array by passing
+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 * mechanism (or
-the equivalent reference mechanism) to push, pop or change the size of
+the equivalent reference mechanism) to push, 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, since normally the LIST
+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">.
+the individual arrays. For more on typeglobs, see
+L<perldata/"Typeglobs and Filehandles">.
=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>.
+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
@@ -471,29 +566,29 @@ list of all their former last elements:
my @retlist = ();
foreach $aref ( @_ ) {
push @retlist, pop @$aref;
- }
+ }
return @retlist;
- }
+ }
-Here's how you might write a function that returns a
+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 );
+ @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 just using the normal list return mechanism.
-What happens if you want to pass or return a hash? Well,
-if you're only using one of them, or you don't mind them
+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.
+a little expensive.
Where people get into trouble is here:
@@ -501,7 +596,7 @@ Where people get into trouble is here:
or
(%a, %b) = func(%c, %d);
-That syntax simply won't work. It just sets @a or %a and clears the @b or
+That syntax simply won't work. It sets just @a or %a and clears the @b or
%b. Plus the function didn't get passed into two separate arrays or
hashes: it got one long list in @_, as always.
@@ -518,8 +613,8 @@ in order of how many elements they have in them:
return ($cref, $dref);
} else {
return ($dref, $cref);
- }
- }
+ }
+ }
It turns out that you can actually do this also:
@@ -531,12 +626,12 @@ It turns out that you can actually do this also:
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 my()
-variables, since only globals (well, and local()s) are in the symbol table.
+variables, because only globals (well, and local()s) are in the symbol table.
If you're passing around filehandles, you could usually just use the bare
typeglob, like *STDOUT, but typeglobs references would be better because
@@ -554,17 +649,20 @@ they'll still work properly under C<use strict 'refs'>. For example:
return scalar <$fh>;
}
+Another way to do this is using *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;
- }
+ 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 FileHandle
-functions supplied with the POSIX package.
+of L<perlfunc/open()> for a somewhat cleaner way using the IO::Handle
+package.
=head2 Prototypes
@@ -574,7 +672,7 @@ As of the 5.002 release of perl, if you declare
then mypush() takes arguments exactly like push() does. The declaration
of the function to be called must be visible at compile time. The prototype
-only affects the interpretation of new-style calls to the function, where
+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
@@ -583,10 +681,10 @@ 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, since it depends
+function to be called is indeterminate at compile time, because it depends
on inheritance.
-Since the intent is primarily to let you define subroutines that work
+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.
@@ -627,7 +725,7 @@ A semicolon separates mandatory arguments from optional arguments.
Note how the last three examples above are treated specially by the parser.
mygrep() is parsed as a true list operator, myrand() is parsed as a
true unary operator with unary precedence the same as rand(), and
-mytime() is truly argumentless, just like time(). That is, if you
+mytime() is truly without arguments, just like time(). That is, if you
say
mytime +2;
@@ -637,7 +735,7 @@ without the prototype.
The interesting thing about & is that you can generate new syntax with it:
- sub try (&$) {
+ sub try (&@) {
my($try,$catch) = @_;
eval { &$try };
if ($@) {
@@ -645,7 +743,7 @@ The interesting thing about & is that you can generate new syntax with it:
&$catch;
}
}
- sub catch (&) { @_ }
+ sub catch (&) { $_[0] }
try {
die "phooey";
@@ -657,7 +755,7 @@ That prints "unphooey". (Yes, there are still unresolved
issues having to do with the visibility of @_. I'm ignoring that
question for the moment. (But note that if we make @_ lexically
scoped, those anonymous subroutines can act like closures... (Gee,
-is this sounding a little Lispish? (Nevermind.))))
+is this sounding a little Lispish? (Never mind.))))
And here's a reimplementation of grep:
@@ -687,7 +785,7 @@ 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:
@@ -698,21 +796,74 @@ returning a list:
Then you've just supplied an automatic scalar() in front of their
argument, which can be more than a bit surprising. The old @foo
which used to hold one thing doesn't get passed in. Instead,
-the func() now gets passed in 1, that is, the number of elments
+the func() now gets passed in 1, that is, the number of elements
in @foo. And the split() gets called in a scalar context and
starts scribbling on your @_ parameter list.
-This is all very powerful, of course, and should only be used in moderation
-to make the world a better place.
+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 constant.pm for an easy way to declare most
+constants.)
+
+All of the following functions would 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 which 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 only be
-tried occasionally and for good reason. Typically this might be
+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 only be done by importing the name from a
+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:
@@ -721,8 +872,14 @@ via the import syntax, and these names may then override the builtin ones:
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 "open"
-or "chdir" as part of their default @EXPORT list, since these may
+or "chdir" as part of their default @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 @EXPORT_OK list, then it's
possible for a user to import the name explicitly, but not implicitly.
@@ -736,6 +893,10 @@ and it would import the open override, but if they said
they would get the default imports without the overrides.
+Note that such overriding is restricted to the package that requests
+the import. Some means of "globally" overriding builtins may become
+available in future.
+
=head2 Autoloading
If you call a subroutine that is undefined, you would ordinarily get an
@@ -762,12 +923,12 @@ should just call system() with those arguments. All you'd do is this:
my $program = $AUTOLOAD;
$program =~ s/.*:://;
system($program, @_);
- }
+ }
date();
- who('am', i');
+ who('am', 'i');
ls('-l');
-In fact, if you preclare the functions you want to call that way, you don't
+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);
@@ -779,13 +940,14 @@ 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>, the standard SelfLoader modules in L<SelfLoader>, and
-the document on adding C functions to perl code in L<perlxs>.
+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 on references. 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
+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/gnu/usr.bin/perl/pod/perlsyn.pod b/gnu/usr.bin/perl/pod/perlsyn.pod
index c3ef4501dde..9c3f6617bd0 100644
--- a/gnu/usr.bin/perl/pod/perlsyn.pod
+++ b/gnu/usr.bin/perl/pod/perlsyn.pod
@@ -32,20 +32,23 @@ 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
+the beginning or the end of the script. However, if you're using
lexically-scoped private variables created with 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 to be able to access those private variables.
+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 (prototyped to take one scalar parameter) without defining it by saying just:
+subroutine without defining it by saying C<sub name>, thus:
- sub myname ($);
+ sub myname;
$me = myname $0 or die "can't get myname";
-Note that it functions as a list operator though, not as a unary
-operator, so be careful to use C<or> instead of C<||> there.
+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 functonion 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.
@@ -63,9 +66,9 @@ 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, since you may eventually add another line.)
+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),
+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,
@@ -91,7 +94,7 @@ can write loops like:
} until $line eq ".\n";
See L<perlfunc/do>. Note also that the loop control
-statements described later will I<NOT> work in this construct, since
+statements described later will I<NOT> work in this construct, because
modifiers don't take loop labels. Sorry. You can always wrap
another block around it to do that sort of thing.
@@ -128,7 +131,7 @@ all do the same thing:
open(FOO) ? 'hi mom' : die "Can't open $FOO: $!";
# a bit exotic, that last one
-The C<if> statement is straightforward. Since BLOCKs are always
+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.
@@ -178,25 +181,26 @@ want to skip ahead and get the next record.
while (<>) {
chomp;
- if (s/\\$//) {
- $_ .= <>;
+ if (s/\\$//) {
+ $_ .= <>;
redo unless eof();
}
# now process $_
- }
+ }
which is Perl short-hand for the more explicitly written version:
- LINE: while ($line = <ARGV>) {
+ LINE: while (defined($line = <ARGV>)) {
chomp($line);
- if ($line =~ s/\\$//) {
- $line .= <ARGV>;
+ if ($line =~ s/\\$//) {
+ $line .= <ARGV>;
redo LINE unless eof(); # not eof(ARGV)!
}
# now process $line
- }
+ }
-Or here's a a simpleminded Pascal comment stripper (warning: assumes no { or } in strings)
+Or here's a simpleminded Pascal comment stripper (warning: assumes no
+{ or } in strings).
LINE: while (<STDIN>) {
while (s|({.*}.*){.*}|$1 |) {}
@@ -220,11 +224,8 @@ 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.
-In either the C<if> or the C<while> statement, you may replace "(EXPR)"
-with a BLOCK, and the conditional is true if the value of the last
-statement in that block is true. While this "feature" continues to work in
-version 5, it has been deprecated, so please change any occurrences of "if BLOCK" to
-"if (do BLOCK)".
+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
@@ -244,27 +245,32 @@ is the same as this:
$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
+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. 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.
-This can cause problems if you have subroutine or format declarations
-within that block's scope.
+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
+with you have subroutine or format declarations.)
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. If VAR is
@@ -278,7 +284,7 @@ Examples:
for (@ary) { s/foo/bar/ }
- foreach $elem (@elements) {
+ foreach my $elem (@elements) {
$elem *= 2;
}
@@ -294,8 +300,8 @@ Examples:
Here's how a C programmer might code up a particular algorithm in Perl:
- for ($i = 0; $i < @ary1; $i++) {
- for ($j = 0; $j < @ary2; $j++) {
+ 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 :-(
}
@@ -304,32 +310,32 @@ Here's how a C programmer might code up a particular algorithm in Perl:
# this is where that last takes me
}
-Whereas here's how a Perl programmer more confortable with the idiom might
+Whereas here's how a Perl programmer more comfortable with the idiom might
do it:
- OUTER: foreach $wid (@ary1) {
- INNER: foreach $jet (@ary2) {
+ 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
+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.
+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.
@@ -368,19 +374,19 @@ or
or formatted so it stands out more as a "proper" switch statement:
SWITCH: {
- /^abc/ && do {
- $abc = 1;
- last SWITCH;
+ /^abc/ && do {
+ $abc = 1;
+ last SWITCH;
};
- /^def/ && do {
- $def = 1;
- last SWITCH;
+ /^def/ && do {
+ $def = 1;
+ last SWITCH;
};
- /^xyz/ && do {
- $xyz = 1;
- last SWITCH;
+ /^xyz/ && do {
+ $xyz = 1;
+ last SWITCH;
};
$nothing = 1;
}
@@ -414,14 +420,14 @@ a temporary assignment to $_ for convenient matching:
/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" }
- elsif ($flag & O_WRONLY) { ($flag & O_APPEND) ? "a" : "w" }
+ if ($flag & O_RDONLY) { "r" }
+ elsif ($flag & O_WRONLY) { ($flag & O_APPEND) ? "a" : "w" }
elsif ($flag & O_RDWR) {
if ($flag & O_CREAT) { "w+" }
else { ($flag & O_APPEND) ? "a+" : "r+" }
@@ -473,14 +479,14 @@ encounters a line that begins with an equal sign and a word, like this
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>.
+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
+ The snazzle() function will behave in the most spectacular
form that you can possibly imagine, not even excepting
cybernetic pyrotechnics.
@@ -489,11 +495,11 @@ and your documentation text freely, as in
sub snazzle($) {
my $thingie = shift;
.........
- }
+ }
-Note that pod translators should only look at paragraphs beginning
-with a pod diretive (it makes parsing easier), whereas the compiler
-actually knows to look for pod escapes even in the middle of a
+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.
@@ -506,3 +512,47 @@ ignored by both the compiler and the translators.
You probably shouldn't rely upon the 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 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/gnu/usr.bin/perl/pod/perltie.pod b/gnu/usr.bin/perl/pod/perltie.pod
index 96f61eb4360..c6eb7156ce3 100644
--- a/gnu/usr.bin/perl/pod/perltie.pod
+++ b/gnu/usr.bin/perl/pod/perltie.pod
@@ -13,8 +13,8 @@ perltie - how to hide an object class in a simple variable
=head1 DESCRIPTION
Prior to release 5.0 of Perl, a programmer could use dbmopen()
-to magically connect an on-disk database in the standard Unix dbm(3x)
-format to a %HASH in their program. However, their Perl was either
+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.
@@ -33,13 +33,14 @@ 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(), or TIEHASH(). (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.
+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.
@@ -59,10 +60,10 @@ 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<E<lt>Jarkko.Hietaniemi@hut.fiE<gt>>'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.
+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;
@@ -104,8 +105,8 @@ variable C<$^W> to see whether to emit a bit of noise anyway.
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. Since in this case
-we're just using a SCALAR ref for the tied scalar object, a simple $$self
+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.
@@ -159,7 +160,7 @@ argument--the new value the user is trying to assign.
=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 ncessary, since Perl
+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.
@@ -172,7 +173,7 @@ C++, you know. We'll use a DESTROY method here for debugging purposes only.
=back
That's about all there is to it. Actually, it's more than all there
-is to it, since we've done a few nice things here for the sake
+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.
@@ -192,7 +193,7 @@ take an exception. (Well, if you access an individual element; an
aggregate assignment would be missed.) For example:
require Bounded_Array;
- tie @ary, Bounded_Array, 2;
+ tie @ary, 'Bounded_Array', 2;
$| = 1;
for $i (0 .. 10) {
print "setting index $i: ";
@@ -252,7 +253,7 @@ 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 simply keep them at one tie type per class.
+to keep them at simply one tie type per class.
=item STORE this, index, value
@@ -273,7 +274,7 @@ there. For example:
=item DESTROY this
This method will be triggered when the tied variable needs to be destructed.
-As with the sclar tie class, this is almost never needed in a
+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.
@@ -292,19 +293,18 @@ the following output demonstrates:
=head2 Tying Hashes
-As the first Perl data type to be tied (see dbmopen()), associative arrays
-have the most complete and useful tie() implementation. A class
-implementing a tied associative array 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.
+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 merely inherit
-from the standard Tie::Hash module for most of your methods, redefining only
-the interesting ones. See L<Tie::Hash> for details.
+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
@@ -312,22 +312,22 @@ 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 dotfiles. You index into the hash
-with the name of the file (minus the dot) and you get back that dotfile's
+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;
+ tie %dot, 'DotFiles';
if ( $dot{profile} =~ /MANPATH/ ||
$dot{login} =~ /MANPATH/ ||
$dot{cshrc} =~ /MANPATH/ )
{
- print "you seem to set your manpath\n";
+ print "you seem to set your MANPATH\n";
}
Or here's another sample of using our tied class:
- tie %him, DotFiles, 'daemon';
+ tie %him, 'DotFiles', 'daemon';
foreach $f ( keys %him ) {
printf "daemon dot file %s is size %d\n",
$f, length $him{$f};
@@ -346,7 +346,7 @@ whose dot files this object represents
=item HOME
-where those dotfiles live
+where those dot files live
=item CLOBBER
@@ -354,7 +354,7 @@ whether we should try to change or remove those dot files
=item LIST
-the hash of dotfile names and content mappings
+the hash of dot file names and content mappings
=back
@@ -366,7 +366,7 @@ Here's the start of F<Dotfiles.pm>:
my $DEBUG = 0;
sub debug { $DEBUG = @_ ? shift : 1 }
-For our example, we want to able to emit debugging info to help in tracing
+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.
@@ -412,8 +412,8 @@ Here's the constructor:
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, since we didn't chdir() there, it would
-have been testing the wrong file.
+in question. Otherwise, because we didn't chdir() there, it would
+have been testing the wrong file.
=item FETCH this, key
@@ -444,7 +444,7 @@ Here's the fetch for our DotFiles example.
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, since dot files are a Unixy concept, we're
+more efficient). Of course, because dot files are a Unixy concept, we're
not that concerned.
=item STORE this, key, value
@@ -509,22 +509,30 @@ be careful to check whether they really want to clobber files.
croak "@{[&whowasi]}: won't remove file $file"
unless $self->{CLOBBER};
delete $self->{LIST}->{$dot};
- unlink($file) || carp "@{[&whowasi]}: can't unlink $file: $!";
+ 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 dotfiles! It's such a
+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 dotfiles for $self->{USER}"
+ croak "@{[&whowasi]}: won't remove all dot files for $self->{USER}"
unless $self->{CLOBBER} > 1;
my $dot;
foreach $dot ( keys %{$self->{LIST}}) {
@@ -565,8 +573,8 @@ 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 our using a real hash so we'll just do the simple
-thing, but we'll have to indirect through the LIST field.
+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;
@@ -592,7 +600,7 @@ 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);
+ tie(%HIST, 'NDBM_File', '/usr/lib/news/history', 1, 0);
while (($key,$val) = each %HIST) {
print $key, ' = ', unpack('L',$val), "\n";
}
@@ -600,7 +608,220 @@ use the each() function to iterate over such. Example:
=head2 Tying FileHandles
-This isn't implemented yet. Sorry; maybe someday.
+This is partially implemented now.
+
+A class implementing a tied filehandle should define the following
+methods: TIEHANDLE, at least one of PRINT, PRINTF, READLINE, GETC, or READ,
+and possibly 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 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 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
@@ -617,10 +838,12 @@ 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 partially address this need is the MLDBM
-module. Check your nearest CPAN site as described in L<perlmod> for
+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/gnu/usr.bin/perl/pod/perltoc.pod b/gnu/usr.bin/perl/pod/perltoc.pod
index d761fcb1505..ce4267e7ce7 100644
--- a/gnu/usr.bin/perl/pod/perltoc.pod
+++ b/gnu/usr.bin/perl/pod/perltoc.pod
@@ -6,3125 +6,4926 @@ 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 be quickly scanned or grepped
+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
+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
-
-HOME, LOGDIR, PATH, PERL5LIB, PERL5DB, PERLLIB
-
=item AUTHOR
-
=item FILES
-
=item SEE ALSO
-
=item DIAGNOSTICS
-
=item BUGS
-
=item NOTES
+=head2 perlfaq - frequently asked questions about Perl ($Date: 1997/04/24
+22:46:06 $)
+=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
-=head2 perldata - Perl data types
+=item Where to get this document
-=item DESCRIPTION
+=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 Variable names
+=item Noncommercial Reproduction
+=item Commercial Reproduction
-=item Context
+=item Disclaimer
+=back
-=item Scalar values
+=item Changes
+24/April/97, 23/April/97, 25/March/97, 18/March/97, 17/March/97 Version,
+Initial Release: 11/March/97
-=item Scalar value constructors
+=head2 perlfaq1 - General Questions About Perl ($Revision: 1.2 $, $Date:
+1997/04/24 22:43:34 $)
+=item DESCRIPTION
-=item List value constructors
+=over
+=item What is Perl?
-=item Typeglobs and FileHandles
+=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?
-=back
+=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?
-=head2 perlsyn - Perl syntax
+=item What's the difference between "perl" and "Perl"?
-=item DESCRIPTION
+=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.2 $,
+$Date: 1997/11/30 07:59:32 $)
+
+=item DESCRIPTION
=over
-=item Declarations
+=item What machines support Perl? Where do I get it?
+=item How can I get a binary version of Perl?
-=item Simple statements
+=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 Compound statements
+=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 Loop Control
+=item Is there an ISO or ANSI certified version of Perl?
+=item Where can I get information on Perl?
-=item For Loops
+=item What are the Perl newsgroups on USENET? Where do I post questions?
+=item Where should I post source code?
-=item Foreach Loops
+=item Perl Books
+=item Perl in Magazines
-=item Basic BLOCKs and Switch Statements
+=item Perl on the Net: FTP and WWW Access
+=item What mailing lists are there for perl?
-=item Goto
+MacPerl, Perl5-Porters, NTPerl, Perl-Packrats
+=item Archives of comp.lang.perl.misc
-=item PODs: Embedded Documentation
+=item Perl Training
+=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.2 $, $Date: 1997/04/24
+22:43:42 $)
+=item DESCRIPTION
-=head2 perlop - Perl operators and precedence
+=over
-=item SYNOPSIS
+=item How do I do (anything)?
+=item How can I use Perl interactively?
-=item DESCRIPTION
+=item Is there a Perl shell?
+=item How do I debug my Perl programs?
-=over
+=item How do I profile my Perl programs?
-=item Terms and List Operators (Leftward)
+=item How do I cross-reference my Perl programs?
+=item Is there a pretty-printer (formatter) for Perl?
-=item The Arrow Operator
+=item Is there a ctags for Perl?
+=item Where can I get Perl macros for vi?
-=item Autoincrement and Autodecrement
+=item Where can I get perl-mode for emacs?
+=item How can I use curses with Perl?
-=item Exponentiation
+=item How can I use X or Tk with Perl?
+=item How can I generate simple menus without using CGI or Tk?
-=item Symbolic Unary Operators
+=item Can I dynamically load C routines into Perl?
+=item What is undump?
-=item Binding Operators
+=item How can I make my Perl program run faster?
+=item How can I make my Perl program take less memory?
-=item Multiplicative Operators
+=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 Additive Operators
+=item How can I make my CGI script more efficient?
+=item How can I hide the source for my Perl program?
-=item Shift Operators
+=item How can I compile my Perl program into byte code or C?
+=item How can I get '#!perl' to work on [MS-DOS,NT,...]?
-=item Named Unary Operators
+=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 Relational Operators
+=item Where can I learn about CGI or Web programming in Perl?
+=item Where can I learn about object-oriented Perl programming?
-=item Equality Operators
+=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 Bitwise And
+=item When I tried to run my script, I got this message. What does it
+mean?
+=item What's MakeMaker?
-=item Bitwise Or and Exclusive Or
+=back
+=item AUTHOR AND COPYRIGHT
-=item C-style Logical And
+=head2 perlfaq4 - Data Manipulation ($Revision: 1.2 $, $Date: 1997/04/24
+22:43:57 $)
+=item DESCRIPTION
-=item C-style Logical Or
+=item Data: Numbers
+=over
-=item Range Operator
+=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 Conditional Operator
+=item Does perl have a round function? What about ceil() and floor()?
+Trig functions?
+=item How do I convert bits into ints?
-=item Assignment Operators
+=item How do I multiply matrices?
+=item How do I perform an operation on a series of integers?
-=item Comma Operator
+=item How can I output Roman numerals?
+=item Why aren't my random numbers random?
-=item List Operators (Rightward)
+=back
+=item Data: Dates
-=item Logical Not
+=over
+=item How do I find the week-of-the-year/day-of-the-year?
-=item Logical And
+=item How can I compare two date strings?
+=item How can I take a string and turn it into epoch seconds?
-=item Logical or and Exclusive Or
+=item How can I find the Julian Day?
+=item Does Perl have a year 2000 problem?
-=item C Operators Missing From Perl
+=back
+=item Data: Strings
-unary &, unary *, (TYPE)
+=over
-=item Quote and Quotelike Operators
+=item How do I validate input?
+=item How do I unescape a string?
-=item Regexp Quotelike Operators
+=item How do I remove consecutive pairs of characters?
+=item How do I expand function calls in a string?
-?PATTERN?, m/PATTERN/gimosx, /PATTERN/gimosx, q/STRING/, C<'STRING'>,
-qq/STRING/, "STRING", qx/STRING/, `STRING`, qw/STRING/,
-s/PATTERN/REPLACEMENT/egimosx, tr/SEARCHLIST/REPLACEMENTLIST/cds,
-y/SEARCHLIST/REPLACEMENTLIST/cds
+=item How do I find matching/nesting anything?
-=item I/O Operators
+=item How do I reverse a string?
+=item How do I expand tabs in a string?
-=item Constant Folding
+=item How do I reformat a paragraph?
+=item How can I access/change the first N letters of a string?
-=item Integer arithmetic
+=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)
-=back
+=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?
-=head2 perlre - Perl regular expressions
+=item What's wrong with always quoting "$vars"?
-=item DESCRIPTION
+=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 Regular Expressions
+=item What is the difference between $array[1] and @array[1]?
+=item How can I extract just the unique elements of an array?
-(?#text), (?:regexp), (?=regexp), (?!regexp), (?imsx)
+a) If @in is sorted, and you want @out to be sorted:, 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 Backtracking
+=item How can I tell whether an 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 Version 8 Regular Expressions
+=item How do I find the first array element for which a condition is true?
+=item How do I handle linked lists?
-=item WARNING on \1 vs $1
+=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?
-=head2 perlrun - how to execute the Perl interpreter
+=item What happens if I add or remove keys from a hash while iterating over
+it?
-=item SYNOPSIS
+=item How do I look up a hash element by value?
+=item How can I know how many entries are in a hash?
-=item DESCRIPTION
+=item How do I sort a hash (optionally by value instead of key)?
+=item How can I always keep my hash sorted?
-=over
+=item What's the difference between "delete" and "undef" with hashes?
-=item Switches
+=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?
-B<-0>I<digits>, B<-a>, B<-c>, B<-d>, B<-d:foo>, B<-D>I<number>,
-B<-D>I<list>, B<-e> I<commandline>, B<-F>I<regexp>, B<-i>I<extension>,
-B<-I>I<directory>, B<-l>I<octnum>, B<-m>I<module>, B<-M>I<module>,
-B<-n>, B<-p>, B<-P>, B<-s>, B<-S>, B<-T>, B<-u>, B<-U>, B<-v>, B<-V>,
-B<-V:name>, B<-w>, B<-x> I<directory>
+=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?
-=head2 perlfunc - Perl builtin functions
+=item How do I determine whether a scalar is a number/whole/integer/float?
-=item DESCRIPTION
+=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.2 $, $Date: 1997/04/24
+22:44:02 $)
+
+=item DESCRIPTION
=over
-=item Perl Functions by Category
+=item How do I flush/unbuffer a 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?
-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
+=item How do I count the number of lines in a file?
-=item Alphabetical Listing of Perl Functions
+=item How do I make a temporary file name?
+=item How can I manipulate fixed-record-length files?
--X FILEHANDLE, -X EXPR, -X, abs VALUE, accept NEWSOCKET,GENERICSOCKET,
-alarm SECONDS, 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, chroot FILENAME, close FILEHANDLE, closedir
-DIRHANDLE, connect SOCKET,NAME, continue BLOCK, cos EXPR, crypt
-PLAINTEXT,SALT, dbmclose ASSOC_ARRAY, dbmopen ASSOC,DBNAME,MODE,
-defined EXPR, delete EXPR, die LIST, do BLOCK, do SUBROUTINE(LIST), do
-EXPR, dump LABEL, each ASSOC_ARRAY, eof FILEHANDLE, eof (), eof, eval
-EXPR, eval BLOCK, exec LIST, exists EXPR, exit EXPR, exp EXPR, 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, getservb
+=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 set up a footer format to be used with write()?
+=item How can I write() into a string?
-=back
+=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 the file read-write it wipes it out?
+=item Why do I sometimes get an "Argument list too long" when I use <*>?
-=head2 perlvar - Perl predefined variables
+=item Is there a leak/bug in glob()?
-=item DESCRIPTION
+=item How can I open a file with a leading "E<gt>" or trailing blanks?
+=item How can I reliably rename a file?
-=over
+=item How can I lock a file?
-=item Predefined Names
+=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?
-$ARG, $_, $<I<digit>>, $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, $!, $EVAL_ERROR, $@, $PROCESS_ID, $PID, $$, $REAL_USER_ID,
-$UID, $<,
+=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?
-=back
+=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?
-=head2 perlsub - Perl subroutines
+=item How do I open a file without blocking?
-=item SYNOPSIS
+=item How do I create a file only if it doesn't exist?
+=item How do I do a C<tail -f> in perl?
-=item DESCRIPTION
+=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.2 $, $Date: 1997/11/30 07:59:32 $)
+
+=item DESCRIPTION
=over
-=item Private Variables via my()
+=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 Temporary Values via local()
+=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 Passing Symbol Table Entries (typeglobs)
+=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 Pass by Reference
+=item How can I make C<\w> match accented characters?
+=item How can I match a locale-smart version of C</[a-zA-Z]/>?
-=item Prototypes
+=item How can I quote a variable to use in a regexp?
+=item What is C</o> really for?
-=item Overriding Builtin Functions
+=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 Autoloading
+=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?
-=back
+=item How do I efficiently match many regular expressions at once?
-=item SEE ALSO
+=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?
-=head2 perlmod - Perl modules (packages)
+=item How can I match strings with multibyte characters?
-=item DESCRIPTION
+=back
+
+=item AUTHOR AND COPYRIGHT
+=head2 perlfaq7 - Perl Language Issues ($Revision: 1.2 $, $Date:
+1997/04/24 22:44:14 $)
+
+=item DESCRIPTION
=over
-=item Packages
+=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 Symbol Tables
+=item Do I always/never have to quote my strings or use semicolons and
+commas?
+=item How do I skip some return values?
-=item Package Constructors and Destructors
+=item How do I temporarily block warnings?
+=item What's an extension?
-=item Perl Classes
+=item Why do Perl operators have different precedence than C operators?
+=item How do I declare/create a structure?
-=item Perl Modules
+=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?
-=back
+=item What is variable suicide and how can I prevent it?
-=item NOTE
+=item How can I pass/return a {Function, FileHandle, Array, Hash, Method,
+Regexp}?
+Passing Variables and Functions, Passing Filehandles, Passing Regexps,
+Passing Methods
-=item THE PERL MODULE LIBRARY
+=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 "local($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.2 $, $Date: 1997/04/24
+22:44:19 $)
+
+=item DESCRIPTION
=over
-=item Pragmatic Modules
+=item How do I find out which operating system I'm running under?
+=item How come exec() doesn't return?
-diagnostics, integer, less, overload, sigtrap, strict, subs
+=item How do I do fancy stuff with the keyboard/screen/mouse?
-=item Standard Modules
+Keyboard, Screen, Mouse
+=item How do I ask the user for a password?
-AnyDBM_File, AutoLoader, AutoSplit, Benchmark, Carp, Config, Cwd,
-DB_File, Devel::SelfStubber, DynaLoader, English, Env, Exporter,
-ExtUtils::Liblist, ExtUtils::MakeMaker, ExtUtils::Manifest,
-ExtUtils::Mkbootstrap, ExtUtils::Miniperl, Fcntl, File::Basename,
-File::CheckTree, File::Find, FileHandle, File::Path, Getopt::Long,
-Getopt::Std, I18N::Collate, IPC::Open2, IPC::Open3, Net::Ping, POSIX,
-SelfLoader, Safe, Socket, Test::Harness, Text::Abbrev
+=item How do I read and write the serial port?
-=item Extension Modules
+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
-=back
+=item How do I trap control characters/signals?
-=item CPAN
+=item How do I modify the shadow password file on a Unix system?
+=item How do I set the time and date?
-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
+=item How can I sleep() or alarm() for under a second?
-=item Modules: Creation, Use and Abuse
+=item How can I measure time under a second?
+=item How can I do an atexit() or setjmp()/longjmp()? (Exception handling)
-=over
+=item Why doesn't my sockets program work under System V (Solaris)? What
+does the error message "Protocol not supported" mean?
-=item Guidelines for Module Creation
+=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()?
-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 Why do setuid perl scripts complain about kernel problems?
-=item Guidelines for Converting Perl 4 Library Scripts into Modules
+=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()?
-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 How can I capture STDERR from an external command?
-=item Guidelines for Reusing Application Code
+=item Why doesn't open() return an error when a pipe open fails?
+=item What's wrong with using backticks in a void context?
-Complete applications rarely belong in the Perl Module Library, Many
-applications contain some perl code which 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
+=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?
-=back
+=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?
-=head2 perlref - Perl references and nested data structures
+Unix, VMS
-=item DESCRIPTION
+=item How do I close a process's filehandle without waiting for it to
+complete?
+=item How do I fork a daemon process?
-=over
+=item How do I make my program run with sh and csh?
-=item Symbolic references
+=item How do I find out if I'm running interactively or not?
+=item How do I timeout a slow event?
-=item Not-so-symbolic references
+=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?
-=back
+=item How do I open a file without blocking?
-=item WARNING
+=item How do I install a CPAN module?
+=item How do I keep my own module/library directory?
-=item SEE ALSO
+=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 How do I get one key from the terminal at a time, under POSIX?
+=item AUTHOR AND COPYRIGHT
-=head2 perldsc - Perl Data Structures Cookbook
+=head2 perlfaq9 - Networking ($Revision: 1.2 $, $Date: 1997/04/24 22:44:29
+$)
=item DESCRIPTION
+=over
-arrays of arrays, hashes of arrays, arrays of hashes, hashes of hashes,
-more elaborate constructs, recursive and self-referential data
-structures, objects
+=item My CGI script runs from the command line but not the browser. Can
+you help me fix it?
-=item REFERENCES
+=item How do I remove HTML from a string?
+=item How do I extract URLs?
-=item COMMON MISTAKES
+=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 CAVEAT ON PRECEDENCE
+=item How do I fetch an HTML file?
+=item how do I decode or create those %-encodings on the web?
-=item WHY YOU SHOULD ALWAYS C<use strict>
+=item How do I redirect to another page?
+=item How do I put a password on my web pages?
-=item DEBUGGING
+=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 CODE EXAMPLES
+=item How do I parse an email header?
+=item How do I decode a CGI form?
-=item LISTS OF LISTS
+=item How do I check a valid email address?
+=item How do I decode a MIME/BASE64 string?
-=over
+=item How do I return the user's email address?
-=item Declaration of a LIST OF LISTS
+=item How do I send/read mail?
+=item How do I find out my hostname/domainname/IP address?
-=item Generation of a LIST OF LISTS
+=item How do I fetch a news article or the active newsgroups?
+=item How do I fetch/put an FTP file?
-=item Access and Printing of a LIST OF LISTS
+=item How can I do RPC in Perl?
+=back
+=item AUTHOR AND COPYRIGHT
+=head2 perldelta - what's new for perl5.004
-=back
+=item DESCRIPTION
-=item HASHES OF LISTS
+=item Supported Environments
+=item Core Changes
=over
-=item Declaration of a HASH OF LISTS
+=item List assignment to %ENV works
+=item "Can't locate Foo.pm in @INC" error now lists @INC
-=item Generation of a HASH OF LISTS
+=item Compilation option: Binary compatibility with 5.003
+=item $PERL5OPT environment variable
-=item Access and Printing of a HASH OF LISTS
+=item Limitations on B<-M>, B<-m>, and B<-T> options
+=item More precise warnings
+=item Deprecated: Inherited C<AUTOLOAD> for non-methods
+=item Previously deprecated %OVERLOAD is no longer usable
-=back
+=item Subroutine arguments created only when they're modified
-=item LISTS OF HASHES
+=item Group vector changeable with C<$)>
+=item Fixed parsing of $$<digit>, &$<digit>, etc.
-=over
+=item No resetting of $. on implicit close
-=item Declaration of a LIST OF HASHES
+=item C<wantarray> may return undef
+=item Changes to tainting checks
-=item Generation of a LIST OF HASHES
+No glob() or <*>, No spawning if tainted $CDPATH, $ENV, $BASH_ENV, No
+spawning if tainted $TERM doesn't look like a terminal name
+=item New Opcode module and revised Safe module
-=item Access and Printing of a LIST OF HASHES
+=item Embedding improvements
+=item Internal change: FileHandle class based on IO::* classes
+=item Internal change: PerlIO abstraction interface
+=item New and changed syntax
-=back
+$coderef->(PARAMS)
-=item HASHES OF HASHES
+=item New and changed builtin constants
+__PACKAGE__
-=over
+=item New and changed builtin variables
-=item Declaration of a HASH OF HASHES
+$^E, $^H, $^M
+=item New and changed builtin functions
-=item Generation of a HASH OF HASHES
+delete on slices, flock, printf and sprintf, keys as an lvalue, my() in
+Control Structures, pack() and unpack(), sysseek(), use VERSION, use Module
+VERSION LIST, prototype(FUNCTION), srand, $_ as Default, C<m//gc> does not
+reset search position on failure, C<m//x> ignores whitespace before ?*+{},
+nested C<sub{}> closures work now, formats work right on changing lexicals
+=item New builtin methods
-=item Access and Printing of a HASH OF HASHES
+isa(CLASS), can(METHOD), VERSION( [NEED] )
+
+=item TIEHANDLE now supported
+TIEHANDLE classname, LIST, PRINT this, LIST, PRINTF this, LIST, READ this
+LIST, READLINE this, GETC this, DESTROY this
+=item Malloc enhancements
+-DDEBUGGING_MSTATS, -DPERL_EMERGENCY_SBRK, -DPACK_MALLOC, -DTWO_POT_OPTIMIZE
+
+=item Miscellaneous efficiency enhancements
=back
-=item MORE ELABORATE RECORDS
+=item Support for More Operating Systems
+
+=over
+
+=item Win32
+
+=item Plan 9
+=item QNX
+
+=item AmigaOS
+
+=back
+
+=item Pragmata
+
+use autouse MODULE => qw(sub1 sub2 sub3), use blib, use blib 'dir', use
+constant NAME => VALUE, use locale, use ops, use vmsish
+
+=item Modules
=over
-=item Declaration of MORE ELABORATE RECORDS
+=item Required Updates
+=item Installation directories
-=item Declaration of a HASH OF COMPLEX RECORDS
+=item Module information summary
+=item Fcntl
-=item Generation of a HASH OF COMPLEX RECORDS
+=item IO
+
+=item Math::Complex
+=item Math::Trig
+=item DB_File
+=item Net::Ping
+
+=item Object-oriented overrides for builtin operators
=back
-=item Database Ties
+=item Utility Changes
+=over
-=item SEE ALSO
+=item pod2html
+Sends converted HTML to standard output
-=item AUTHOR
+=item xsubpp
+C<void> XSUBs now default to returning nothing
+=back
+=item C Language API Changes
+
+C<gv_fetchmethod> and C<perl_call_sv>, C<perl_eval_pv>, Extended API for
+manipulating hashes
+
+=item Documentation Changes
+
+L<perldelta>, L<perlfaq>, L<perllocale>, L<perltoot>, L<perlapio>,
+L<perlmodlib>, L<perldebug>, L<perlsec>
+
+=item New Diagnostics
+
+"my" variable %s masks earlier declaration in same scope, %s argument is
+not a HASH element or slice, Allocation too large: %lx, Allocation too
+large, Applying %s to %s will act on scalar(%s), Attempt to free
+nonexistent shared string, Attempt to use reference as lvalue in substr,
+Can't redefine active sort subroutine %s, Can't use bareword ("%s") as %s
+ref while "strict refs" in use, Cannot resolve method `%s' overloading `%s'
+in package `%s', Constant subroutine %s redefined, Constant subroutine %s
+undefined, Copy method did not return a reference, Died, Exiting
+pseudo-block via %s, Identifier too long, Illegal character %s (carriage
+return), Illegal switch in PERL5OPT: %s, Integer overflow in hex number,
+Integer overflow in octal number, internal error: glob failed, Invalid
+conversion in %s: "%s", Invalid type in pack: '%s', Invalid type in unpack:
+'%s', Name "%s::%s" used only once: possible typo, Null picture in
+formline, Offset outside string, Out of memory!, Out of memory during
+request for %s, panic: frexp, Possible attempt to put comments in qw()
+list, Possible attempt to separate words with commas, Scalar value @%s{%s}
+better written as $%s{%s}, Stub found while resolving method `%s'
+overloading `%s' in package `%s', Too late for "B<-T>" option, untie
+attempted while %d inner references still exist, Unrecognized character %s,
+Unsupported function fork, Use of "$$<digit>" to mean "${$}<digit>" is
+deprecated, Value of %s can be "0"; test with defined(), Variable "%s" may
+be unavailable, Variable "%s" will not stay shared, Warning: something's
+wrong, Ill-formed logical name |%s| in prime_env_iter, Got an error from
+DosAllocMem, Malformed PERLLIB_PREFIX, PERL_SH_DIR too long, Process
+terminated by SIG%s
+=item BUGS
-=head2 perllol, perlLoL - Manipulating Lists of Lists in Perl
+=item SEE ALSO
+
+=item HISTORY
+
+=head2 perldata - Perl data types
=item DESCRIPTION
+=over
-=item Declaration and Access of Lists of Lists
+=item Variable names
+=item Context
-=item Growing Your Own
+=item Scalar values
+=item Scalar value constructors
-=item Access and Printing
+=item List value constructors
+=item Typeglobs and Filehandles
-=item Slices
+=back
+=head2 perlsyn - Perl syntax
-=item SEE ALSO
+=item DESCRIPTION
+=over
-=item AUTHOR
+=item Declarations
+=item Simple statements
+=item Compound statements
+=item Loop Control
+=item For Loops
-=head2 perlobj - Perl objects
+=item Foreach Loops
-=item DESCRIPTION
+=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 An Object is Simply a Reference
+=item Terms and List Operators (Leftward)
+
+=item The Arrow Operator
+=item Auto-increment and Auto-decrement
-=item A Class is Simply a Package
+=item Exponentiation
+=item Symbolic Unary Operators
-=item A Method is Simply a Subroutine
+=item Binding Operators
+=item Multiplicative Operators
-=item Method Invocation
+=item Additive Operators
+=item Shift Operators
-=item Destructors
+=item Named Unary Operators
+=item Relational Operators
-=item WARNING
+=item Equality Operators
+=item Bitwise And
-=item Summary
+=item Bitwise Or and Exclusive Or
+=item C-style Logical And
-=item Two-Phased Garbage Collection
+=item C-style Logical Or
+=item Range Operator
+=item Conditional Operator
+=item Assignment Operators
-=back
+=item Comma Operator
-=item SEE ALSO
+=item List Operators (Rightward)
+=item Logical Not
+=item Logical And
+=item Logical or and Exclusive Or
+=item C Operators Missing From Perl
-=head2 perltie - how to hide an object class in a simple variable
+unary &, unary *, (TYPE)
-=item SYNOPSIS
+=item Quote and Quote-like Operators
+=item Regexp Quote-Like Operators
-=item DESCRIPTION
+?PATTERN?, m/PATTERN/gimosx, /PATTERN/gimosx, q/STRING/, C<'STRING'>,
+qq/STRING/, "STRING", qx/STRING/, `STRING`, qw/STRING/,
+s/PATTERN/REPLACEMENT/egimosx, tr/SEARCHLIST/REPLACEMENTLIST/cds,
+y/SEARCHLIST/REPLACEMENTLIST/cds
+=item I/O Operators
-=over
+=item Constant Folding
-=item Tying Scalars
+=item Integer Arithmetic
+=item Floating-point Arithmetic
-TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this
+=back
-=item Tying Arrays
+=head2 perlre - Perl regular expressions
+=item DESCRIPTION
-TIEARRAY classname, LIST, FETCH this, index, STORE this, index, value,
-DESTROY this
+i, m, s, x
-=item Tying Hashes
+=over
+=item Regular Expressions
-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
+(?#text), (?:regexp), (?=regexp), (?!regexp), (?imsx)
-=item Tying FileHandles
+=item Backtracking
+=item Version 8 Regular Expressions
+=item WARNING on \1 vs $1
+=item SEE ALSO
=back
-=item SEE ALSO
+=head2 perlrun - how to execute the Perl interpreter
+=item SYNOPSIS
-=item BUGS
+=item DESCRIPTION
+
+=over
+=item #! and quoting on non-Unix systems
-=item AUTHOR
+OS/2, MS-DOS, Win95/NT, Macintosh
+=item Switches
+B<-0>[I<digits>], B<-a>, B<-c>, B<-d>, B<-d:>I<foo>, B<-D>I<number>,
+B<-D>I<list>, 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
-=head2 perlbot - Bag'o Object Tricks (the BOT)
+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
+ I<THERE IS NO GENERAL RULE FOR CONVERTING A LIST INTO A SCALAR!>
-=item OO SCALING TIPS
+=over
+=item Perl Functions by Category
-=item INSTANCE VARIABLES
+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
-=item SCALAR INSTANCE VARIABLES
+-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, 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, 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 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/,
+qx/STRING/, qw/STRING/, quotemeta EXPR, quotemeta, rand EXPR, rand, read
+FILEHANDLE,SCALAR,LENGTH,OFFSET, read FILEHANDLE,SCALAR,LENGTH, readdir
+DIRHANDLE, readlink EXPR, readlink, 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, 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, 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
-=item INSTANCE VARIABLE INHERITANCE
+=head2 perlvar - Perl predefined variables
+=item DESCRIPTION
-=item OBJECT RELATIONSHIPS
+=over
+=item Predefined Names
-=item OVERRIDING SUPERCLASS METHODS
+$ARG, $_, $E<lt>I<digit>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, $OSNAME,
+$^O, $PERLDB, $^P, $BASETIME, $^T, $WARNING, $^W, $EXECUTABLE_NAME, $^X,
+$ARGV, @ARGV, @INC, %INC, $ENV{expr}, $SIG{expr}, $^M
+=back
-=item USING RELATIONSHIP WITH SDBM
+=head2 perlsub - Perl subroutines
+=item SYNOPSIS
-=item THINKING OF CODE REUSE
+=item DESCRIPTION
+=over
-=item CLASS CONTEXT AND THE OBJECT
+=item Private Variables via my()
+=item Temporary Values via local()
-=item INHERITING A CONSTRUCTOR
+=item Passing Symbol Table Entries (typeglobs)
+=item Pass by Reference
-=item DELEGATION
+=item Prototypes
+
+=item Constant Functions
+=item Overriding Builtin Functions
+=item Autoloading
+=back
+=item SEE ALSO
-=head2 perldebug - Perl debugging
+=head2 perlmod - Perl modules (packages and symbol tables)
=item DESCRIPTION
-
=over
-=item Debugging
+=item Packages
+=item Symbol Tables
+
+=item Package Constructors and Destructors
-h, T, s, n, f, c, c line, <CR>, l min+incr, l min-max, l line, l, -, w
-line, l subname, /pattern/, ?pattern?, L, S, t, b line [ condition ], b
-subname [ condition ], d line, D, a line command, A, < command, >
-command, V package [symbols], X [symbols], ! number, ! -number, H
--number, q or ^D, command, p expr
+=item Perl Classes
-=item Customization
+=item Perl Modules
+=back
-=item Other resources
+=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, 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, 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 BUGS
+=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
-=head2 perldiag - various Perl diagnostics
+=item Guidelines for Converting Perl 4 Library Scripts into Modules
-=item DESCRIPTION
+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 which 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 perlform - Perl formats
=item DESCRIPTION
-
=over
=item Format Variables
+=back
+
+=item NOTES
+
+=over
+=item Footers
+=item Accessing Formatting Internals
=back
-=item NOTES
+=item WARNINGS
+=head2 perllocale - Perl locale handling (internationalization and
+localization)
-=over
+=item DESCRIPTION
-=item Footers
+=item PREPARING TO USE LOCALES
+=item USING LOCALES
-=item Accessing Formatting Internals
+=over
+=item The use locale pragma
+=item The setlocale function
+=item The localeconv function
=back
-=item WARNING
+=item LOCALE CATEGORIES
+=over
+=item Category LC_COLLATE: Collation
+=item Category LC_CTYPE: Character Types
+=item Category LC_NUMERIC: Numeric Formatting
-=head2 perlipc - Perl interprocess communication (signals, fifos,
-pipes, safe subprocceses, sockets, and semaphores)
+=item Category LC_MONETARY: Formatting of monetary amounts
-=item DESCRIPTION
+=item LC_TIME
+=item Other categories
-=item Signals
+=back
+=item SECURITY
-=item Named Pipes
+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 <\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
-=item Using open() for IPC
+PERL_BADLANG, LC_ALL, LC_CTYPE, LC_COLLATE, LC_MONETARY, LC_NUMERIC,
+LC_TIME, LANG
+=item NOTES
=over
-=item Safe Pipe Opens
+=item Backward compatibility
+=item I18N:Collate obsolete
-=item Bidirectional Communication
+=item Sort speed and memory use impacts
+=item write() and LC_NUMERIC
+=item Freely available locale definitions
+=item I18n and l10n
-=back
+=item An imperfect standard
-=item Sockets: Client/Server Communication
+=back
+=item BUGS
=over
-=item Internet TCP Clients and Servers
+=item Broken systems
+=back
-=item Unix-Domain TCP Clients and Servers
+=item SEE ALSO
+=item HISTORY
-=item UDP: Message Passing
+=head2 perlref - Perl references and nested data structures
+=item DESCRIPTION
+=over
+=item Symbolic references
+
+=item Not-so-symbolic references
=back
-=item SysV IPC
+=item WARNING
+=item SEE ALSO
-=item WARNING
+=head2 perldsc - Perl Data Structures Cookbook
+=item DESCRIPTION
-=item NOTES
+arrays of arrays, hashes of arrays, arrays of hashes, hashes of hashes,
+more elaborate constructs
+=item REFERENCES
-=item BUGS
+=item COMMON MISTAKES
+=item CAVEAT ON PRECEDENCE
-=item AUTHOR
+=item WHY YOU SHOULD ALWAYS C<use strict>
+=item DEBUGGING
-=item SEE ALSO
+=item CODE EXAMPLES
+=item LISTS OF LISTS
+=over
+=item Declaration of a LIST OF LISTS
+=item Generation of a LIST OF LISTS
-=head2 perlsec - Perl security
+=item Access and Printing of a LIST OF LISTS
-=item DESCRIPTION
+=back
+=item HASHES OF LISTS
+=over
+=item Declaration of a HASH OF LISTS
+=item Generation of a HASH OF LISTS
-=head2 perltrap - Perl traps for the unwary
+=item Access and Printing of a HASH OF LISTS
-=item DESCRIPTION
+=back
+=item LISTS OF HASHES
=over
-=item Awk Traps
+=item Declaration of a LIST OF HASHES
+=item Generation of a LIST OF HASHES
-=item C Traps
+=item Access and Printing of a LIST OF HASHES
+=back
-=item Sed Traps
+=item HASHES OF HASHES
+=over
-=item Shell Traps
+=item Declaration of a HASH OF HASHES
+=item Generation of a HASH OF HASHES
-=item Perl Traps
+=item Access and Printing of a HASH OF HASHES
+
+=back
+=item MORE ELABORATE RECORDS
-=item Perl4 Traps
+=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 perlstyle - Perl style guide
+=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 perlxs - XS language reference manual
+=head2 perltoot - Tom's object-oriented tutorial for perl
=item DESCRIPTION
+=item Creating a Class
=over
-=item Introduction
+=item Object Representation
+=item Class Interface
-=item On The Road
+=item Constructors and Instance Methods
+=item Planning for the Future: Better Constructors
-=item The Anatomy of an XSUB
+=item Destructors
+=item Other Object Methods
-=item The Argument Stack
+=back
+=item Class Data
-=item The RETVAL Variable
+=over
+=item Accessing Class Data
-=item The MODULE Keyword
+=item Debugging Methods
+=item Class Destructors
-=item The PACKAGE Keyword
+=item Documenting the Interface
+=back
-=item The PREFIX Keyword
+=item Aggregation
+=item Inheritance
-=item The OUTPUT: Keyword
+=over
+=item Overridden Methods
-=item The CODE: Keyword
+=item Multiple Inheritance
+=item UNIVERSAL: The Root of All Objects
-=item The INIT: Keyword
+=back
+=item Alternate Object Representations
-=item The NO_INIT Keyword
+=over
+=item Arrays as Objects
-=item Initializing Function Parameters
+=item Closures as Objects
+=back
-=item Default Parameter Values
+=item AUTOLOAD: Proxy Methods
+=over
-=item The PREINIT: Keyword
+=item Autoloaded Data Methods
+=item Inherited Autoloaded Data Methods
-=item The INPUT: Keyword
+=back
+=item Metaclassical Tools
-=item Variable-length Parameter Lists
+=over
+=item Class::Struct
-=item The PPCODE: Keyword
+=item Data Members as Variables
+=item NOTES
-=item Returning Undef And Empty Lists
+=item Object Terminology
+=back
-=item The REQUIRE: Keyword
+=item SEE ALSO
+=item COPYRIGHT
-=item The CLEANUP: Keyword
+=over
+=item Acknowledgments
-=item The BOOT: Keyword
+=back
+=head2 perlobj - Perl objects
-=item The VERSIONCHECK: Keyword
+=item DESCRIPTION
+=over
-=item The PROTOTYPES: Keyword
+=item An Object is Simply a Reference
+=item A Class is Simply a Package
-=item The PROTOTYPE: Keyword
+=item A Method is Simply a Subroutine
+=item Method Invocation
-=item The ALIAS: Keyword
+=item Default UNIVERSAL methods
+isa(CLASS), can(METHOD), VERSION( [NEED] )
-=item The INCLUDE: Keyword
+=item Destructors
+=item WARNING
-=item The CASE: Keyword
+=item Summary
+=item Two-Phased Garbage Collection
-=item The & Unary Operator
+=back
+=item SEE ALSO
-=item Inserting Comments and C Preprocessor Directives
+=head2 perltie - how to hide an object class in a simple variable
+=item SYNOPSIS
-=item Using XS With C++
+=item DESCRIPTION
+=over
-=item Interface Strategy
+=item Tying Scalars
+TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this
-=item Perl Objects And C Structures
+=item Tying Arrays
+TIEARRAY classname, LIST, FETCH this, index, STORE this, index, value,
+DESTROY this
-=item The Typemap
+=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, PRINT this, LIST, PRINTF this, LIST, READ this
+LIST, READLINE this, GETC this, DESTROY this
+=item The C<untie> Gotcha
=back
-=item EXAMPLES
+=item SEE ALSO
+=item BUGS
-=item XS VERSION
+=item AUTHOR
+=head2 perlbot - Bag'o Object Tricks (the BOT)
-=item AUTHOR
+=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 perlxstut, perlXStut - Tutorial for XSUB's
+=head2 perlipc - Perl interprocess communication (signals, fifos, pipes,
+safe subprocesses, sockets, and semaphores)
=item DESCRIPTION
+=item Signals
+
+=item Named Pipes
+
+=item Using open() for IPC
=over
-=item VERSION CAVEAT
+=item Filehandles
+=item Background Processes
-=item DYNAMIC VERSUS STATIC
+=item Complete Dissociation of Child from Parent
+=item Safe Pipe Opens
-=item EXAMPLE 1
+=item Bidirectional Communication with Another Process
+=back
-=item EXAMPLE 2
+=item Sockets: Client/Server Communication
+=over
-=item WHAT HAS GONE ON?
+=item Internet TCP Clients and Servers
+=item Unix-Domain TCP Clients and Servers
-=item EXAMPLE 3
+=back
+=item TCP Clients with IO::Socket
-=item WHAT'S NEW HERE?
+=over
+=item A Simple Client
-=item INPUT AND OUTPUT PARAMETERS
+C<Proto>, C<PeerAddr>, C<PeerPort>
+=item A Webget Client
-=item THE XSUBPP COMPILER
+=item Interactive Client with IO::Socket
+=back
-=item THE TYPEMAP FILE
+=item TCP Servers with IO::Socket
+Proto, LocalPort, Listen, Reuse
-=item WARNING
+=item UDP: Message Passing
+=item SysV IPC
-=item SPECIFYING ARGUMENTS TO XSUBPP
+=item NOTES
+=item BUGS
-=item THE ARGUMENT STACK
+=item AUTHOR
+=item SEE ALSO
-=item EXTENDING YOUR EXTENSION
+=head2 perldebug - Perl debugging
+=item DESCRIPTION
-=item DOCUMENTING YOUR EXTENSION
+=item The Perl Debugger
+=over
-=item INSTALLING YOUR EXTENSION
+=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, 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<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, =
+[alias value], command, m expr, m package
-=item SEE ALSO
+=item Debugger input/output
+Prompt, Multiline commands, Stack backtrace, Listing, Frame listing
-=item Author
+=item Debugging compile-time statements
+=item Debugger Customization
-=item Last Changed
+=item Readline Support
+
+=item Editor Support for Debugging
+=item The Perl Profiler
+=item Debugger support in perl
+=item Debugger Internals
+
+=item Other resources
=back
+=item BUGS
+=head2 perldiag - various Perl diagnostics
+=item DESCRIPTION
-=head2 perlguts - Perl's Internal Functions
+=head2 perlsec - Perl security
=item DESCRIPTION
+=over
-=item Datatypes
+=item Laundering and Detecting Tainted Data
+=item Switches On the "#!" Line
-=over
+=item Cleaning Up Your Path
-=item What is an "IV"?
+=item Security Bugs
+=item Protecting Your Programs
-=item Working with SV's
+=back
+=head2 perltrap - Perl traps for the unwary
-=item What's Really Stored in an SV?
+=item DESCRIPTION
+=over
-=item Working with AV's
+=item Awk Traps
+=item C Traps
-=item Working with HV's
+=item Sed Traps
+=item Shell Traps
-=item References
+=item Perl Traps
+=item Perl4 to Perl5 Traps
-=item Blessed References and Class Objects
+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
-=back
+Parsing, Parsing, Parsing
-=item Creating New Variables
+=item Numerical Traps
+Numerical, Numerical, Numerical
-=item XSUB's and the Argument Stack
+=item General data type traps
+(Arrays), (Arrays), (Hashes), (Globs), (Scalar String), (Constants),
+(Scalars), (Variable Suicide)
-=item Mortality
+=item Context Traps - scalar, list contexts
+(list context), (scalar context), (scalar context), (list, builtin)
-=item Stashes
+=item Precedence Traps
+Precedence, Precedence, Precedence, Precedence, Precedence, Precedence,
+Precedence
-=item Magic
+=item General Regular Expression Traps using s///, etc.
+Regular Expression, Regular Expression, Regular Expression, Regular
+Expression, Regular Expression, Regular Expression, Regular Expression,
+Regular Expression, Regular Expression
-=over
+=item Subroutine, Signal, Sorting Traps
-=item Assigning Magic
+(Signals), (Sort Subroutine), warn() won't let you specify a filehandle
+=item OS Traps
-=item Magic Virtual Tables
+(SysV), (SysV)
+=item Interpolation Traps
-=item Finding Magic
+Interpolation, Interpolation, Interpolation, Interpolation, Interpolation,
+Interpolation, Interpolation, Interpolation, Interpolation
+
+=item DBM Traps
+DBM, DBM
+=item Unclassified Traps
+Unclassified
=back
-=item Double-Typed SV's
+=head2 perlstyle - Perl style guide
+
+=item DESCRIPTION
+=head2 perlpod - plain old documentation
-=item Calling Perl Routines from within C Programs
+=item DESCRIPTION
+=item Embedding Pods in Perl Modules
-=item Memory Allocation
+=item Common Pod Pitfalls
+=item SEE ALSO
-=item API LISTING
+=item AUTHOR
+=head2 perlbook - Perl book information
-AvFILL, av_clear, av_extend, av_fetch, av_len, av_make, av_pop,
-av_push, av_shift, av_store, av_undef, av_unshift, CLASS, Copy, croak,
-CvSTASH, DBsingle, DBsub, dMARK, dORIGMARK, dSP, dXSARGS, ENTER,
-EXTEND, FREETMPS, G_ARRAY, G_DISCARD, G_EVAL, GIMME, G_NOARGS,
-G_SCALAR, gv_stashpv, gv_stashsv, GvSV, he_free, hv_clear, hv_delete,
-hv_exists, hv_fetch, hv_iterinit, hv_iterkey, hv_iternext,
-hv_iternextsv, hv_iterval, hv_magic, HvNAME, hv_store, hv_undef,
-isALNUM, isALPHA, isDIGIT, isLOWER, isSPACE, isUPPER, items, LEAVE,
-MARK, mg_clear, mg_copy, mg_find, mg_free, mg_get, mg_len, mg_magical,
-mg_set, Move, na, New, Newc, Newz, newAV, newHV, newRV, newSV, newSViv,
-newSVnv, newSVpv, newSVrv, newSVsv, newXS, newXSproto, 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_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,
+=item DESCRIPTION
-=item AUTHOR
+=head2 perlembed - how to embed perl in your C program
+=item DESCRIPTION
-=item DATE
+=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
-=head2 perlcall - Perl calling conventions from C
+=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(s,f)>,
+B<PerlIO_putc(c,f)>, B<PerlIO_ungetc(c,f)>, 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()>
-An Error Handler, An Event Driven Program
+=over
-=item THE PERL_CALL FUNCTIONS
+=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)>
-B<perl_call_sv>, B<perl_call_pv>, B<perl_call_method>,
-B<perl_call_argv>
+=back
-=item FLAG VALUES
+=head2 perlxs - XS language reference manual
+=item DESCRIPTION
=over
-=item G_SCALAR
+=item Introduction
+=item On The Road
-=item G_ARRAY
+=item The Anatomy of an XSUB
+=item The Argument Stack
-=item G_DISCARD
+=item The RETVAL Variable
+=item The MODULE Keyword
-=item G_NOARGS
+=item The PACKAGE Keyword
+=item The PREFIX Keyword
-=item G_EVAL
+=item The OUTPUT: Keyword
+=item The CODE: Keyword
-=item G_KEEPERR
+=item The INIT: Keyword
+=item The NO_INIT Keyword
-=item Determining the Context
+=item Initializing Function Parameters
+=item Default Parameter Values
+=item The PREINIT: Keyword
+=item The SCOPE: Keyword
-=back
+=item The INPUT: Keyword
-=item KNOWN PROBLEMS
+=item Variable-length Parameter Lists
+=item The PPCODE: Keyword
-=item EXAMPLES
+=item Returning Undef And Empty Lists
+=item The REQUIRE: Keyword
-=over
+=item The CLEANUP: Keyword
-=item No Parameters, Nothing returned
+=item The BOOT: Keyword
+=item The VERSIONCHECK: Keyword
-=item Passing Parameters
+=item The PROTOTYPES: Keyword
+=item The PROTOTYPE: Keyword
-=item Returning a Scalar
+=item The ALIAS: Keyword
+=item The INCLUDE: Keyword
-=item Returning a list of values
+=item The CASE: Keyword
+=item The & Unary Operator
-=item Returning a list in a scalar context
+=item Inserting Comments and C Preprocessor Directives
+=item Using XS With C++
-=item Returning Data from Perl via the parameter list
+=item Interface Strategy
+=item Perl Objects And C Structures
-=item Using G_EVAL
+=item The Typemap
+=back
-=item Using G_KEEPERR
+=item EXAMPLES
+=item XS VERSION
-=item Using perl_call_sv
+=item AUTHOR
+=head2 perlxstut, perlXStut - Tutorial for XSUBs
-=item Using perl_call_argv
+=item DESCRIPTION
+=over
-=item Using perl_call_method
+=item VERSION CAVEAT
+=item DYNAMIC VERSUS STATIC
-=item Using GIMME
+=item EXAMPLE 1
+=item EXAMPLE 2
-=item Using Perl to dispose of temporaries
+=item WHAT HAS GONE ON?
+=item WRITING GOOD TEST SCRIPTS
-=item Strategies for storing Callback Context Information
+=item EXAMPLE 3
+=item WHAT'S NEW HERE?
-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 INPUT AND OUTPUT PARAMETERS
-=item Alternate Stack Manipulation
+=item THE XSUBPP COMPILER
+=item THE TYPEMAP FILE
+=item WARNING
+=item EXAMPLE 4
-=back
+=item WHAT HAS HAPPENED HERE?
-=item SEE ALSO
+=item SPECIFYING ARGUMENTS TO XSUBPP
+=item THE ARGUMENT STACK
-=item AUTHOR
+=item EXTENDING YOUR EXTENSION
+=item DOCUMENTING YOUR EXTENSION
-=item DATE
+=item INSTALLING YOUR EXTENSION
+=item SEE ALSO
+=item Author
+=item Last Changed
+=back
-=head2 perlembed - how to embed perl in your C program
+=head2 perlguts - Perl's Internal Functions
=item DESCRIPTION
+=item Variables
=over
-=item PREAMBLE
+=item Datatypes
+=item What is an "IV"?
-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 Working with SVs
-=item ROADMAP
+=item What's Really Stored in an SV?
+=item Working with AVs
-=item Compiling your C program
+=item Working with HVs
+=item Hash API Extensions
-=item Adding a Perl interpreter to your C program
+=item References
+=item Blessed References and Class Objects
-=item Calling a Perl subroutine from your C program
+=item Creating New Variables
+=item Reference Counts and Mortality
-=item Evaluating a Perl statement from your C program
+=item Stashes and Globs
+=item Double-Typed SVs
-=item Performing Perl pattern matches and substitutions from your C
-program
+=item Magic Variables
+
+=item Assigning Magic
+=item Magic Virtual Tables
+=item Finding Magic
+=item Understanding the Magic of Tied Hashes and Arrays
=back
-=item MORAL
+=item Subroutines
+=over
-=item AUTHOR
+=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
-=head2 perlpod - plain old documentation
+=item Scratchpads
-=item DESCRIPTION
+=item Scratchpads and recursion
+=back
-=item Embedding Pods in Perl Modules
+=item Compiled code
+=over
-=item SEE ALSO
+=item Code tree
+=item Examining the tree
-=item AUTHOR
+=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
-=head2 perlbook - Perl book information
+=item API LISTING
+
+AvFILL, av_clear, av_extend, av_fetch, av_len, av_make, av_pop, av_push,
+av_shift, av_store, av_undef, av_unshift, CLASS, Copy, croak, CvSTASH,
+DBsingle, DBsub, DBtrace, dMARK, dORIGMARK, dowarn, dSP, dXSARGS, dXSI32,
+dXSI32, ENTER, EXTEND, FREETMPS, G_ARRAY, G_DISCARD, G_EVAL, GIMME,
+GIMME_V, G_NOARGS, G_SCALAR, G_VOID, gv_fetchmeth, gv_fetchmethod,
+gv_fetchmethod_autoload, 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, MARK, mg_clear, mg_copy, mg_find, mg_free,
+mg_get, mg_len, mg_magical, mg_set, Move, na, New, Newc, Newz, newAV,
+newHV, newRV_inc, newRV_noinc, newSV, newSViv, newSVnv, newSVpv, newSVrv,
+newSVsv, newXS, newXSproto, 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, 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_catpvn, sv_catpvf, sv_catsv, sv_cmp, sv_cmp, SvCUR, SvCUR_set, sv_dec,
+sv_dec, SvEND, sv_eq, SvGROW, sv_grow, sv_inc, SvIOK, SvIOK_off, SvIOK_on,
+SvIOK_only, SvIOK_only, SvIOKp, sv_isa, SvIV, sv_isobject, SvIVX, SvLEN,
+sv_len, sv_len, sv_magic, sv_mortalcopy, SvOK, sv_newmortal, sv_no, SvNIOK,
+SvNIOK_off, SvNIOKp, SvNOK, SvNOK_off, SvNOK_on, SvNOK_only, SvNOK_only,
+SvNOKp, SvNV, SvNVX, SvPOK, SvPOK_off, SvPOK_on, SvPOK_only, SvPOK_only,
+SvPOKp, SvPV, SvPVX, SvREFCNT, SvREFCNT_dec, SvREFCNT_inc, SvROK,
+SvROK_off, SvROK_on, SvRV, sv_setiv, sv_setnv, sv_setpv, sv_setpvn,
+sv_setpvf, sv_setref_iv, sv_setref_nv, sv_setref_pv, sv_setref_pvn,
+sv_setsv, SvSTASH, SVt_IV, SVt_PV, SVt_PVAV, SVt_PVCV, SVt_PVHV, SVt_PVMG,
+SVt_NV, SvTRUE, SvTYPE, svtype, SvUPGRADE, sv_upgrade, sv_undef, sv_unref,
+sv_usepvn, sv_yes, THIS, toLOWER, toUPPER, warn, XPUSHi, XPUSHn, XPUSHp,
+XPUSHs, 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 EDITOR
+
+=item DATE
+
+=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
-=head1 PRAGMA DOCUMENTATION
+=item G_VOID
+=item G_SCALAR
+=item G_ARRAY
+=item G_DISCARD
-=head2 diagnostics - Perl compiler pragma to force verbose warning
-diagnostics
+=item G_NOARGS
-=item SYNOPSIS
+=item G_EVAL
+=item G_KEEPERR
-=item DESCRIPTION
+=item Determining the Context
+
+=back
+
+=item KNOWN PROBLEMS
+=item EXAMPLES
=over
-=item The C<diagnostics> Pragma
+=item No Parameters, Nothing returned
+=item Passing Parameters
-=item The I<splain> Program
+=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
-=back
+=item Using G_EVAL
-=item EXAMPLES
+=item Using G_KEEPERR
+=item Using perl_call_sv
-=item INTERNALS
+=item Using perl_call_argv
+=item Using perl_call_method
-=item BUGS
+=item Using GIMME_V
+=item Using Perl to dispose of temporaries
-=item AUTHOR
+=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
-=head2 integer - Perl pragma to compute arithmetic in integer instead
-of double
+=item SEE ALSO
-=item SYNOPSIS
+=item AUTHOR
+=item DATE
+
+=head1 PRAGMA DOCUMENTATION
+
+=head2 autouse - postpone load of modules until a function is used
+
+=item SYNOPSIS
=item DESCRIPTION
+=item WARNING
+=item BUGS
+=item AUTHOR
+=item SEE ALSO
-=head2 less - perl pragma to request less of something from the
-compiler
+=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 lib - manipulate @INC at compile time
+=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 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
-=over
+=item SYNOPSIS
-=item ADDING DIRECTORIES TO @INC
+=item DESCRIPTION
+=head2 lib - manipulate @INC at compile time
-=item DELETING DIRECTORIES FROM @INC
+=item SYNOPSIS
+=item DESCRIPTION
-=item RESTORING ORIGINAL @INC
+=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 ops - Perl pragma to restrict unsafe operations when compiling
+=item SYNOPSIS
+=item DESCRIPTION
+=item SEE ALSO
=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>
+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
+=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<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)
+overload::StrVal(arg), overload::Overloaded(arg), overload::Method(obj,op)
=item IMPLEMENTATION
-
=item AUTHOR
-
=item DIAGNOSTICS
-
=item BUGS
+=head2 sigtrap - Perl pragma to enable simple signal handling
+
+=item SYNOPSIS
+=item DESCRIPTION
+=item OPTIONS
+=over
-=head2 sigtrap - Perl pragma to enable stack backtrace on unexpected
-signals
+=item SIGNAL HANDLERS
-=item SYNOPSIS
+B<stack-trace>, B<die>, B<handler> I<your-handler>
+=item SIGNAL LISTS
-=item DESCRIPTION
+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 subs - Perl pragma to predeclare sub names
+=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 vars - Perl pragma to predeclare global variable names
+=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
-=head1 MODULE DOCUMENTATION
+=item B<AutoLoader> vs. B<SelfLoader>
+=back
+=item CAVEATS
+=item SEE ALSO
-=head2 AnyDBM_File - provide framework for multiple DBMs
+=head2 AutoSplit - split a package for autoloading
=item SYNOPSIS
-
=item DESCRIPTION
+=item CAVEATS
+
+=item DIAGNOSTICS
+
+=head2 Benchmark - benchmark running times of code
+
+=item SYNOPSIS
+
+=item DESCRIPTION
=over
-=item DBM Comparisons
+=item Methods
+new, debug
-[0], [1], [2], [3]
+=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 SEE ALSO
+=item NOTES
+=item INHERITANCE
+=item CAVEATS
+=item AUTHORS
+=item MODIFICATION HISTORY
-=head2 AutoLoader - load functions only on demand
+=head2 Bundle::CPAN - A bundle to play with all the other modules on CPAN
=item SYNOPSIS
+=item CONTENTS
=item DESCRIPTION
+=item AUTHOR
-
-
-
-=head2 AutoSplit - split a package for autoloading
+=head2 CGI - Simple Common Gateway Interface Class
=item SYNOPSIS
+=item ABSTRACT
+
+=item INSTALLATION
=item DESCRIPTION
+=over
+=item CREATING A NEW QUERY OBJECT:
+=item CREATING A NEW QUERY OBJECT FROM AN INPUT FILE
+=item FETCHING A LIST OF KEYWORDS FROM THE QUERY:
-=head2 Benchmark - benchmark running times of code
+=item FETCHING THE NAMES OF ALL THE PARAMETERS PASSED TO YOUR SCRIPT:
-=item SYNOPSIS
+=item FETCHING THE VALUE OR VALUES OF A SINGLE NAMED PARAMETER:
+=item SETTING THE VALUE(S) OF A NAMED PARAMETER:
-=item DESCRIPTION
+=item APPENDING ADDITIONAL VALUES TO A NAMED PARAMETER:
+=item IMPORTING ALL PARAMETERS INTO A NAMESPACE:
-=over
+=item DELETING A PARAMETER COMPLETELY:
-=item Methods
+=item DELETING ALL PARAMETERS:
+=item SAVING THE STATE OF THE FORM TO A FILE:
-new, debug
+=item CREATING A SELF-REFERENCING URL THAT PRESERVES STATE INFORMATION:
-=item Standard Exports
+=item COMPATIBILITY WITH CGI-LIB.PL
+=item CALLING CGI FUNCTIONS THAT TAKE MULTIPLE ARGUMENTS
-timeit(COUNT, CODE), timethis, timethese, timediff, timestr
+=item CREATING THE HTTP HEADER:
-=item Optional Exports
+=item GENERATING A REDIRECTION INSTRUCTION
+=item CREATING THE HTML HEADER:
+B<Parameters:>, 4, 5, 6..
+=item ENDING THE HTML DOCUMENT:
=back
-=item NOTES
+=item CREATING FORMS
+=over
-=item INHERITANCE
+=item CREATING AN ISINDEX TAG
+=item STARTING AND ENDING A FORM
-=item CAVEATS
+B<application/x-www-form-urlencoded>, B<multipart/form-data>
+=item CREATING A TEXT FIELD
-=item AUTHORS
+B<Parameters>
+=item CREATING A BIG TEXT FIELD
-=item MODIFICATION HISTORY
+=item CREATING A PASSWORD FIELD
+=item CREATING A FILE UPLOAD FIELD
+B<Parameters>
+=item CREATING A POPUP MENU
+=item CREATING A SCROLLING LIST
-=head2 Carp, carp - warn of errors (from perspective of caller)
+B<Parameters:>
-=item SYNOPSIS
+=item CREATING A GROUP OF RELATED CHECKBOXES
+B<Parameters:>
-=item DESCRIPTION
+=item CREATING A STANDALONE CHECKBOX
+B<Parameters:>
+=item CREATING A RADIO BUTTON GROUP
+B<Parameters:>
+=item CREATING A SUBMIT BUTTON
-=head2 Cwd, getcwd - get pathname of current working directory
+B<Parameters:>
-=item SYNOPSIS
+=item CREATING A RESET BUTTON
+=item CREATING A DEFAULT BUTTON
-=item DESCRIPTION
+=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
-=head2 DB_File - Perl5 access to Berkeley DB
+=back
-=item SYNOPSIS
+=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 DESCRIPTION
+=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
-DB_HASH, DB_BTREE, DB_RECNO
+=item DEBUGGING
=over
-=item How does DB_File interface to Berkeley DB?
+=item DUMPING OUT ALL THE NAME/VALUE PAIRS
+=back
-=item Differences with Berkeley DB
+=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 RECNO
+=item CREATING HTML ELEMENTS
+=over
-=item In Memory Databases
+=item PROVIDING ARGUMENTS TO HTML SHORTCUTS
+=item Generating new HTML tags
-=item Using the Berkeley DB Interface Directly
+=back
+=item IMPORTING CGI METHOD CALLS INTO YOUR NAME SPACE
-get, put, del, fd, seq, sync
+B<cgi>, B<form>, B<html2>, B<html3>, B<netscape>, B<shortcuts>,
+B<standard>, B<all>
+=item USING NPH SCRIPTS
+In the B<use> statementSimply add ":nph" to the list of symbols to be
+imported into your script:, By calling the B<nph()> method:, By using
+B<-nph> parameters in the B<header()> and B<redirect()> statements:
-=back
+=item AUTHOR INFORMATION
-=item EXAMPLES
+=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), ...and many many more..
-=over
+=item A COMPLETE EXAMPLE OF A SIMPLE FORM-BASED SCRIPT
-=item Using HASH
+=item BUGS
+=item SEE ALSO
-=item Using BTREE
+=head2 CGI::Apache - Make things work with CGI.pm against Perl-Apache API
+=item SYNOPSIS
-=item Using RECNO
+=item DESCRIPTION
+=item NOTE 1
-=item Locking Databases
+=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
-=back
+=item SYNOPSIS
-=item HISTORY
+=item DESCRIPTION
+=item REDIRECTING ERROR MESSAGES
-=item WARNINGS
+=item MAKING PERL ERRORS APPEAR IN THE BROWSER WINDOW
+=item CHANGE LOG
-=item BUGS
+=item AUTHORS
+=item SEE ALSO
-=item AVAILABILITY
+=head2 CGI::Fast - CGI Interface for Fast CGI
+=item SYNOPSIS
-=item SEE ALSO
+=item DESCRIPTION
+=item OTHER PIECES OF THE PUZZLE
-=item AUTHOR
+=item WRITING FASTCGI PERL SCRIPTS
+=item INSTALLING FASTCGI SCRIPTS
+=item USING FASTCGI SCRIPTS AS CGI SCRIPTS
+=item CAVEATS
+=item AUTHOR INFORMATION
-=head2 Devel::SelfStubber - generate stubs for a SelfLoading module
+=item BUGS
-=item SYNOPSIS
+=item SEE ALSO
+
+=head2 CGI::Push - Simple Interface to Server Push
+=item SYNOPSIS
=item DESCRIPTION
+=item USING CGI::Push
+
+-last_page, -type, -delay, -cookie, -target, -expires
+=item INSTALLING CGI::Push SCRIPTS
+=item CAVEATS
+=item AUTHOR INFORMATION
-=head2 DirHandle - supply object methods for directory handles
+=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
+=item CPAN::Shell
-=head2 DynaLoader - Dynamically load C libraries into Perl code
+=item autobundle
-=item SYNOPSIS
+=item recompile
+=item The 4 Classes: Authors, Bundles, Modules, Distributions
-=item DESCRIPTION
+=item ProgrammerE<39>s interface
+expand($type,@things), Programming Examples
-@dl_library_path, @dl_resolve_using, @dl_require_symbols, dl_error(),
-$dl_debug, dl_findfile(), dl_expandspec(), dl_load_file(),
-dl_find_symbol(), dl_undef_symbols(), dl_install_xsub(), boostrap()
+=item Cache Manager
-=item AUTHOR
+=item Bundles
+=item Prerequisites
+=item Debugging
+=item Floppy, Zip, and all that Jazz
+=back
-=head2 English - use nice English (or awk) names for ugly punctuation
-variables
+=item CONFIGURATION
-=item SYNOPSIS
+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>
+=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 Env - perl module that imports environment variables
+=head2 Carp, carp - warn of errors (from perspective of caller)
=item SYNOPSIS
+=item DESCRIPTION
+
+=head2 Class::Struct - declare struct-like datatypes as Perl classes
+
+=item SYNOPSIS
=item DESCRIPTION
+=over
-=item AUTHOR
+=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
-=head2 Exporter - Implements default import method for modules
+Example 1, Example 2
-=item SYNOPSIS
+=item Author and Modification History
+
+=head2 Config - access Perl configuration information
+=item SYNOPSIS
=item DESCRIPTION
+myconfig(), config_sh(), config_vars(@names)
-=over
+=item EXAMPLE
-=item Selecting What To Export
+=item WARNING
+
+=item NOTE
+=head2 Cwd, getcwd - get pathname of current working directory
-=item Specialised Import Lists
+=item SYNOPSIS
+=item DESCRIPTION
-=item Module Version Checking
+=head2 DB_File - Perl5 access to Berkeley DB
+
+=item SYNOPSIS
+=item DESCRIPTION
-=item Managing Unknown Symbols
+B<DB_HASH>, B<DB_BTREE>, B<DB_RECNO>
+=over
-=item Tag Handling Utility Functions
+=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
-=head2 ExtUtils::Install - install files from here to there
+=back
-=item SYNOPSIS
+=item DB_BTREE
+=over
-=item DESCRIPTION
+=item Changing the BTREE sort order
+=item Handling Duplicate Keys
+=item The get_dup() Method
+=item Matching Partial Keys
+=back
-=head2 ExtUtils::Liblist - determine libraries to use and how to use
-them
+=item DB_RECNO
-=item SYNOPSIS
+=over
+=item The 'bval' Option
-=item DESCRIPTION
+=item A Simple Example
+=item Extra Methods
-For static extensions, For dynamic extensions, For dynamic extensions
+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 EXTRALIBS
+=item Locking Databases
+=item Sharing Databases With C Applications
-=item LDLOADLIBS and LD_RUN_PATH
+=item The untie() Gotcha
+=back
-=item BSLOADLIBS
+=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 PORTABILITY
+=item HISTORY
+
+=item BUGS
+=item AVAILABILITY
=item SEE ALSO
+=item AUTHOR
+
+=head2 Devel::SelfStubber - generate stubs for a SelfLoading module
+=item SYNOPSIS
+=item DESCRIPTION
+=head2 DirHandle - supply object methods for directory handles
-=head2 ExtUtils::MM_OS2 - methods to override UN*X behaviour in
-ExtUtils::MakeMaker
+=item SYNOPSIS
=item DESCRIPTION
+=head2 DynaLoader - Dynamically load C libraries into Perl code
+
+=item SYNOPSIS
+=item DESCRIPTION
+@dl_library_path, @dl_resolve_using, @dl_require_symbols, @dl_librefs,
+@dl_modules, dl_error(), $dl_debug, dl_findfile(), dl_expandspec(),
+dl_load_file(), dl_loadflags(), dl_find_symbol(),
+dl_find_symbol_anywhere(), dl_undef_symbols(), dl_install_xsub(),
+bootstrap()
+=item AUTHOR
-=head2 ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker
+=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
-=item METHODS
+=head2 Exporter - Implements default import method for modules
+
+=item SYNOPSIS
+=item DESCRIPTION
=over
-=item Preloaded methods
+=item Selecting What To Export
+
+=item Specialised Import Lists
+=item Module Version Checking
-catdir, catfile, nicetext, libscan, exescan, lsdir, path,
-replace_manpage_separator, file_name_is_absolute, prefixify,
-maybe_command_in_dirs, maybe_command, perl_script
+=item Managing Unknown Symbols
-=item SelfLoaded methods
+=item Tag Handling Utility Functions
+=back
-guess_name, init_main, init_dirscan, init_others, find_perl
+=head2 ExtUtils::Command - utilities to replace common UNIX commands in
+Makefiles etc.
-=item Methods to actually produce chunks of text for the Makefile
+=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
-post_initialize, const_config, constants, const_loadlibs, const_cccmd,
-tool_autosplit, tool_xsubpp, tools_other, dist, macro, depend,
-post_constants, pasthru, c_o, xs_c, xs_o, top_targets, linkext, dlsyms,
-dynamic, dynamic_bs, dynamic_lib, static, static_lib, installpm,
-installpm_x, manifypods, processPL, installbin, subdirs, subdir_x,
-clean, realclean, dist_basics, dist_core, dist_dir, dist_test, dist_ci,
-install, force, perldepend, makefile, staticmake, test,
-test_via_harness, test_via_script, postamble, makeaperl, extliblist,
-dir_target, needs_linking, has_link_code, writedoc
+=item BUGS
+=item SEE ALSO
+=item AUTHOR
-=back
+=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::MM_VMS - methods to override UN*X behaviour in
-ExtUtils::MakeMaker
+=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
-=head2 ExtUtils::MakeMaker - create an extension Makefile
+=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 Hintsfile support
+=item Preloaded methods
+canonpath, catdir, catfile, curdir, rootdir, updir
-=item What's new in version 5 of MakeMaker
+=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 Incompatibilities between MakeMaker 5.00 and 4.23
+=item Methods to actually produce chunks of text for the Makefile
+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, pasthru
+(o), path, perl_script, perldepend (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
-=item Default Makefile Behaviour
+=back
+=item SEE ALSO
-=item make test
+=head2 ExtUtils::MM_VMS - methods to override UN*X behaviour in
+ExtUtils::MakeMaker
+=item SYNOPSIS
-=item make install
+=item DESCRIPTION
+=over
-=item PREFIX attribute
+=item Methods always loaded
+eliminate_macros, fixpath, catdir, catfile, wraplist, curdir (override),
+rootdir (override), updir (override)
-=item AFS users
+=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)
-=item Static Linking of a new Perl Binary
+=back
+=head2 ExtUtils::MM_Win32 - methods to override UN*X behaviour in
+ExtUtils::MakeMaker
-=item Determination of Perl Library and Installation Locations
+=item SYNOPSIS
+=item DESCRIPTION
-=item Useful Default Makefile Macros
+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 Using Attributes and Parameters
+=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, CONFIG, CONFIGURE, DEFINE, DIR, DISTNAME, DL_FUNCS, DL_VARS,
-EXE_FILES, FIRST_MAKEFILE, FULLPERL, H, INC, INSTALLARCHLIB,
-INSTALLBIN, INSTALLDIRS, INSTALLMAN1DIR, INSTALLMAN3DIR,
-INSTALLPRIVLIB, INSTALLSITELIB, INSTALLSITEARCH, INST_ARCHLIB,
-INST_EXE, INST_LIB, INST_MAN1DIR, INST_MAN3DIR, LDFROM, LIBPERL_A,
-LIBS, LINKTYPE, MAKEAPERL, MAKEFILE, MAN1PODS, MAN3PODS, MAP_TARGET,
-MYEXTLIB, NAME, NEEDS_LINKING, NOECHO, NORECURS, OBJECT, PERL,
-PERLMAINCC, PERL_ARCHLIB, PERL_LIB, PERL_SRC, PL_FILES, PM, PMLIBDIRS,
-PREFIX, PREREQ, SKIP, TYPEMAPS, VERSION, VERSION_FROM, XS, XSOPT,
-XSPROTOARG, XS_VERSION
+EXCLUDE_EXT, EXE_FILES, NO_VC, FIRST_MAKEFILE, FULLPERL, H, 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, 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
- make distcheck, make skipcheck, make distclean, make
- manifest, make distdir, make tardist, make dist, make
- uutardist, make shdist, make ci
+=back
+=item SEE ALSO
+=item AUTHORS
-=back
+=head2 ExtUtils::Manifest - utilities to write and check a MANIFEST file
-=item AUTHORS
+=item SYNOPSIS
+=item DESCRIPTION
-=item MODIFICATION HISTORY
+=item MANIFEST.SKIP
+=item EXPORT_OK
-=item TODO
+=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::Manifest - utilities to write and check a MANIFEST
-file
+=head2 ExtUtils::Miniperl, writemain - write the C code for perlmain.c
=item SYNOPSIS
-
=item DESCRIPTION
+=item SEE ALSO
-=item MANIFEST.SKIP
+=head2 ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader
+=item SYNOPSIS
-=item EXPORT_OK
+=item DESCRIPTION
+=head2 ExtUtils::Mksymlists - write linker options files for dynamic
+extension
-=item GLOBAL VARIABLES
+=item SYNOPSIS
+=item DESCRIPTION
-=item DIAGNOSTICS
+NAME, DL_FUNCS, DL_VARS, FILE, FUNCLIST, DLBASE
+=item AUTHOR
-C<Not in MANIFEST:> I<file>, C<No such file:> I<file>, C<MANIFEST:>
-I<$!>, C<Added to MANIFEST:> I<file>
+=item REVISION
-=item SEE ALSO
+=head2 ExtUtils::testlib - add blib/* directories to @INC
+=item SYNOPSIS
-=item AUTHOR
+=item DESCRIPTION
+
+=head2 Fcntl - load the C Fcntl.h defines
+=item SYNOPSIS
+=item DESCRIPTION
+=item NOTE
+=item EXPORTED SYMBOLS
-=head2 ExtUtils::Mkbootstrap - make a bootstrap file for use by
-DynaLoader
+=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 ExtUtils::Mksymlists - write linker options files for dynamic
-extension
+=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)
-NAME, DL_FUNCS, DL_VARS, FILE, FUNCLIST, DLBASE
+=item BUGS
=item AUTHOR
+=item HISTORY
+
+=item SEE ALSO
+
+=head2 File::Find, find - traverse a file tree
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=head2 File::Path - create or remove a series of directories
+
+=item SYNOPSIS
+
+=item DESCRIPTION
+
+=item AUTHORS
=item REVISION
+=head2 File::stat - by-name interface to Perl's built-in stat() functions
+=item SYNOPSIS
+=item DESCRIPTION
+=item NOTE
-=head2 Fcntl - load the C Fcntl.h defines
+=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 NOTE
+=item SEE ALSO
+=head2 FindBin - Locate directory of original perl script
+=item SYNOPSIS
+=item DESCRIPTION
+=item EXPORTABLE VARIABLES
-=head2 File::Basename, Basename - parse file specifications
+=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
+E<lt>noneE<gt>, !, =s, :s, =i, :i, =f, :f
-fileparse_set_fstype, fileparse
+=over
+
+=item Linkage specification
+
+=item Aliases and abbreviations
+
+=item Non-option call-back routine
+
+=item Option starters
+
+=item Return value
+
+=back
+
+=item COMPATIBILITY
=item EXAMPLES
+=item CONFIGURATION OPTIONS
-C<basename>, C<dirname>
+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), debug (default: reset)
+=item OTHER USEFUL VARIABLES
+$Getopt::Long::VERSION, $Getopt::Long::error
+=head2 Getopt::Std, getopt - Process single-character switches with switch
+clustering
-=head2 File::CheckTree, validate - run many filetest checks on a tree
+=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::File - supply object methods for filehandles
+=item SYNOPSIS
+=item DESCRIPTION
+=item CONSTRUCTOR
-=head2 File::Find, find - traverse a file tree
+new ([ ARGS ] ), new_tmpfile
-=item SYNOPSIS
+=item METHODS
+
+open( FILENAME [,MODE [,PERMS]] )
+
+=item SEE ALSO
+
+=item HISTORY
+
+=head2 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
-=head2 File::Path - create or remove a series of directories
+=item NOTE
-=item SYNOPSIS
+=item SEE ALSO
+=item BUGS
-=item DESCRIPTION
+=item HISTORY
+=head2 IO::Pipe, IO::pipe - supply object methods for pipes
-=item AUTHORS
+=item SYNOPSIS
+=item DESCRIPTION
-=item REVISION
+=item CONSTRCUTOR
+new ( [READER, WRITER] )
+=item METHODS
+reader ([ARGS]), writer ([ARGS]), handles ()
+=item SEE ALSO
-=head2 FileCache - keep more files open than the system permits
+=item AUTHOR
+
+=item COPYRIGHT
+
+=head2 IO::Seekable - supply seek based methods for I/O objects
=item SYNOPSIS
+=item DESCRIPTION
+
+=item SEE ALSO
+
+=item HISTORY
+
+=head2 IO::Select - OO interface to the select system call
+
+=item SYNOPSIS
=item DESCRIPTION
+=item CONSTRUCTOR
-=item BUGS
+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
-=head2 FileHandle - supply object methods for filehandles
+=item COPYRIGHT
-=item SYNOPSIS
+=head2 IO::Socket - Object interface to socket communications
+=item SYNOPSIS
=item DESCRIPTION
+=item CONSTRUCTOR
- $fh->print, $fh->printf, $fh->getline, $fh->getlines
+new ( [ARGS] )
-=item SEE ALSO
+=item METHODS
+accept([PKG]), timeout([VAL]), sockopt(OPT [, VAL]), sockdomain, socktype,
+protocol
-=item BUGS
+=item SUB-CLASSES
+=over
+=item IO::Socket::INET
+=item METHODS
+sockaddr (), sockport (), sockhost (), peeraddr (), peerport (), peerhost
+()
-=head2 GDBM_File - Perl5 access to the gdbm library.
+=item IO::Socket::UNIX
+
+=item METHODS
+
+hostpath(), peerpath()
+
+=back
+
+=item SEE ALSO
+
+=item AUTHOR
+
+=item COPYRIGHT
+
+=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
-=item AVAILABILITY
+new (), new_from_fd ( FD, MODE )
+=item METHODS
-=item BUGS
+$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
-=head2 Getopt::Long, GetOptions - extended processing of command line
-options
+=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
-<none>, !, =s, :s, =i, :i, =f, :f
+new ( [ HANDLES ] )
-=over
+=item METHODS
-=item Linkage specification
+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 Aliases and abbreviations
+=item AUTHOR
+=item COPYRIGHT
-=item Non-option call-back routine
+=head2 IO::lib::IO::Socket, IO::Socket - Object interface to socket
+communications
+=item SYNOPSIS
-=item Option starters
+=item DESCRIPTION
+=item CONSTRUCTOR
-=item Return value
+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 COMPATIBILITY
+=item SEE ALSO
+
+=item AUTHOR
+=item COPYRIGHT
-=item EXAMPLES
+=head2 IPC::Open2, open2 - open a process for both reading and writing
+
+=item SYNOPSIS
+=item DESCRIPTION
-=item CONFIGURATION VARIABLES
+=item WARNING
+=item SEE ALSO
-$Getopt::Long::autoabbrev, $Getopt::Long::getopt_compat,
-$Getopt::Long::order, $Getopt::Long::ignorecase,
-$Getopt::Long::VERSION, $Getopt::Long::error, $Getopt::Long::debug
+=head2 IPC::Open3, open3 - open a process for reading, writing, and error
+handling
+=item SYNOPSIS
+=item DESCRIPTION
+=item WARNING
-=head2 Getopt::Std, getopt - Process single-character switches with
-switch clustering
+=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 BUGS
+=item AUTHOR
-=head2 I18N::Collate - compare 8-bit scalar data according to the
-current locale
+=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
+
+=item BUGS
+
+=item AUTHORS
+
+=head2 Math::Trig - trigonometric functions
+
+=item SYNOPSIS
=item DESCRIPTION
+=item TRIGONOMETRIC FUNCTIONS
+
+=over
+
+=item ERRORS DUE TO DIVISION BY ZERO
+=item SIMPLE (REAL) ARGUMENTS, COMPLEX RESULTS
+=back
+=item ANGLE CONVERSIONS
-=head2 IPC::Open2, open2 - open a process for both reading and writing
+=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
-=item SEE ALSO
+=head2 Net::hostent - by-name interface to Perl's built-in gethost*()
+functions
+=item SYNOPSIS
+
+=item DESCRIPTION
+=item EXAMPLES
+=item NOTE
+=item AUTHOR
-=head2 IPC::Open3, open3 - open a process for reading, writing, and
-error handling
+=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 Net::Ping, pingecho - check a host for upness
+=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
-=over
+=item Operator Names and Operator Lists
-=item Parameters
+an operator name (opname), an operator tag name (optag), a negated opname
+or optag, an operator set (opset)
+=item Opcode Functions
-hostname, timeout
+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)
-=back
+=item Predefined Opcode Tags
+
+:base_core, :base_mem, :base_loop, :base_io, :base_orig, :base_math,
+: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)
-=head2 POSIX - Perl interface to IEEE Std 1003.1
+=item Some Safety Issues
-=item SYNOPSIS
+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
-=item NOTE
+=head2 POSIX - Perl interface to IEEE Std 1003.1
+=item SYNOPSIS
-=item CAVEATS
+=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, pat
+_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, 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 Safe - Compile and execute code in restricted compartments
-=head2 Safe - Safe extension module for Perl
+=item SYNOPSIS
=item DESCRIPTION
-
a new namespace, an operator mask
-=over
+=item WARNING
-=item Operator masks
+=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)
-NAMESPACE, MASK, root (NAMESPACE), mask (MASK), trap (OP, ...), untrap
-(OP, ...), share (VARNAME, ...), varglob (VARNAME), reval (STRING), rdo
-(FILENAME)
-
-=item Subroutines in package Safe
-
+=item Some Safety Issues
-ops_to_mask (OP, ...), mask_to_ops (MASK), opcode (OP, ...), opname
-(OP, ...), fullmask, emptymask, MAXO, op_mask
+Memory, CPU, Snooping, Signals, State Changes
=item AUTHOR
-
-
-
=back
-
-
-
=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 Socket, sockaddr_in, sockaddr_un, inet_aton, inet_ntoa - load
-the C socket.h defines and structure manipulators
+=head2 Shell - run shell commands transparently within perl
=item SYNOPSIS
-
=item DESCRIPTION
+=item AUTHOR
-inet_aton HOSTNAME, inet_ntoa IP_ADDRESS, INADDR_ANY, 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 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
+=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, $mask, $format,
-@args, setlogmask $mask_priority, closelog
+openlog $ident, $logopt, $facility, syslog $priority, $format, @args,
+setlogmask $mask_priority, 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
-
-<tab>Attempts word completion. Cannot be changed, ^D, ^U, <del>, <bs>
+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.
+=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>, C<Features>
-
-=item EXPORTS
-
+C<MinLine>, C<findConsole>, Attribs, C<Features>
+=item Additional supported functions
+=item EXPORTS
+=item ENVIRONMENT
=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>
+%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 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
+=item SYNOPSIS
+=item DESCRIPTION
+=item AUTHORS
-=head2 Text::Soundex - Implementation of the Soundex Algorithm as
-Described by Knuth
+=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
-=head2 Text::Tabs -- expand and unexpand tabs
+=item AUTHOR
-=item SYNOPSIS
+=head2 Text::Wrap - line wrapping to form simple paragraphs
+=item SYNOPSIS
=item DESCRIPTION
+=item EXAMPLE
+
+=item BUGS
=item AUTHOR
+=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 Text::Wrap -- wrap text into a paragraph
+=head2 Tie::RefHash - use references as hash keys
=item SYNOPSIS
-
=item DESCRIPTION
+=item EXAMPLE
=item AUTHOR
+=item VERSION
+=item SEE ALSO
-
-
-=head2 Tie::Hash, Tie::StdHash - base class definitions for tied hashes
+=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
-TIEHASH classname, LIST, STORE this, key, value, FETCH this, key,
-FIRSTKEY this, NEXTKEY this, lastkey, EXISTS this, key, DELETE this,
-key, CLEAR this
+=item MORE INFORMATION
-=item CAVEATS
+=head2 Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
+=item SYNOPSIS
-=item MORE INFORMATION
+=item DESCRIPTION
+=item CAVEATS
+=head2 Time::Local - efficiently compute time from local and GMT time
+=item SYNOPSIS
+=item DESCRIPTION
-=head2 Tie::Scalar, Tie::StdScalar - base class definitions for tied
-scalars
+=head2 Time::gmtime - by-name interface to Perl's built-in gmtime()
+function
=item SYNOPSIS
-
=item DESCRIPTION
+=item NOTE
-TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this
+=item AUTHOR
-=item MORE INFORMATION
+=head2 Time::localtime - by-name interface to Perl's built-in localtime()
+function
+=item SYNOPSIS
+=item DESCRIPTION
+=item NOTE
+=item AUTHOR
-=head2 Tie::SubstrHash - Fixed-table-size, fixed-key-length hashing
+=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 ] ), isa ( VAL, TYPE ),
+can ( VAL, METHOD )
-=item CAVEATS
+=head2 User::grent - by-name interface to Perl's built-in getgr*()
+functions
+=item SYNOPSIS
+=item DESCRIPTION
+=item NOTE
+=item AUTHOR
-=head2 Time::Local - efficiently compute tome from local and GMT time
+=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 program's docs, but they don't all
-have man pages yet:
+Here should be listed all the extra programs' documentation, but they
+don't all have manual pages yet:
=item a2p
@@ -3144,10 +4945,8 @@ have man pages yet:
=item wrapsuid
-
=head1 AUTHOR
-Larry Wall E<lt><F<lwall@sems.com>E<gt>, with the help of oodles of
-other folks.
-
+Larry Wall <F<larry@wall.org>>, with the help of oodles
+of other folks.
diff --git a/gnu/usr.bin/perl/pod/perltoot.pod b/gnu/usr.bin/perl/pod/perltoot.pod
new file mode 100644
index 00000000000..3a35c05b903
--- /dev/null
+++ b/gnu/usr.bin/perl/pod/perltoot.pod
@@ -0,0 +1,1789 @@
+=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 COPYRIGHT
+
+I I<really> hate to have to say this, but recent unpleasant
+experiences have mandated its inclusion:
+
+ Copyright 1996 Tom Christiansen. All Rights Reserved.
+
+This work derives in part from the second edition of I<Programming Perl>.
+Although destined for release as a manpage with the standard Perl
+distribution, it is not public domain (nor is any of Perl and its docset:
+publishers beware). It's expected to someday make its way into a revision
+of the Camel Book. While it is copyright by me with all rights reserved,
+permission is granted to freely distribute verbatim copies of this
+document provided that no modifications outside of formatting be made,
+and that this notice remain intact. You are permitted and encouraged to
+use its code and derivatives thereof in your own source code for fun or
+for profit as you see fit. But so help me, if in six months I find some
+book out there with a hacked-up version of this material in it claiming to
+be written by someone else, I'll tell all the world that you're a jerk.
+Furthermore, your lawyer will meet my lawyer (or O'Reilly's) over lunch
+to arrange for you to receive your just deserts. Count on it.
+
+=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/gnu/usr.bin/perl/pod/perltrap.pod b/gnu/usr.bin/perl/pod/perltrap.pod
index dd219c064bc..02abc3b03b3 100644
--- a/gnu/usr.bin/perl/pod/perltrap.pod
+++ b/gnu/usr.bin/perl/pod/perltrap.pod
@@ -6,7 +6,8 @@ perltrap - Perl traps for the unwary
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>.
+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
@@ -20,8 +21,8 @@ The English module, loaded via
use English;
-allows you to refer to special variables (like $RS) as
-though they were in B<awk>; see L<perlvar> for details.
+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 *
@@ -34,7 +35,7 @@ Curly brackets are required on C<if>s and C<while>s.
=item *
-Variables begin with "$" or "@" in Perl.
+Variables begin with "$", "@" or "%" in Perl.
=item *
@@ -47,8 +48,7 @@ You have to decide whether your array has numeric or string indices.
=item *
-Associative array values do not spring into existence upon mere
-reference.
+Hash values do not spring into existence upon mere reference.
=item *
@@ -58,8 +58,8 @@ comparisons.
=item *
Reading an input line does not split it for you. You get to split it
-yourself to an array. And split() operator has different
-arguments.
+to an array yourself. And the split() operator has different
+arguments than B<awk>'s.
=item *
@@ -69,13 +69,13 @@ executed.) See L<perlvar>.
=item *
-$<I<digit>> does not refer to fields--it refers to substrings matched by
-the last match pattern.
+$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
+you set C<$,> and C<$\>. You can set $OFS and $ORS if you're using
the English module.
=item *
@@ -101,9 +101,9 @@ basically incompatible with C.)
=item *
The concatenation operator is ".", not the null string. (Using the
-null string would render C</pat/ /pat/> unparsable, since the third slash
-would be interpreted as a division operator--the tokener is in fact
-slightly context sensitive for operators like "/", "?", and ">".
+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 *
@@ -158,7 +158,7 @@ You must use C<elsif> rather than C<else if>.
=item *
-The C<break> and C<continue> keywords from C become in
+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.
@@ -168,11 +168,11 @@ There's no switch statement. (But it's easy to build one on the fly.)
=item *
-Variables begin with "$" or "@" in Perl.
+Variables begin with "$", "@" or "%" in Perl.
=item *
-printf() does not implement the "*" format for interpolating
+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.
@@ -183,7 +183,7 @@ Comments begin with "#", not "/*".
=item *
You can't take the address of anything, although a similar operator
-in Perl 5 is the backslash, which creates a reference.
+in Perl is the backslash, which creates a reference.
=item *
@@ -231,7 +231,7 @@ Sharp shell programmers should take note of the following:
=item *
-The backtick operator does variable interpretation without regard to
+The backtick operator does variable interpolation without regard to
the presence of single quotes in the command.
=item *
@@ -241,7 +241,7 @@ 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 only in certain constructs
+command line. Perl does substitution in only certain constructs
such as double quotes, backticks, angle brackets, and search patterns.
=item *
@@ -274,36 +274,36 @@ context than they do in a scalar one. See L<perldata> for details.
=item *
-Avoid barewords if you can, especially all lower-case ones.
-You can't tell just by looking at it whether a bareword is
-a function or a string. By using quotes on strings and
-parens on function calls, you won't ever get them confused.
+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 built-ins
-are unary operators (like chop() and chdir())
+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 B<only> be list operators, never
+(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.
+you might expect to do not.
-=item *
+=item *
-The <FH> construct is not the name of the filehandle, it is a readline
-operation on that handle. The data read is only assigned to $_ if the
+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 ($_ = <FH>) { }..
+ while (defined($_ = <FH>)) { }..
<FH>; # data discarded!
-=item *
+=item *
Remember not to use "C<=>" when you need "C<=~>";
these two constructs are quite different:
@@ -313,14 +313,14 @@ these two constructs are quite different:
=item *
-The C<do {}> construct isn't a real loop that you can use
+The C<do {}> construct isn't a real loop that you can use
loop control on.
=item *
-Use my() for local variables whenever you can get away with
-it (but see L<perlform> for where you can't).
-Using local() actually gives a local value to a global
+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.
@@ -332,65 +332,629 @@ external name is still an alias for the original.
=back
-=head2 Perl4 Traps
+=head2 Perl4 to Perl5 Traps
-Penitent Perl 4 Programmers should take note of the following
-incompatible changes that occurred between release 4 and release 5:
+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 *
+=item Discontinuance, Deprecation, and BugFix traps
-C<@> now always interpolates an array in double-quotish strings. Some programs
-may now need to use backslash to protect any C<@> that shouldn't interpolate.
+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 *
+=item Parsing Traps
-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.
-For example:
+Traps that appear to stem from the new parser.
- sub SeeYa { die "Hasta la vista, baby!" }
- $SIG{'QUIT'} = SeeYa;
+=item Numerical Traps
-In Perl 4, that set the signal handler; in Perl 5, it actually calls the
-function! You may use the B<-w> switch to find such places.
+Traps having to do with numerical or mathematical operators.
-=item *
+=item General data type traps
-Symbols starting with C<_> are no longer forced into package C<main>, except
-for $_ itself (and @_, etc.).
+Traps involving perl standard data types.
-=item *
+=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
-Double-colon is now a valid package separator in an identifier. Thus these
-behave differently in perl4 vs. perl5:
+Anything that has been discontinued, deprecated, or fixed as
+a bug from perl4.
- print "$a::$b::$c\n";
+=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
-=item *
+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)
-C<s'$lhs'$rhs'> now does no interpolation on either side. It used to
-interpolate C<$lhs> but not C<$rhs>.
+ $x = 10 ;
+ print "x=${'x}\n" ;
-=item *
+ # perl4 prints: x=10
+ # perl5 prints: Can't find string terminator "'" anywhere before EOF
-The second and third arguments of splice() are now evaluated in scalar
-context (as the book says) rather than list context.
+You can avoid this problem, and remain compatible with perl4, if you
+always explicitly include the package name:
-=item *
+ $x = 10 ;
+ print "x=${main'x}\n" ;
-These are now semantic errors because of precedence:
+Also see precedence traps, for parsing C<$:>.
- shift @list + 20;
- $n = keys %map + 20;
+=item * BugFix
-Because if that were to work, then this couldn't:
+The second and third arguments of C<splice()> are now evaluated in scalar
+context (as the Camel says) rather than list context.
- sleep $dormancy + 20;
+ sub sub1{return(0,2) } # return a 2-elem array
+ sub sub2{ return(1,2,3)} # return a 3-elem array
+ @a1 = ("a","b","c","d","e");
+ @a2 = splice(@a1,&sub1,&sub2);
+ print join(' ',@a2),"\n";
-=item *
+ # 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
+
+=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:
+
+ # Another example
+
+ *fred = *barney; # fred is aliased to barney
+ @barney = (1, 2, 4);
+ # @fred;
+ print "@fred"; # should print "1, 2, 4"
+
+ # perl4 prints: 1 2 4
+ # perl5 prints: In string, @fred now must be written as \@fred
+
+=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.
+
+=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
@@ -400,7 +964,7 @@ operator. So you now must parenthesize them in expressions like
Otherwise
- /foo/ ? $a += 2 : $a -= 2;
+ /foo/ ? $a += 2 : $a -= 2
would be erroneously parsed as
@@ -412,111 +976,512 @@ On the other hand,
now works as a C programmer would expect.
-=item *
+=item * Precedence
-C<open FOO || die> is now incorrect. You need parens around the filehandle.
-While temporarily supported, using such a construct will
-generate a non-fatal (but non-suppressible) warning.
+ open FOO || die;
-=item *
+is now incorrect. You need parentheses around the filehandle.
+Otherwise, perl5 leaves the statement as its default precedence:
-The elements of argument lists for formats are now evaluated in list
-context. This means you can interpolate list values now.
+ open(FOO || die);
-=item *
+ # perl4 opens or dies
+ # perl5 errors: Precedence problem: open FOO should be open(FOO)
-You can't do a C<goto> into a block that is optimized away. Darn.
+=item * Precedence
-=item *
+perl4 gives the special variable, C<$:> precedence, where perl5
+treats C<$::> as main C<package>
-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 = "x"; print "$::a";
-=item *
+ # perl 4 prints: -:a
+ # perl 5 prints: x
-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.
+=item * Precedence
-=item *
+concatenation precedence over filetest operator?
+
+ -e $foo .= "q"
+
+ # perl4 prints: no output
+ # perl5 prints: Can't modify -e in concatenation
+
+=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.
+regular expression. (Once the scope of a block is left for the sub, the
+state of the searched string is lost)
-=item *
+ $_ = "ababab";
+ while(m/ab/g){
+ &doit("blah");
+ }
+ sub doit{local($_) = shift; print "Got $_ "}
-C<reverse> is no longer allowed as the name of a sort subroutine.
+ # perl4 prints: blah blah blah
+ # perl5 prints: infinite loop blah...
-=item *
+=item * Regular Expression
-B<taintperl> is no longer a separate executable. There is now a B<-T>
-switch to turn on tainting when it isn't turned on automatically.
+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
-=item *
+ sub build_match {
+ my($left,$right) = @_;
+ return sub { $_[0] =~ /$left stuff $right/o; };
+ }
-Double-quoted strings may no longer end with an unescaped C<$> or C<@>.
+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.
-=item *
+This is probably a bug, and may change in future versions of Perl.
-The archaic C<while/if> BLOCK BLOCK syntax is no longer supported.
+=item * Regular Expression
+If no parentheses are used in a match, Perl4 sets C<$+> to
+the whole match, just like C<$&>. Perl5 does not.
-=item *
+ "abcdef" =~ /b.*e/;
+ print "\$+ = $+\n";
-Negative array subscripts now count from the end of the array.
+ # perl4 prints: bcde
+ # perl5 prints:
-=item *
+=item * Regular Expression
-The comma operator in a scalar context is now guaranteed to give a
-scalar context to its arguments.
+substitution now returns the null string if it fails
-=item *
+ $string = "test";
+ $value = ($string =~ s/foo//);
+ print $value, "\n";
-The C<**> operator now binds more tightly than unary minus.
-It was documented to work this way before, but didn't.
+ # perl4 prints: 0
+ # perl5 prints:
-=item *
+Also see L<Numerical Traps> for another example of this new feature.
-Setting C<$#array> lower now discards array elements.
+=item * Regular Expression
-=item *
+C<s`lhs`rhs`> (using backticks) is now a normal substitution, with no
+backtick expansion
-delete() is not guaranteed to return the old value for tie()d arrays,
-since this capability may be onerous for some modules to implement.
+ $string = "";
+ $string =~ s`^`hostname`;
+ print $string, "\n";
-=item *
+ # 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
+
+
+=item * Regular Expression
+
+Under perl4 and upto version 5.003, a failed C<m//g> match used to
+reset the internal iterator, so that subsequent C<m//g> match attempts
+began from the beginning of the string. In perl version 5.004 and later,
+failed C<m//g> matches do not reset the iterator position (which can be
+found using the C<pos()> function--see L<perlfunc/pos>).
+
+ $test = "foop";
+ for (1..3) {
+ print $1 while ($test =~ /(o)/g);
+ # pos $test = 0; # to get old behavior
+ }
+
+ # perl4 prints: oooooo
+ # perl5.004 prints: oo
+
+You may always reset the iterator yourself as shown in the commented line
+to get the old behavior.
+
+=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 tries to dereference $x. C<$$> by itself still
+point, but now apparently tries to dereference C<$x>. C<$$> by itself still
works fine, however.
-=item *
+ print "this is $$x\n";
-The meaning of 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. To retain Perl 4 semantics you need to assign your list
-explicitly to a temporary array and then iterate over that. For
-example, you might need to change
+ # 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
- foreach $var (grep /x/, @list) { ... }
+ eval "\$$hashname{'$key'} = q|$value|";
to
- foreach $var (my @tmp = grep /x/, @list) { ... }
+ eval "\$\$hashname{'$key'} = q|$value|";
-Otherwise changing C<$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<$_>.)
+causes the following result:
-=item *
+ # perl4 prints: Nope
+ # perl5 prints: Yup
-Some error messages will be different.
+or, changing to
-=item *
+ eval "\$$hashname\{'$key'\} = q|$value|";
+
+causes the following result:
-Some bugs may have been inadvertently removed.
+ # 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/gnu/usr.bin/perl/pod/perlvar.pod b/gnu/usr.bin/perl/pod/perlvar.pod
index 3d1c195007b..75f4e6d5c2b 100644
--- a/gnu/usr.bin/perl/pod/perlvar.pod
+++ b/gnu/usr.bin/perl/pod/perlvar.pod
@@ -7,7 +7,7 @@ perlvar - Perl predefined variables
=head2 Predefined Names
The following names have special meaning to Perl. Most of the
-punctuational names have reasonable mnemonics, or analogues in one of
+punctuation names have reasonable mnemonics, or analogues in one of
the shells. Nevertheless, if you wish to use the long variable names,
you just need to say
@@ -18,9 +18,9 @@ long names in the current package. Some of them 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 be set by calling an object method on
-the FileHandle object. (Summary lines below for this contain the word
-HANDLE.) First you must say
+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;
@@ -42,6 +42,12 @@ 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
@@ -51,8 +57,8 @@ a reference, you'll raise a run-time exception.
The default input and pattern-searching space. The following pairs are
equivalent:
- while (<>) {...} # only equivalent in while!
- while ($_ = <>) {...}
+ while (<>) {...} # equivalent in only while!
+ while (defined($_ = <>)) {...}
/^Subject:/
$_ =~ /^Subject:/
@@ -63,7 +69,7 @@ equivalent:
chop
chop($_)
-Here are the places where Perl will assume $_ even if you
+Here are the places where Perl will assume $_ even if you
don't use it:
=over 3
@@ -83,16 +89,16 @@ Various list functions like print() and unlink().
The pattern matching operations C<m//>, C<s///>, and C<tr///> when used
without an C<=~> operator.
-=item *
+=item *
The default iterator variable in a C<foreach> loop if no other
variable is supplied.
-=item *
+=item *
The implicit iterator variable in the grep() and map() functions.
-=item *
+=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>
@@ -102,7 +108,11 @@ test. Note that outside of a C<while> test, this will not happen.
(Mnemonic: underline is understood in certain operations.)
-=item $<I<digit>>
+=back
+
+=over 8
+
+=item $E<lt>I<digit>E<gt>
Contains the subpattern from the corresponding set of parentheses in
the last pattern matched, not counting patterns matched in nested
@@ -123,7 +133,7 @@ BLOCK). (Mnemonic: like & in some editors.) This variable is read-only.
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: ` often precedes a quoted
+enclosed by the current BLOCK). (Mnemonic: C<`> often precedes a quoted
string.) This variable is read-only.
=item $POSTMATCH
@@ -132,7 +142,7 @@ string.) This variable is read-only.
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: ' often follows a quoted
+enclosed by the current BLOCK). (Mnemonic: C<'> often follows a quoted
string.) Example:
$_ = 'abcdefghi';
@@ -158,15 +168,15 @@ This variable is read-only.
=item $*
-Set to 1 to do multiline matching within a string, 0 to tell Perl
+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
-only influences the interpretation of "C<^>" and "C<$>". A literal newline can
+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 Perl 5.
+Use of "C<$*>" is deprecated in modern perls.
=item input_line_number HANDLE EXPR
@@ -176,8 +186,9 @@ Use of "C<$*>" is deprecated in Perl 5.
=item $.
-The current input line number of the last filehandle that was read. An
-explicit close on the filehandle resets the line number. Since
+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
@@ -193,33 +204,39 @@ number.)
=item $/
The input record separator, newline by default. Works like B<awk>'s RS
-variable, including treating blank lines as delimiters if set to the
-null string. You may set it to a multicharacter string to match a
-multi-character delimiter. Note that setting it to C<"\n\n"> means
-something slightly different than setting it to C<"">, if the file
-contains consecutive blank lines. Setting it to C<""> will treat two or
-more consecutive blank lines as a single blank 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.)
+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 :-)
+
=item autoflush HANDLE EXPR
=item $OUTPUT_AUTOFLUSH
=item $|
-If set to nonzero, forces a flush after every write or print on the
-currently selected output channel. Default is 0. 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.
+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
@@ -231,8 +248,8 @@ effect on input buffering.
=item $,
The output field separator for the print operator. Ordinarily the
-print operator simply prints out the comma separated fields you
-specify. In order to get behavior more like B<awk>, set this variable
+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.)
@@ -246,12 +263,12 @@ print statement.)
=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. In
-order to get behavior more like B<awk>, set this variable as you would
+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 /, but it's what you get "back" from
+print. Also, it's just like C<$/>, but it's what you get "back" from
Perl.)
=item $LIST_SEPARATOR
@@ -268,7 +285,7 @@ is a space. (Mnemonic: obvious, I think.)
=item $;
-The subscript separator for multi-dimensional array emulation. If you
+The subscript separator for multidimensional array emulation. If you
refer to a hash element as
$foo{$a,$b,$c}
@@ -291,7 +308,7 @@ keys contain binary data there might not be any safe value for "C<$;>".
semi-semicolon. Yeah, I know, it's pretty lame, but "C<$,>" is already
taken for something more important.)
-Consider using "real" multi-dimensional arrays in Perl 5.
+Consider using "real" multidimensional arrays.
=item $OFMT
@@ -300,11 +317,12 @@ Consider using "real" multi-dimensional arrays in Perl 5.
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. Also, the initial value is %.20g rather than %.6g, so you
-need to set "C<$#>" explicitly to get B<awk>'s value. (Mnemonic: # is the
-number sign.)
+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 in Perl 5.
+Use of "C<$#>" is deprecated.
=item format_page_number HANDLE EXPR
@@ -360,7 +378,7 @@ appended. (Mnemonic: points to top of page.)
=item $:
The current set of characters after which a string may be broken to
-fill continuation fields (starting with ^) in a format. Default is
+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.)
@@ -370,7 +388,7 @@ poetry is a part of a line.)
=item $^L
-What formats output to perform a formfeed. Default is \f.
+What formats output to perform a form feed. Default is \f.
=item $ACCUMULATOR
@@ -389,10 +407,22 @@ L<perlfunc/formline()>.
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, so the exit value of the subprocess is actually
-(C<$? E<gt>E<gt> 8>). Thus on many systems, C<$? & 255> gives which signal,
-if any, the process died from, and whether there was a core dump.
-(Mnemonic: similar to B<sh> and B<ksh>.)
+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<$? & 255> gives which signal, if any, the process died from, and
+whether there was a core dump. (Mnemonic: similar to B<sh> and
+B<ksh>.)
+
+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.
=item $OS_ERROR
@@ -405,7 +435,7 @@ 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<$!>" in order to set I<errno> if, for instance, you want "C<$!>" to return the
+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?)
@@ -413,14 +443,14 @@ operator. (Mnemonic: What just went bang?)
=item $^E
-More specific information about the last system error than that
-provided by C<$!>, if available. (If not, it's just C<$!> again.)
-At the moment, this differs from C<$!> only under VMS, where it
-provides the VMS status value from the last system error. The
+More specific information about the last system error than that provided by
+C<$!>, if available. (If not, it's just C<$!> again.)
+At the moment, this differs from C<$!> under only VMS and OS/2, where it
+provides the VMS status value from the last system error, and OS/2 error
+code of the last call to OS/2 API either via CRT, or directly from perl. The
caveats mentioned in the description of C<$!> apply here, too.
(Mnemonic: Extra error explanation.)
-
=item $EVAL_ERROR
=item $@
@@ -431,7 +461,8 @@ 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 $SIG{__WARN__} below.
+however, set up a routine to process warnings by setting C<$SIG{__WARN__}>
+as described below.
=item $PROCESS_ID
@@ -462,8 +493,9 @@ 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 only be swapped on machines supporting setreuid().
+(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
@@ -475,8 +507,14 @@ 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. (Mnemonic: parentheses are used to I<GROUP>
-things. The real gid is the group you I<LEFT>, if you're running setgid.)
+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
@@ -488,21 +526,29 @@ 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. (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.)
+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" >.
-Note: "C<$E<lt>>", "C<$E<gt>>", "C<$(>" and "C<$)>" can only be set on machines
-that support the corresponding I<set[re][ug]id()> routine. "C<$(>" and "C<$)>"
-can only be swapped on machines supporting setregid(). Because Perl doesn't
-currently use initgroups(), you can't set your group vector to multiple groups.
+(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. Assigning to "C<$0>" modifies the argument area that the ps(1)
+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>.)
@@ -523,24 +569,15 @@ discouraged.
=item $]
-The string printed out when you say C<perl -v>.
-(This is currently I<BROKEN>).
-It can be used to
-determine at the beginning of a script whether the perl interpreter
-executing the script is in the right range of versions. If used in a
-numeric context, returns the version + patchlevel / 1000. Example:
-
- # see if getc is available
- ($version,$patchlevel) =
- $] =~ /(\d+\.\d+).*\nPatch level: (\d+)/;
- print STDERR "(No filename completion available.)\n"
- if $version * 1000 + $patchlevel < 2016;
-
-or, used numerically,
+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;
-(Mnemonic: Is this version of perl in the right bracket?)
+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
@@ -561,6 +598,11 @@ 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
@@ -568,7 +610,22 @@ C<$^F> at the time of the open, not the time of the exec.
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
@@ -579,16 +636,52 @@ is identical to C<$Config{'osname'}>.
=item $^P
-The internal flag that the debugger clears so that it doesn't debug
-itself. You could conceivably disable debugging yourself by clearing
-it.
+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 $^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, othewise 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>
+epoch (beginning of 1970). The values returned by the B<-M>, B<-A>,
and B<-C> filetests are
based on this value.
@@ -596,8 +689,8 @@ based on this value.
=item $^W
-The current value of the warning switch, either TRUE or FALSE. (Mnemonic: related to the
-B<-w> switch.)
+The current value of the warning switch, either TRUE or FALSE.
+(Mnemonic: related to the B<-w> switch.)
=item $EXECUTABLE_NAME
@@ -607,13 +700,13 @@ 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 <>.
+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, since C<$ARGV[0]> is the first argument, I<NOT> the command name. See
+one, because C<$ARGV[0]> is the first argument, I<NOT> the command name. See
"C<$0>" for the command name.
=item @INC
@@ -621,14 +714,19 @@ one, since C<$ARGV[0]> is the first argument, I<NOT> the command name. See
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 "/usr/local/lib/perl",
+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 in order
-to also get the machine-dependent library properly loaded:
+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
@@ -637,44 +735,60 @@ 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{expr}
+=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{expr}
+=item %SIG $SIG{expr}
The hash %SIG is used to set signal handlers for various
signals. Example:
sub handler { # 1st argument is signal name
- local($sig) = @_;
+ my($sig) = @_;
print "Caught a SIG$sig--shutting down\n";
close(LOG);
exit(0);
}
- $SIG{'INT'} = 'handler';
- $SIG{'QUIT'} = 'handler';
+ $SIG{'INT'} = \&handler;
+ $SIG{'QUIT'} = \&handler;
...
$SIG{'INT'} = 'DEFAULT'; # restore default action
$SIG{'QUIT'} = 'IGNORE'; # ignore SIGQUIT
-The %SIG array only contains values for the signals actually set within
+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"; # just fine, assumes main::Plumber
+ $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
+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<perlsubs>.
+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 $SIG{__WARN__} is called when a warning message is
+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
@@ -683,13 +797,36 @@ in a variable, or turn warnings into fatal errors, like this:
local $SIG{__WARN__} = sub { die $_[0] };
eval $proggie;
-The routine indicated by $SIG{__DIE__} is called when a fatal exception
+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 __DIE__ handler is explicitly disabled during the call, so that you
-can die from a __DIE__ handler. Similarly for __WARN__.
+The C<__DIE__> handler is explicitly disabled during the call, so that you
+can die from a C<__DIE__> handler. Similarly for C<__WARN__>.
-=back
+Note that the C<$SIG{__DIE__}> hook is called even inside eval()ed
+blocks/strings. See L<perlfunc/die>, 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
diff --git a/gnu/usr.bin/perl/pod/perlxs.pod b/gnu/usr.bin/perl/pod/perlxs.pod
index 191a78fe891..6629af2dd55 100644
--- a/gnu/usr.bin/perl/pod/perlxs.pod
+++ b/gnu/usr.bin/perl/pod/perlxs.pod
@@ -167,7 +167,21 @@ 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 may not be needed.
+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
@@ -275,7 +289,7 @@ its parameters. The Perl usage is given first.
$status = rpcb_gettime( "localhost", $timep );
-The XSUB follows.
+The XSUB follows.
bool_t
rpcb_gettime(host,timep)
@@ -305,7 +319,7 @@ above, this keyword does not affect the way the compiler handles RETVAL.
=head2 The NO_INIT Keyword
The NO_INIT keyword is used to indicate that a function
-parameter is being used as only an output value. The B<xsubpp>
+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
@@ -314,7 +328,7 @@ 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 as only an output variable and does
+This function uses the timep variable only as an output variable and does
not care about its initial contents.
bool_t
@@ -416,6 +430,23 @@ A correct, but error-prone example.
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
@@ -543,7 +574,7 @@ the following statement.
=head2 Returning Undef And Empty Lists
-Occasionally the programmer will want to simply return
+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
@@ -553,13 +584,13 @@ of $timep will either be undef or it will be a valid time.
$timep = rpcb_gettime( "localhost" );
-The following XSUB uses the C<void> return type to disable the generation of
-the RETVAL variable and uses a CODE: block to indicate to the compiler
+The following XSUB uses the C<SV *> return type as a mneumonic 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.
- void
+ SV *
rpcb_gettime(host)
char * host
PREINIT:
@@ -573,7 +604,7 @@ the default return value.
The next example demonstrates how one would place an explicit undef in the
return value, should the need arise.
- void
+ SV *
rpcb_gettime(host)
char * host
PREINIT:
@@ -614,7 +645,7 @@ other C<XSRETURN> macros.
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 only compile with B<xsubpp> version
+contains the following statement will compile with only B<xsubpp> version
1.922 or greater:
REQUIRE: 1.922
@@ -647,7 +678,7 @@ terminate the code block.
=head2 The VERSIONCHECK: Keyword
The VERSIONCHECK: keyword corresponds to B<xsubpp>'s C<-versioncheck> and
-C<-noversioncheck> options. This keyword overrides the commandline
+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.
@@ -663,7 +694,7 @@ To disable version checking:
=head2 The PROTOTYPES: Keyword
The PROTOTYPES: keyword corresponds to B<xsubpp>'s C<-prototypes> and
-C<-noprototypes> options. This keyword overrides the commandline options.
+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.
@@ -700,7 +731,7 @@ prototypes.
=head2 The ALIAS: Keyword
-The ALIAS: keyword allows an XSUB to have two more more unique Perl names
+The ALIAS: keyword allows an XSUB to have two 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
@@ -760,8 +791,8 @@ variable (see L<"The ALIAS: Keyword">), or maybe via the C<items> variable
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()> it's parameters are the usual C<(char *host, time_t *timep)>,
-but when the function is called as C<x_gettime()> is parameters are
+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
@@ -827,17 +858,17 @@ C<&> through, so the function call looks like C<rpcb_gettime(host, &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.
+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
@@ -936,7 +967,7 @@ example.
# 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) )
@@ -1071,6 +1102,37 @@ 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.
@@ -1085,7 +1147,7 @@ File C<RPC.xs>: Interface to some ONC+ RPC bind library functions.
MODULE = RPC PACKAGE = RPC
- void
+ SV *
rpcb_gettime(host="localhost")
char *host
PREINIT:
@@ -1146,5 +1208,5 @@ This document covers features supported by C<xsubpp> 1.935.
=head1 AUTHOR
-Dean Roehrich F<E<lt>roehrich@cray.comE<gt>>
-Mar 12, 1996
+Dean Roehrich <F<roehrich@cray.com>>
+Jul 8, 1996
diff --git a/gnu/usr.bin/perl/pod/perlxstut.pod b/gnu/usr.bin/perl/pod/perlxstut.pod
index 7fea4210a96..9ebfe82a97d 100644
--- a/gnu/usr.bin/perl/pod/perlxstut.pod
+++ b/gnu/usr.bin/perl/pod/perlxstut.pod
@@ -1,6 +1,6 @@
=head1 NAME
-perlXStut - Tutorial for XSUB's
+perlXStut - Tutorial for XSUBs
=head1 DESCRIPTION
@@ -10,8 +10,8 @@ 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 in order to slowly ease
-the reader into building extensions.
+completely explained until later in the tutorial to ease the
+reader slowly into building extensions.
=head2 VERSION CAVEAT
@@ -25,13 +25,21 @@ features were added to Perl 5.
=item *
-In versions of 5.002 prior to version beta 3, then the line in the .xs file
+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 5.002 prior to version 5.002b1h, the test.pl file was not
+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:
@@ -47,7 +55,7 @@ to use the following line:
=item *
-This document assumes that the executable named "perl" is Perl version 5.
+This document assumes that the executable named "perl" is Perl version 5.
Some systems may have installed Perl version 5 as "perl5".
=back
@@ -55,7 +63,7 @@ Some systems may have installed Perl version 5 as "perl5".
=head2 DYNAMIC VERSUS STATIC
It is commonly thought that if a system does not have the capability to
-dynamically load a library, you cannot build XSUB's. This is incorrect.
+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.
@@ -80,7 +88,7 @@ test" is sufficient.
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 "h2xs -A -n Mytest". This creates a directory named Mytest, possibly under
+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.
@@ -137,7 +145,7 @@ And the Mytest.xs file should look something like this:
#ifdef __cplusplus
}
#endif
-
+
PROTOTYPES: DISABLE
MODULE = Mytest PACKAGE = Mytest
@@ -150,7 +158,7 @@ Let's edit the .xs file by adding this to the end of the file:
printf("Hello, world!\n");
Now we'll run "perl Makefile.PL". This will create a real Makefile,
-which make needs. It's output looks something like:
+which make needs. Its output looks something like:
% perl Makefile.PL
Checking if your kit is complete...
@@ -177,11 +185,11 @@ example only, we'll create a special test script. Create a file called hello
that looks like this:
#! /opt/perl5/bin/perl
-
- use lib './blib';
-
+
+ use ExtUtils::testlib;
+
use Mytest;
-
+
Mytest::hello();
Now we run the script and we should see the following output:
@@ -193,7 +201,7 @@ Now we run the script and we should see the following output:
=head2 EXAMPLE 2
Now let's add to our extension a subroutine that will take a single argument
-and return 0 if the argument is even, 1 if the argument is odd.
+and return 1 if the argument is even, 0 if the argument is odd.
Add the following to the end of Mytest.xs:
@@ -214,20 +222,18 @@ 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 re-run make to rebuild our new shared library.
+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.
-In order to test that our extension works, we now need to look at the
+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.
-
-Remove the line that starts with "use lib", change the print statement in
-the BEGIN block to print "1..4", and add the following code to the end of
-the file:
+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";
@@ -255,7 +261,8 @@ 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 <extension>.pm and <extension>.xs contain the meat of the extension.
+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.
@@ -265,7 +272,7 @@ 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 -I arguments so that it could find the various
+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
@@ -367,9 +374,9 @@ 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, in this case the
-math library, libm. We'll talk later about how to write XSUBs that can call
-every routine in a library.
+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.
@@ -439,14 +446,14 @@ 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, in order to better accomodate calling
+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.
+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 XSUB's that will interact with
-pre-defined C libraries. To begin with, we will build a small library of
+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
@@ -468,7 +475,7 @@ Also create a file mylib.c that looks like this:
#include <stdlib.h>
#include "./mylib.h"
-
+
double
foo(a, b, c)
int a;
@@ -483,12 +490,13 @@ And finally create a file Makefile.PL that looks like this:
use ExtUtils::MakeMaker;
$Verbose = 1;
WriteMakefile(
- 'NAME' => 'Mytest2::mylib',
- 'clean' => {'FILES' => 'libmylib.a'},
+ NAME => 'Mytest2::mylib',
+ SKIP => [qw(all static static_lib dynamic dynamic_lib)],
+ clean => {'FILES' => 'libmylib$(LIB_EXT)'},
);
- sub MY::postamble {
+ sub MY::top_targets {
'
all :: static
@@ -504,7 +512,7 @@ And finally create a file Makefile.PL that looks like this:
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
+ % 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.
@@ -521,12 +529,13 @@ and a new replacement subroutine too:
sub MY::postamble {
'
$(MYEXTLIB): mylib/Makefile
- cd mylib && $(MAKE)
+ cd mylib && $(MAKE) $(PASTHRU)
';
}
(Note: Most makes will require that there be a tab character that indents
-the line "cd mylib && $(MAKE)".)
+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
@@ -537,8 +546,9 @@ the following three lines:
mylib/mylib.h
To keep our namespace nice and unpolluted, edit the .pm file and change
-the line setting @EXPORT to @EXPORT_OK. And finally, in the .xs file,
-edit the #include line to read:
+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"
@@ -569,17 +579,19 @@ and add the following lines to the end of the script:
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 to not check
+(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.
-=head 2 WHAT HAS HAPPENED HERE?
+=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
@@ -597,20 +609,25 @@ C<constant> routine.
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 only going to be used by the C routines themselves, and not by the user,
+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 only the addition of the MYEXTLIB variable
+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
-simply specified that the library to be created here was a static
+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.
@@ -670,7 +687,7 @@ 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 tell xsubpp
+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.
@@ -681,14 +698,14 @@ 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 only loaded when called depends on where in the .pm file the subroutine
+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 man page format,
+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.
@@ -701,7 +718,7 @@ 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
+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.
@@ -712,11 +729,11 @@ and L<perlpod>.
=head2 Author
-Jeff Okamoto <okamoto@corp.hp.com>
+Jeff Okamoto <F<okamoto@corp.hp.com>>
Reviewed and assisted by Dean Roehrich, Ilya Zakharevich, Andreas Koenig,
and Tim Bunce.
=head2 Last Changed
-1996/2/9
+1996/7/10
diff --git a/gnu/usr.bin/perl/pod/pod2html.PL b/gnu/usr.bin/perl/pod/pod2html.PL
index 646190bddbc..de36cd7fc93 100644
--- a/gnu/usr.bin/perl/pod/pod2html.PL
+++ b/gnu/usr.bin/perl/pod/pod2html.PL
@@ -12,10 +12,9 @@ use File::Basename qw(&basename &dirname);
# 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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
@@ -25,523 +24,155 @@ print "Extracting $file (with variable substitutions)\n";
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
+$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!';
-eval 'exec perl -S $0 ${1+"$@"}'
- if $running_under_some_shell;
-#
-# pod2html - convert pod format to html
-# Version 1.15
-# usage: pod2html [podfiles]
-# Will read the cwd and parse all files with .pod extension
-# if no arguments are given on the command line.
-#
-# Many helps, suggestions, and fixes from the perl5 porters, and all over.
-# Bill Middleton - wjm@metronet.com
-#
-# Please send patches/fixes/features to me
-#
-#
-#
-*RS = */;
-*ERRNO = *!;
-
-################################################################################
-# Invoke with various levels of debugging possible
-################################################################################
-while ($ARGV[0] =~ /^-d(.*)/) {
- shift;
- $Debug{ lc($1 || shift) }++;
-}
-
-# ck for podnames on command line
-while ($ARGV[0]) {
- push(@Pods,shift);
-}
-
-################################################################################
-# CONFIGURE
-#
-# The beginning of the url for the anchors to the other sections.
-# Edit $type to suit. It's configured for relative url's now.
-# Other possibilities are:
-# $type = '<A HREF="file://localhost/usr/local/htmldir/'; # file url
-# $type = '<A HREF="http://www.bozo.com/perl/manual/html/' # server
-#
-################################################################################
-
-$type = '<A HREF="';
-$dir = "."; # location of pods
-
-# look in these pods for things not found within the current pod
-# be careful tho, namespace collisions cause stupid links
-
-@inclusions = qw[
- perlfunc perlvar perlrun perlop
-];
-################################################################################
-# END CONFIGURE
-################################################################################
-
-$A = {}; # The beginning of all things
-
-unless (@Pods) {
- opendir(DIR,$dir) or die "Can't opendir $dir: $ERRNO";
- @Pods = grep(/\.pod$/,readdir(DIR));
- closedir(DIR) or die "Can't closedir $dir: $ERRNO";
-}
-@Pods or die "aak, expected pods";
-
-# loop twice through the pods, first to learn the links, then to produce html
-for $count (0,1) {
- print STTDER "Scanning pods...\n" unless $count;
- foreach $podfh ( @Pods ) {
- ($pod = $podfh) =~ s/\.pod$//;
- Debug("files", "opening 2 $podfh" );
- print "Creating $pod.html from $podfh\n" if $count;
- $RS = "\n="; # grok pods by item (Nonstandard but effecient)
- open($podfh,"<".$podfh) || die "can't open $podfh: $ERRNO";
- @all = <$podfh>;
- close($podfh);
- $RS = "\n";
-
- $all[0] =~ s/^=//;
- for (@all) { s/=$// }
- $Podnames{$pod} = 1;
- $in_list = 0;
- $html = $pod.".html";
- if ($count) { # give us a html and rcs header
- open(HTML,">$html") || die "can't create $html: $ERRNO";
- print HTML '<!-- $Id$ -->',"\n",'<HTML><HEAD>',"\n";
- print HTML "<CENTER>" unless $NO_NS;
- print HTML "<TITLE>$pod</TITLE>\n</HEAD>\n<BODY>";
- print HTML "</CENTER>" unless $NO_NS;
- }
- for ($i = 0; $i <= $#all; $i++) { # decide what to do with each chunk
- $all[$i] =~ /^(\w+)\s*(.*)\n?([^\0]*)$/ ;
- ($cmd, $title, $rest) = ($1,$2,$3);
- if ($cmd eq "item") {
- if ($count ) { # producing html
- do_list("over",$all[$i],\$in_list,\$depth) unless $depth;
- do_item($title,$rest,$in_list);
- }
- else {
- # scan item
- scan_thing("item",$title,$pod);
- }
- }
- elsif ($cmd =~ /^head([12])/) {
- $num = $1;
- if ($count) { # producing html
- do_hdr($num,$title,$rest,$depth);
- }
- else {
- # header scan
- scan_thing($cmd,$title,$pod); # skip head1
- }
- }
- elsif ($cmd =~ /^over/) {
- $count and $depth and do_list("over",$all[$i+1],\$in_list,\$depth);
- }
- elsif ($cmd =~ /^back/) {
- if ($count) { # producing html
- ($depth) or next; # just skip it
- do_list("back",$all[$i+1],\$in_list,\$depth);
- do_rest("$title.$rest");
- }
- }
- elsif ($cmd =~ /^cut/) {
- next;
- }
- elsif ($cmd =~ /^for/) { # experimental pragma html
- if ($count) { # producing html
- if ($title =~ s/^html//) {
- $in_html =1;
- do_rest("$title.$rest");
- }
- }
- }
- elsif ($cmd =~ /^begin/) { # experimental pragma html
- if ($count) { # producing html
- if ($title =~ s/^html//) {
- print HTML $title,"\n",$rest;
- }
- elsif ($title =~ /^end/) {
- next;
- }
- }
- }
- elsif ($Debug{"misc"}) {
- warn("unrecognized header: $cmd");
- }
- }
- # close open lists without '=back' stmts
- if ($count) { # producing html
- while ($depth) {
- do_list("back",$all[$i+1],\$in_list,\$depth);
- }
- print HTML "\n</BODY>\n</HTML>\n";
- }
- }
-}
-
-sub do_list{ # setup a list type, depending on some grok logic
- my($which,$next_one,$list_type,$depth) = @_;
- my($key);
- if ($which eq "over") {
- unless ($next_one =~ /^item\s+(.*)/) {
- warn "Bad list, $1\n" if $Debug{"misc"};
- }
- $key = $1;
-
- if ($key =~ /^1\.?/) {
- $$list_type = "OL";
- } elsif ($key =~ /\*\s*$/) {
- $$list_type = "UL";
- } elsif ($key =~ /\*?\s*\w/) {
- $$list_type = "DL";
- } else {
- warn "unknown list type for item $key" if $Debug{"misc"};
- }
-
- print HTML qq{\n};
- print HTML $$list_type eq 'DL' ? qq{<DL COMPACT>} : qq{<$$list_type>};
- $$depth++;
- }
- elsif ($which eq "back") {
- print HTML qq{\n</$$list_type>\n};
- $$depth--;
- }
-}
-
-sub do_hdr{ # headers
- my($num,$title,$rest,$depth) = @_;
- print HTML qq{<p><hr>\n} if $num == 1;
- process_thing(\$title,"NAME");
- print HTML qq{\n<H$num> };
- print HTML $title;
- print HTML qq{</H$num>\n};
- do_rest($rest);
-}
-
-sub do_item{ # list items
- my($title,$rest,$list_type) = @_;
- my $bullet_only = $title eq '*' and $list_type eq 'UL';
- process_thing(\$title,"NAME");
- if ($list_type eq "DL") {
- print HTML qq{\n<DT><STRONG>\n};
- print HTML $title;
- print HTML qq{\n</STRONG>\n};
- print HTML qq{<DD>\n};
- }
- else {
- print HTML qq{\n<LI>};
- unless ($bullet_only or $list_type eq "OL") {
- print HTML $title,"\n";
- }
- }
- do_rest($rest);
-}
-
-sub do_rest{ # the rest of the chunk handled here
- my($rest) = @_;
- my(@lines,$p,$q,$line,,@paras,$inpre);
- @paras = split(/\n\n\n*/,$rest);
- for ($p = 0; $p <= $#paras; $p++) {
- $paras[$p] =~ s/^\n//mg;
- @lines = split(/\n/,$paras[$p]);
- if ($in_html) { # handle =for html paragraphs
- print HTML $paras[0];
- $in_html = 0;
- next;
- }
- elsif ($lines[0] =~ /^\s+\w*\t.*/) { # listing or unordered list
- print HTML qq{<UL>};
- foreach $line (@lines) {
- ($line =~ /^\s+(\w*)\t(.*)/) && (($key,$rem) = ($1,$2));
- print HTML defined($Podnames{$key})
- ? "<LI>$type$key.html\">$key<\/A>\t$rem</LI>\n"
- : "<LI>$line</LI>\n";
- }
- print HTML qq{</UL>\n};
- }
- elsif ($lines[0] =~ /^\s/) { # preformatted code
- if ($paras[$p] =~/>>|<</) {
- print HTML qq{\n<PRE>\n};
- $inpre=1;
- }
- else { # Still cant beat XMP. Yes, I know
- print HTML qq{\n<XMP>\n}; # it's been obsoleted... suggestions?
- $inpre = 0;
- }
- while (defined($paras[$p])) {
- @lines = split(/\n/,$paras[$p]);
- foreach $q (@lines) { # mind your p's and q's here :-)
- if ($paras[$p] =~ />>|<</) {
- if ($inpre) {
- process_thing(\$q,"HTML");
- }
- else {
- print HTML qq{\n</XMP>\n};
- print HTML qq{<PRE>\n};
- $inpre=1;
- process_thing(\$q,"HTML");
- }
- }
- 1 while $q =~ s/\t+/' 'x (length($&) * 8 - length($`) % 8)/e;
- print HTML $q,"\n";
- }
- last if $paras[$p+1] !~ /^\s/;
- $p++;
- }
- print HTML ($inpre==1) ? (qq{\n</PRE>\n}) : (qq{\n</XMP>\n});
- }
- else { # other text
- @lines = split(/\n/,$paras[$p]);
- foreach $line (@lines) {
- process_thing(\$line,"HTML");
- print HTML qq{$line\n};
- }
- }
- print HTML qq{<p>};
- }
-}
-
-sub process_thing{ # process a chunk, order important
- my($thing,$htype) = @_;
- pre_escapes($thing);
- find_refs($thing,$htype);
- post_escapes($thing);
-}
-
-sub scan_thing{ # scan a chunk for later references
- my($cmd,$title,$pod) = @_;
- $_ = $title;
- s/\n$//;
- s/E<(.*?)>/&$1;/g;
- # remove any formatting information for the headers
- s/[SFCBI]<(.*?)>/$1/g;
- # the "don't format me" thing
- s/Z<>//g;
- if ($cmd eq "item") {
- /^\*/ and return; # skip bullets
- /^\d+\./ and return; # skip numbers
- s/(-[a-z]).*/$1/i;
- trim($_);
- return if defined $A->{$pod}->{"Items"}->{$_};
- $A->{$pod}->{"Items"}->{$_} = gensym($pod, $_);
- $A->{$pod}->{"Items"}->{(split(' ',$_))[0]}=$A->{$pod}->{"Items"}->{$_};
- Debug("items", "item $_");
- if (!/^-\w$/ && /([%\$\@\w]+)/ && $1 ne $_
- && !defined($A->{$pod}->{"Items"}->{$_}) && ($_ ne $1))
- {
- $A->{$pod}->{"Items"}->{$1} = $A->{$pod}->{"Items"}->{$_};
- Debug("items", "item $1 REF TO $_");
- }
- if ( m{^(tr|y|s|m|q[qwx])/.*[^/]} ) {
- my $pf = $1 . '//';
- $pf .= "/" if $1 eq "tr" || $1 eq "y" || $1 eq "s";
- if ($pf ne $_) {
- $A->{$pod}->{"Items"}->{$pf} = $A->{$pod}->{"Items"}->{$_};
- Debug("items", "item $pf REF TO $_");
- }
- }
- }
- elsif ($cmd =~ /^head[12]/) {
- return if defined($A->{$pod}->{"Headers"}->{$_});
- $A->{$pod}->{"Headers"}->{$_} = gensym($pod, $_);
- Debug("headers", "header $_");
- }
- else {
- warn "unrecognized header: $cmd" if $Debug;
- }
-}
-
-
-sub picrefs {
- my($char, $bigkey, $lilkey,$htype) = @_;
- my($key,$ref,$podname);
- for $podname ($pod,@inclusions) {
- for $ref ( "Items", "Headers" ) {
- if (defined $A->{$podname}->{$ref}->{$bigkey}) {
- $value = $A->{$podname}->{$ref}->{$key = $bigkey};
- Debug("subs", "bigkey is $bigkey, value is $value\n");
- }
- elsif (defined $A->{$podname}->{$ref}->{$lilkey}) {
- $value = $A->{$podname}->{$ref}->{$key = $lilkey};
- return "" if $lilkey eq '';
- Debug("subs", "lilkey is $lilkey, value is $value\n");
- }
- }
- if (length($key)) {
- ($pod2,$num) = split(/_/,$value,2);
- if ($htype eq "NAME") {
- return "\n<A NAME=\"".$value."\">\n$bigkey</A>\n"
- }
- else {
- return "\n$type$pod2.html\#".$value."\">$bigkey<\/A>\n";
- }
- }
- }
- if ($char =~ /[IF]/) {
- return "<EM>$bigkey</EM>";
- } elsif ($char =~ /C/) {
- return "<CODE>$bigkey</CODE>";
- } else {
- return "<STRONG>$bigkey</STRONG>";
- }
-}
-
-sub find_refs {
- my($thing,$htype) = @_;
- my($orig) = $$thing;
- # LREF: a manpage(3f) we don't know about
- for ($$thing) {
- #s:L<([a-zA-Z][^\s\/]+)(\([^\)]+\))>:the I<$1>$2 manpage:g;
- s@(\S+?://\S*[^.,;!?\s])@noremap(qq{<A HREF="$1">$1</A>})@ge;
- s,([a-z0-9_.-]+\@([a-z0-9_-]+\.)+([a-z0-9_-]+)),noremap(qq{<A HREF="MAILTO:$1">$1</A>}),gie;
- s/L<([^>]*)>/lrefs($1,$htype)/ge;
- s/([CIBF])<(\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge;
- s/(S)<([^\/]\W*?(-?\w*).*?)>/picrefs($1, $2, $3, $htype)/ge;
- s/((\w+)\(\))/picrefs("I", $1, $2,$htype)/ge;
- s/([\$\@%](?!&[gl]t)([\w:]+|\W\b))/varrefs($1,$htype)/ge;
- }
- if ($$thing eq $orig && $htype eq "NAME") {
- $$thing = picrefs("I", $$thing, "", $htype);
- }
-
-}
-
-sub lrefs {
- my($page, $item) = split(m#/#, $_[0], 2);
- my($htype) = $_[1];
- my($podname);
- my($section) = $page =~ /\((.*)\)/;
- my $selfref;
- if ($page =~ /^[A-Z]/ && $item) {
- $selfref++;
- $item = "$page/$item";
- $page = $pod;
- } elsif (!$item && $page =~ /[^a-z\-]/ && $page !~ /^\$.$/) {
- $selfref++;
- $item = $page;
- $page = $pod;
- }
- $item =~ s/\(\)$//;
- if (!$item) {
- if (!defined $section && defined $Podnames{$page}) {
- return "\n$type$page.html\">\nthe <EM>$page</EM> manpage<\/A>\n";
- } else {
- (warn "Bizarre entry $page/$item") if $Debug;
- return "the <EM>$_[0]</EM> manpage\n";
- }
- }
-
- if ($item =~ s/"(.*)"/$1/ || ($item =~ /[^\w\/\-]/ && $item !~ /^\$.$/)) {
- $text = "<EM>$item</EM>";
- $ref = "Headers";
- } else {
- $text = "<EM>$item</EM>";
- $ref = "Items";
- }
- for $podname ($pod, @inclusions) {
- undef $value;
- if ($ref eq "Items") {
- if (defined($value = $A->{$podname}->{$ref}->{$item})) {
- ($pod2,$num) = split(/_/,$value,2);
- return (($pod eq $pod2) && ($htype eq "NAME"))
- ? "\n<A NAME=\"".$value."\">\n$text</A>\n"
- : "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
- }
- }
- elsif ($ref eq "Headers") {
- if (defined($value = $A->{$podname}->{$ref}->{$item})) {
- ($pod2,$num) = split(/_/,$value,2);
- return (($pod eq $pod2) && ($htype eq "NAME"))
- ? "\n<A NAME=\"".$value."\">\n$text</A>\n"
- : "\n$type$pod2.html\#".$value."\">$text<\/A>\n";
- }
- }
- }
- warn "No $ref reference for $item (@_)" if $Debug;
- return $text;
-}
-
-sub varrefs {
- my ($var,$htype) = @_;
- for $podname ($pod,@inclusions) {
- if ($value = $A->{$podname}->{"Items"}->{$var}) {
- ($pod2,$num) = split(/_/,$value,2);
- Debug("vars", "way cool -- var ref on $var");
- return (($pod eq $pod2) && ($htype eq "NAME")) # INHERIT $_, $pod
- ? "\n<A NAME=\"".$value."\">\n$var</A>\n"
- : "\n$type$pod2.html\#".$value."\">$var<\/A>\n";
- }
- }
- Debug( "vars", "bummer, $var not a var");
- return "<STRONG>$var</STRONG>";
-}
-
-sub gensym {
- my ($podname, $key) = @_;
- $key =~ s/\s.*//;
- ($key = lc($key)) =~ tr/a-z/_/cs;
- my $name = "${podname}_${key}_0";
- $name =~ s/__/_/g;
- while ($sawsym{$name}++) {
- $name =~ s/_?(\d+)$/'_' . ($1 + 1)/e;
- }
- return $name;
-}
-
-sub pre_escapes { # twiddle these, and stay up late :-)
- my($thing) = @_;
- for ($$thing) {
- s/"(.*?)"/``$1''/gs;
- s/&/noremap("&amp;")/ge;
- s/<</noremap("&lt;&lt;")/eg;
- s/([^ESIBLCF])</$1\&lt\;/g;
- s/E<([^\/][^<>]*)>/\&$1\;/g; # embedded special
- }
-}
-sub noremap { # adding translator for hibit chars soon
- my $hide = $_[0];
- $hide =~ tr/\000-\177/\200-\377/;
- $hide;
-}
-
-
-sub post_escapes {
- my($thing) = @_;
- for ($$thing) {
- s/([^GM])>>/$1\&gt\;\&gt\;/g;
- s/([^D][^"MGA])>/$1\&gt\;/g;
- tr/\200-\377/\000-\177/;
- }
-}
-
-sub Debug {
- my $level = shift;
- print STDERR @_,"\n" if $Debug{$level};
-}
-
-sub dumptable {
- my $t = shift;
- print STDERR "TABLE DUMP $t\n";
- foreach $k (sort keys %$t) {
- printf STDERR "%-20s <%s>\n", $t->{$k}, $k;
- }
-}
-sub trim {
- for (@_) {
- s/^\s+//;
- s/\s\n?$//;
- }
-}
+=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: $!";
diff --git a/gnu/usr.bin/perl/pod/pod2latex.PL b/gnu/usr.bin/perl/pod/pod2latex.PL
index 34b1faadba8..3d0b55b32f9 100644
--- a/gnu/usr.bin/perl/pod/pod2latex.PL
+++ b/gnu/usr.bin/perl/pod/pod2latex.PL
@@ -12,10 +12,9 @@ use File::Basename qw(&basename &dirname);
# 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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
@@ -25,9 +24,9 @@ print "Extracting $file (with variable substitutions)\n";
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
- eval 'exec perl -S \$0 "\$@"'
- if 0;
+$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.
@@ -124,11 +123,21 @@ 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;
@@ -146,6 +155,22 @@ while (<POD>) {
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*//;
@@ -500,9 +525,8 @@ sub noremap {
}
sub init_noremap {
- if ( /[\200-\377]/ ) {
- warn "hit bit char in input stream";
- }
+ # escape high bit characters in input stream
+ s/([\200-\377])/"E<".ord($1).">"/ge;
}
sub clear_noremap {
@@ -513,11 +537,14 @@ sub clear_noremap {
sub expand_HTML_escapes {
local($s) = $_[0];
- $s =~ s { E<([A-Za-z]+)> }
+ $s =~ s { E<((\d+)|([A-Za-z]+))> }
{
do {
- exists $HTML_Escapes{$1}
- ? do { $HTML_Escapes{$1} }
+ defined($2)
+ ? do { chr($2) }
+ :
+ exists $HTML_Escapes{$3}
+ ? do { $HTML_Escapes{$3} }
: do {
warn "Unknown escape: $& in $_";
"E<$1>";
diff --git a/gnu/usr.bin/perl/pod/pod2man.PL b/gnu/usr.bin/perl/pod/pod2man.PL
index d8f7cbb716c..46f47a8870c 100644
--- a/gnu/usr.bin/perl/pod/pod2man.PL
+++ b/gnu/usr.bin/perl/pod/pod2man.PL
@@ -8,14 +8,14 @@ use File::Basename qw(&basename &dirname);
# 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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
@@ -25,14 +25,16 @@ print "Extracting $file (with variable substitutions)\n";
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
+$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!';
-eval 'exec perl -S $0 "$@"'
- if 0;
=head1 NAME
@@ -47,6 +49,7 @@ B<pod2man>
[ B<--date=>I<string> ]
[ B<--fixed=>I<font> ]
[ B<--official> ]
+[ B<--lax> ]
I<inputfile>
=head1 DESCRIPTION
@@ -106,6 +109,10 @@ 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
@@ -198,7 +205,7 @@ Who wrote it (or AUTHORS if multiple).
=item HISTORY
Programs derived from other sources sometimes have this, or
-you might keep a modification long here.
+you might keep a modification log here.
=back
@@ -225,12 +232,6 @@ as bold, italic, or code.
(F) The input file wasn't available for the given reason.
-=item high bit char in input stream
-
-(W) You can't use high-bit characters in the input stream,
-because the translator uses them for its own nefarious purposes.
-Use an HTML entity in angle brackets instead.
-
=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
@@ -254,7 +255,7 @@ 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<E<lt>E<gt>> directive. Besides amp, lt, gt, and quot, recognized
+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,
@@ -279,7 +280,7 @@ C<=head1>, C<=head2>, C<=item>, C<=over>, C<=back>, or C<=cut>.
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 one some versions of man(7).
+numbering and even/odd paging, at least on some versions of man(7).
Settting the F register will get you some additional experimental
indexing:
@@ -292,8 +293,7 @@ directives.
=head1 RESTRICTIONS
-You shouldn't use 8-bit characters in the input stream, as these
-will be used by the translator.
+None at this time.
=head1 BUGS
@@ -310,8 +310,17 @@ Tom Christiansen such that Larry probably doesn't recognize it anymore.
$/ = "";
$cutting = 1;
-
-($version,$patch) = `\PATH=.:..:\$PATH; perl -v` =~ /version (\d\.\d{3}(?: +)(?:\S+)?)(?:.*patchlevel (\d\S*))?/s;
+@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') {
+ ($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;
@@ -329,6 +338,7 @@ $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 @_;
@@ -341,6 +351,7 @@ Options are:
--date=string (default "$DEF_DATE")
--fixed=font (default "$DEF_FIXED")
--official (default NOT)
+ --lax (default NOT)
EOF
}
@@ -351,6 +362,7 @@ $uok = GetOptions( qw(
date=s
fixed=s
official
+ lax
help));
$DEF_DATE = makedate((stat($ARGV[0]))[9] || time());
@@ -359,9 +371,11 @@ 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$/ ? 3 : $DEF_SECTION);
+$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;
@@ -375,7 +389,6 @@ else {
die "roff font should be 1 or 2 chars, not `$CFont_embed'";
}
-$section = $opt_section || $DEF_SECTION;
$date = $opt_date || $DEF_DATE;
for (qw{NAME DESCRIPTION}) {
@@ -387,8 +400,27 @@ $wanna_see{SYNOPSIS}++ if $section =~ /^3/;
$name = @ARGV ? $ARGV[0] : "<STDIN>";
$Filename = $name;
-$name = uc($name) if $section =~ /^1/;
-$name =~ s/\.[^.]*$//;
+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 ^arch/version/.
+ $name =~ s-^[^/]+/\d+\.\d+/--;
+}
+
+# Translate Getopt/Long to Getopt::Long, etc.
+$name =~ s(/)(::)g;
if ($name ne 'something') {
FCHECK: {
@@ -400,14 +432,23 @@ if ($name ne 'something') {
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;
+ }
}
- %namedesc = split /\s+-\s+/;
last FCHECK;
}
next if /^=cut\b/; # DB_File and Net::Ping have =cut before NAME
- die "$0: Invalid man page - 1st pod line is not NAME in $ARGV[0]\n";
+ 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";
+ die "$0: Invalid man page - no documentation in $ARGV[0]\n" unless $lax;
}
close F;
}
@@ -460,16 +501,36 @@ print <<"END";
.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
@@ -495,13 +556,14 @@ END
print <<"END";
.TH $name $section "$RP" "$date" "$center"
-.IX Title "$name $section"
.UC
END
+push(@Indices, qq{.IX Title "$name $section"});
+
while (($name, $desc) = each %namedesc) {
for ($name, $desc) { s/^\s+//; s/\s+$//; }
- print qq(.IX Name "$name - $desc"\n);
+ push(@Indices, qq(.IX Name "$name - $desc"\n));
}
print <<'END';
@@ -603,11 +665,22 @@ END
$indent = 0;
+$begun = "";
+
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
@@ -632,6 +705,22 @@ while (<>) {
$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();
@@ -640,6 +729,10 @@ while (<>) {
# 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
@@ -653,18 +746,16 @@ while (<>) {
)
} {I<$1>}gx;
- # func(n) is a reference to a man page
+ # func(n) is a reference to a perl function or a man page
s{
- (\w+)
+ ([:\w]+)
(
- \(
- [^\s,\051]+
- \)
+ \( [^\051]+ \)
)
} {I<$1>\\|$2}gx;
# convert simple variable references
- s/(\s+)([\$\@%][\w:]+)/${1}C<$2>/g;
+ s/(\s+)([\$\@%][\w:]+)(?!\()/${1}C<$2>/g;
if (m{ (
[\-\w]+
@@ -754,7 +845,7 @@ while (<>) {
? "the section on I<$2> in the I<$1> manpage"
: "the section on I<$2>"
}
- }gex;
+ }gesx; # s in case it goes over multiple lines, so . matches \n
s/Z<>/\\&/g;
@@ -769,8 +860,19 @@ while (<>) {
($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;
+ &escapes($dotlevel);
s/"/""/g;
}
@@ -783,11 +885,11 @@ while (<>) {
s/\s+$//;
delete $wanna_see{$_} if exists $wanna_see{$_};
print qq{.SH "$_"\n};
- print qq{.IX Header "$_"\n};
+ push(@Indices, qq{.IX Header "$_"\n});
}
elsif ($Cmd eq 'head2') {
print qq{.Sh "$_"\n};
- print qq{.IX Subsection "$_"\n};
+ push(@Indices, qq{.IX Subsection "$_"\n});
}
elsif ($Cmd eq 'over') {
push(@indent,$indent);
@@ -800,8 +902,13 @@ while (<>) {
}
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};
- print qq{.IX Item "$_"\n};
+ push(@Indices, qq{.IX Item "$_"\n});
}
elsif ($Cmd eq 'pod') {
# this is just a comment
@@ -814,7 +921,7 @@ while (<>) {
if ($needspace) {
&makespace;
}
- &escapes;
+ &escapes(0);
clear_noremap(1);
print $_, "\n";
$needspace = 1;
@@ -826,7 +933,7 @@ print <<"END";
.rn }` ''
END
-if (%wanna_see) {
+if (%wanna_see && !$lax) {
@missing = keys %wanna_see;
warn "$0: $Filename is missing required section"
. (@missing > 1 && "s")
@@ -834,6 +941,8 @@ if (%wanna_see) {
$oops++;
}
+foreach (@Indices) { print "$_\n"; }
+
exit;
#exit ($oops != 0);
@@ -846,6 +955,7 @@ sub nobreak {
}
sub escapes {
+ my $indot = shift;
s/X<(.*?)>/mkindex($1)/ge;
@@ -858,9 +968,19 @@ sub escapes {
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\\*(L$2")/ge;
- s/(['"])($|[\-\s,;\\!?.])/noremap("\\*(R$1$2")/ge;
+ s/(^|\s)(['"])/noremap("$1\\*($dotmacroL$2")/ge;
+ s/(['"])($|[\-\s,;\\!?.])/noremap("\\*($dotmacroR$1$2")/ge;
}
#s/(?!")(?:.)--(?!")(?:.)/\\*(--/g;
@@ -910,13 +1030,7 @@ sub escapes {
# 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) = @_;
- if ( /^\W+$/ && !/^\$./ ) {
- ($prev && "\n") . noremap(qq{.CQ $_ \n\\&});
- # what about $" ?
- } else {
- noremap(qq{${CFont_embed}$_\\fR});
- }
+ local($_,$prev) = @_;
noremap(qq{.CQ "$_" \n\\&});
}
@@ -932,7 +1046,7 @@ sub makespace {
sub mkindex {
my ($entry) = @_;
my @entries = split m:\s*/\s*:, $entry;
- print ".IX Xref ";
+ push @Indices, ".IX Xref " . join ' ', map {qq("$_")} @entries;
for $entry (@entries) {
print qq("$entry" );
}
@@ -952,9 +1066,8 @@ sub noremap {
}
sub init_noremap {
- if ( /[\200-\377]/ ) {
- warn "$0: high bit char in input stream in paragraph $. of $ARGV\n";
- }
+ # escape high bit characters in input stream
+ s/([\200-\377])/"E<".ord($1).">"/ge;
}
sub clear_noremap {
@@ -969,13 +1082,19 @@ sub clear_noremap {
# otherwise the interative \w<> processing would have
# been hosed by the E<gt>
s {
- E<
- ( [A-Za-z]+ )
+ E<
+ (
+ ( \d + )
+ | ( [A-Za-z]+ )
+ )
>
} {
- do {
- exists $HTML_Escapes{$1}
- ? do { $HTML_Escapes{$1} }
+ 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>";
@@ -986,6 +1105,7 @@ sub clear_noremap {
sub internal_lrefs {
local($_) = shift;
+ local $trailing_and = s/and\s+$// ? "and " : "";
s{L</([^>]+)>}{$1}g;
my(@items) = split( /(?:,?\s+(?:and\s+)?)/ );
@@ -998,7 +1118,8 @@ sub internal_lrefs {
}
$retstr .= " entr" . ( @items > 1 ? "ies" : "y" )
- . " elsewhere in this document";
+ . " elsewhere in this document "; # terminal space to avoid words running together (pattern used strips terminal spaces)
+ $retstr .= $trailing_and;
return $retstr;
diff --git a/gnu/usr.bin/perl/pod/pod2text.PL b/gnu/usr.bin/perl/pod/pod2text.PL
index 49198078c00..da645b554ee 100644
--- a/gnu/usr.bin/perl/pod/pod2text.PL
+++ b/gnu/usr.bin/perl/pod/pod2text.PL
@@ -12,10 +12,9 @@ use File::Basename qw(&basename &dirname);
# 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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
@@ -25,9 +24,9 @@ print "Extracting $file (with variable substitutions)\n";
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
- eval 'exec perl -S \$0 "\$@"'
- if 0;
+$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.
diff --git a/gnu/usr.bin/perl/pod/roffitall b/gnu/usr.bin/perl/pod/roffitall
index 024279a69ea..cbd19af4fed 100644
--- a/gnu/usr.bin/perl/pod/roffitall
+++ b/gnu/usr.bin/perl/pod/roffitall
@@ -1,84 +1,201 @@
#!/bin/sh
-#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 \
- /usr/local/man/man1/perl.1 \
- /usr/local/man/man1/perldata.1 \
- /usr/local/man/man1/perlsyn.1 \
- /usr/local/man/man1/perlop.1 \
- /usr/local/man/man1/perlre.1 \
- /usr/local/man/man1/perlrun.1 \
- /usr/local/man/man1/perlfunc.1 \
- /usr/local/man/man1/perlvar.1 \
- /usr/local/man/man1/perlsub.1 \
- /usr/local/man/man1/perlmod.1 \
- /usr/local/man/man1/perlref.1 \
- /usr/local/man/man1/perldsc.1 \
- /usr/local/man/man1/perllol.1 \
- /usr/local/man/man1/perlobj.1 \
- /usr/local/man/man1/perltie.1 \
- /usr/local/man/man1/perlbot.1 \
- /usr/local/man/man1/perldebug.1 \
- /usr/local/man/man1/perldiag.1 \
- /usr/local/man/man1/perlform.1 \
- /usr/local/man/man1/perlipc.1 \
- /usr/local/man/man1/perlsec.1 \
- /usr/local/man/man1/perltrap.1 \
- /usr/local/man/man1/perlstyle.1 \
- /usr/local/man/man1/perlxs.1 \
- /usr/local/man/man1/perlxstut.1 \
- /usr/local/man/man1/perlguts.1 \
- /usr/local/man/man1/perlcall.1 \
- /usr/local/man/man1/perlembed.1 \
- /usr/local/man/man1/perlpod.1 \
- /usr/local/man/man1/perlbook.1 \
+#
+# 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/local/man/man1
+test -d $libdir || libdir=/usr/local/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/perldelta.1 \
+ $mandir/perldata.1 \
+ $mandir/perlsyn.1 \
+ $mandir/perlop.1 \
+ $mandir/perlre.1 \
+ $mandir/perlrun.1 \
+ $mandir/perllocale.1 \
+ $mandir/perlfunc.1 \
+ $mandir/perlvar.1 \
+ $mandir/perlsub.1 \
+ $mandir/perlmod.1 \
+ $mandir/perlmodlib.1 \
+ $mandir/perlref.1 \
+ $mandir/perldsc.1 \
+ $mandir/perllol.1 \
+ $mandir/perlobj.1 \
+ $mandir/perltie.1 \
+ $mandir/perltoot.1 \
+ $mandir/perlbot.1 \
+ $mandir/perldebug.1 \
+ $mandir/perldiag.1 \
+ $mandir/perlform.1 \
+ $mandir/perlipc.1 \
+ $mandir/perlsec.1 \
+ $mandir/perltrap.1 \
+ $mandir/perlstyle.1 \
+ $mandir/perlapio.1 \
+ $mandir/perlxs.1 \
+ $mandir/perlxstut.1 \
+ $mandir/perlguts.1 \
+ $mandir/perlcall.1 \
+ $mandir/perlembed.1 \
+ $mandir/perlpod.1 \
+ $mandir/perlbook.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 \
\
- /usr/local/man/man3/diagnostics.3 \
- /usr/local/man/man3/integer.3 \
- /usr/local/man/man3/less.3 \
- /usr/local/man/man3/lib.3 \
- /usr/local/man/man3/overload.3 \
- /usr/local/man/man3/sigtrap.3 \
- /usr/local/man/man3/strict.3 \
- /usr/local/man/man3/subs.3 \
+ $libdir/blib.3 \
+ $libdir/diagnostics.3 \
+ $libdir/integer.3 \
+ $libdir/less.3 \
+ $libdir/lib.3 \
+ $libdir/locale.3 \
+ $libdir/overload.3 \
+ $libdir/sigtrap.3 \
+ $libdir/strict.3 \
+ $libdir/subs.3 \
+ $libdir/vars.3 \
\
- /usr/local/man/man3/AnyDBM_File.3 \
- /usr/local/man/man3/AutoLoader.3 \
- /usr/local/man/man3/AutoSplit.3 \
- /usr/local/man/man3/Benchmark.3 \
- /usr/local/man/man3/Carp.3 \
- /usr/local/man/man3/Config.3 \
- /usr/local/man/man3/Cwd.3 \
- /usr/local/man/man3/DB_File.3 \
- /usr/local/man/man3/Devel::SelfStubber.3 \
- /usr/local/man/man3/DynaLoader.3 \
- /usr/local/man/man3/English.3 \
- /usr/local/man/man3/Env.3 \
- /usr/local/man/man3/Exporter.3 \
- /usr/local/man/man3/ExtUtils::Liblist.3 \
- /usr/local/man/man3/ExtUtils::MakeMaker.3 \
- /usr/local/man/man3/ExtUtils::Manifest.3 \
- /usr/local/man/man3/ExtUtils::Mkbootstrap.3 \
- /usr/local/man/man3/Fcntl.3 \
- /usr/local/man/man3/File::Basename.3 \
- /usr/local/man/man3/File::CheckTree.3 \
- /usr/local/man/man3/File::Find.3 \
- /usr/local/man/man3/FileHandle.3 \
- /usr/local/man/man3/File::Path.3 \
- /usr/local/man/man3/Getopt::Long.3 \
- /usr/local/man/man3/Getopt::Std.3 \
- /usr/local/man/man3/I18N::Collate.3 \
- /usr/local/man/man3/IPC::Open2.3 \
- /usr/local/man/man3/IPC::Open3.3 \
- /usr/local/man/man3/Net::Ping.3 \
- /usr/local/man/man3/POSIX.3 \
- /usr/local/man/man3/Safe.3 \
- /usr/local/man/man3/SelfLoader.3 \
- /usr/local/man/man3/Socket.3 \
- /usr/local/man/man3/Sys::Hostname.3 \
- /usr/local/man/man3/Term::Cap.3 \
- /usr/local/man/man3/Term::Complete.3 \
- /usr/local/man/man3/Test::Harness.3 \
- /usr/local/man/man3/Text::Abbrev.3 \
- /usr/local/man/man3/Text::Soundex.3 \
- /usr/local/man/man3/TieHash.3 \
- /usr/local/man/man3/Time::Local.3
+ $libdir/AnyDBM_File.3 \
+ $libdir/AutoLoader.3 \
+ $libdir/AutoSplit.3 \
+ $libdir/Benchmark.3 \
+ $libdir/Carp.3 \
+ $libdir/Config.3 \
+ $libdir/Cwd.3 \
+ $libdir/DB_File.3 \
+ $libdir/Devel::SelfStubber.3 \
+ $libdir/DynaLoader.3 \
+ $libdir/English.3 \
+ $libdir/Env.3 \
+ $libdir/Exporter.3 \
+ $libdir/ExtUtils::Embed.3 \
+ $libdir/ExtUtils::Install.3 \
+ $libdir/ExtUtils::Liblist.3 \
+ $libdir/ExtUtils::MakeMaker.3 \
+ $libdir/ExtUtils::Manifest.3 \
+ $libdir/ExtUtils::Mkbootstrap.3 \
+ $libdir/ExtUtils::Mksymlists.3 \
+ $libdir/Fcntl.3 \
+ $libdir/File::Basename.3 \
+ $libdir/File::CheckTree.3 \
+ $libdir/File::Copy.3 \
+ $libdir/File::Compare.3 \
+ $libdir/File::Find.3 \
+ $libdir/File::Path.3 \
+ $libdir/File::stat.3 \
+ $libdir/FileCache.3 \
+ $libdir/FileHandle.3 \
+ $libdir/FindBin.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::Open2.3 \
+ $libdir/IPC::Open3.3 \
+ $libdir/Math::BigFloat.3 \
+ $libdir/Math::BigInt.3 \
+ $libdir/Math::Complex.3 \
+ $libdir/Math::Trig.3 \
+ $libdir/Net::Ping.3 \
+ $libdir/Net::hostent.3 \
+ $libdir/Net::netent.3 \
+ $libdir/Net::protoent.3 \
+ $libdir/Net::servent.3 \
+ $libdir/Opcode.3 \
+ $libdir/POSIX.3 \
+ $libdir/Pod::Text.3 \
+ $libdir/Safe.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/Test::Harness.3 \
+ $libdir/Text::Abbrev.3 \
+ $libdir/Text::ParseWords.3 \
+ $libdir/Text::Soundex.3 \
+ $libdir/Text::Tabs.3 \
+ $libdir/Tie::Hash.3 \
+ $libdir/Tie::RefHash.3 \
+ $libdir/Tie::Scalar.3 \
+ $libdir/Tie::SubstrHash.3 \
+ $libdir/Time::Local.3 \
+ $libdir/Time::gmtime.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/gnu/usr.bin/perl/pod/rofftoc b/gnu/usr.bin/perl/pod/rofftoc
new file mode 100644
index 00000000000..a2d0e7ba204
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/pod/splitpod b/gnu/usr.bin/perl/pod/splitpod
index 8db40603706..fd38e51acf8 100644
--- a/gnu/usr.bin/perl/pod/splitpod
+++ b/gnu/usr.bin/perl/pod/splitpod
@@ -12,21 +12,33 @@ while (<>) {
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;
- $pod{$cur} .= $_ if $cur;
+ push @{$pod{$cur}}, $_ if $cur;
}
}
for $f ( keys %syn ) {
- $type = $Type{$f} || next;
+ 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
@@ -39,7 +51,7 @@ $syn{$orig}
=head1 DESCRIPTION
-$pod{$orig}
+$body
EOF
diff --git a/gnu/usr.bin/perl/pp.c b/gnu/usr.bin/perl/pp.c
index 54433af2925..3513dda13d8 100644
--- a/gnu/usr.bin/perl/pp.c
+++ b/gnu/usr.bin/perl/pp.c
@@ -1,6 +1,6 @@
/* pp.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -15,16 +15,101 @@
#include "EXTERN.h"
#include "perl.h"
-static void doencodes _((SV *sv, char *s, I32 len));
+/*
+ * 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 BYTEORDER > 0xFFFF && 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.)
+ */
+#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
+
+static void doencodes _((SV* sv, char* s, I32 len));
+static SV* refto _((SV* sv));
+static U32 seed _((void));
+
+static bool srand_called = FALSE;
/* variations on pp_null */
PP(pp_stub)
{
dSP;
- if (GIMME != G_ARRAY) {
+ if (GIMME_V == G_SCALAR)
XPUSHs(&sv_undef);
- }
RETURN;
}
@@ -63,25 +148,27 @@ PP(pp_padav)
PP(pp_padhv)
{
dSP; dTARGET;
+ I32 gimme;
+
XPUSHs(TARG);
if (op->op_private & OPpLVAL_INTRO)
SAVECLEARSV(curpad[op->op_targ]);
if (op->op_flags & OPf_REF)
RETURN;
- if (GIMME == G_ARRAY) { /* array wanted */
+ gimme = GIMME_V;
+ if (gimme == G_ARRAY) {
RETURNOP(do_kv(ARGS));
}
- else {
+ else if (gimme == G_SCALAR) {
SV* sv = sv_newmortal();
- if (HvFILL((HV*)TARG)) {
- sprintf(buf, "%d/%d", HvFILL((HV*)TARG), HvMAX((HV*)TARG)+1);
- sv_setpv(sv, buf);
- }
+ 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;
}
+ RETURN;
}
PP(pp_padany)
@@ -98,7 +185,13 @@ PP(pp_rv2gv)
if (SvROK(sv)) {
wasref:
sv = SvRV(sv);
- if (SvTYPE(sv) != SVt_PVGV)
+ 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 {
@@ -114,6 +207,8 @@ PP(pp_rv2gv)
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a symbol");
+ if (dowarn)
+ warn(warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, na);
@@ -122,28 +217,8 @@ PP(pp_rv2gv)
sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVGV);
}
}
- if (op->op_private & OPpLVAL_INTRO) {
- GP *ogp = GvGP(sv);
-
- SSCHECK(3);
- SSPUSHPTR(SvREFCNT_inc(sv));
- SSPUSHPTR(ogp);
- SSPUSHINT(SAVEt_GP);
-
- if (op->op_flags & OPf_SPECIAL) {
- GvGP(sv)->gp_refcnt++; /* will soon be assigned */
- GvINTRO_on(sv);
- }
- else {
- GP *gp;
- Newz(602,gp, 1, GP);
- GvGP(sv) = gp;
- GvREFCNT(sv) = 1;
- GvSV(sv) = NEWSV(72,0);
- GvLINE(sv) = curcop->cop_line;
- GvEGV(sv) = sv;
- }
- }
+ if (op->op_private & OPpLVAL_INTRO)
+ save_gp((GV*)sv, !(op->op_flags & OPf_SPECIAL));
SETs(sv);
RETURN;
}
@@ -163,7 +238,7 @@ PP(pp_rv2sv)
}
}
else {
- GV *gv = sv;
+ GV *gv = (GV*)sv;
char *sym;
if (SvTYPE(gv) != SVt_PVGV) {
@@ -176,20 +251,22 @@ PP(pp_rv2sv)
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a SCALAR");
+ if (dowarn)
+ warn(warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, na);
if (op->op_private & HINT_STRICT_REFS)
DIE(no_symref, sym, "a SCALAR");
- gv = (SV*)gv_fetchpv(sym, TRUE, SVt_PV);
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
}
sv = GvSV(gv);
}
if (op->op_flags & OPf_MOD) {
if (op->op_private & OPpLVAL_INTRO)
sv = save_scalar((GV*)TOPs);
- else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
- provide_ref(op, sv);
+ else if (op->op_private & OPpDEREF)
+ vivify_ref(sv, op->op_private & OPpDEREF);
}
SETs(sv);
RETURN;
@@ -214,7 +291,12 @@ PP(pp_pos)
dSP; dTARGET; dPOPss;
if (op->op_flags & OPf_MOD) {
- LvTYPE(TARG) = '<';
+ if (SvTYPE(TARG) < SVt_PVLV) {
+ sv_upgrade(TARG, SVt_PVLV);
+ sv_magic(TARG, Nullsv, '.', Nullch, 0);
+ }
+
+ LvTYPE(TARG) = '.';
LvTARG(TARG) = sv;
PUSHs(TARG); /* no SvSETMAGIC */
RETURN;
@@ -242,8 +324,11 @@ PP(pp_rv2cv)
/* We usually try to add a non-existent subroutine in case of AUTOLOAD. */
/* (But not in defined().) */
CV *cv = sv_2cv(TOPs, &stash, &gv, !(op->op_flags & OPf_SPECIAL));
-
- if (!cv)
+ if (cv) {
+ if (CvCLONE(cv))
+ cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ }
+ else
cv = (CV*)&sv_undef;
SETs((SV*)cv);
RETURN;
@@ -259,10 +344,8 @@ PP(pp_prototype)
ret = &sv_undef;
cv = sv_2cv(TOPs, &stash, &gv, FALSE);
- if (cv && SvPOK(cv)) {
- char *p = SvPVX(cv);
- ret = sv_2mortal(newSVpv(p ? p : "", SvLEN(cv)));
- }
+ if (cv && SvPOK(cv))
+ ret = sv_2mortal(newSVpv(SvPVX(cv), SvCUR(cv)));
SETs(ret);
RETURN;
}
@@ -270,60 +353,59 @@ PP(pp_prototype)
PP(pp_anoncode)
{
dSP;
- CV* cv = (CV*)cSVOP->op_sv;
- EXTEND(SP,1);
-
+ CV* cv = (CV*)curpad[op->op_targ];
if (CvCLONE(cv))
cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
-
+ EXTEND(SP,1);
PUSHs((SV*)cv);
RETURN;
}
PP(pp_srefgen)
{
- dSP; dTOPss;
- SV* rv;
- rv = sv_newmortal();
- sv_upgrade(rv, SVt_RV);
- if (SvPADTMP(sv))
- sv = newSVsv(sv);
- else {
- SvTEMP_off(sv);
- (void)SvREFCNT_inc(sv);
- }
- SvRV(rv) = sv;
- SvROK_on(rv);
- SETs(rv);
+ dSP;
+ *SP = refto(*SP);
RETURN;
}
PP(pp_refgen)
{
dSP; dMARK;
- SV* sv;
- SV* rv;
if (GIMME != G_ARRAY) {
MARK[1] = *SP;
SP = MARK + 1;
}
- while (MARK < SP) {
- sv = *++MARK;
- rv = sv_newmortal();
- sv_upgrade(rv, SVt_RV);
- if (SvPADTMP(sv))
- sv = newSVsv(sv);
- else {
- SvTEMP_off(sv);
- (void)SvREFCNT_inc(sv);
- }
- SvRV(rv) = sv;
- SvROK_on(rv);
- *MARK = rv;
- }
+ EXTEND_MORTAL(SP - MARK);
+ while (++MARK <= SP)
+ *MARK = refto(*MARK);
RETURN;
}
+static SV*
+refto(sv)
+SV* sv;
+{
+ SV* rv;
+
+ if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
+ if (LvTARGLEN(sv))
+ vivify_defelem(sv);
+ if (!(sv = LvTARG(sv)))
+ sv = &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)
{
dSP; dTARGET;
@@ -331,6 +413,10 @@ PP(pp_ref)
char *pv;
sv = POPs;
+
+ if (sv && SvGMAGICAL(sv))
+ mg_get(sv);
+
if (!sv || !SvROK(sv))
RETPUSHNO;
@@ -354,6 +440,68 @@ PP(pp_bless)
RETURN;
}
+PP(pp_gelem)
+{
+ GV *gv;
+ SV *sv;
+ SV *ref;
+ char *elem;
+ dSP;
+
+ sv = POPs;
+ elem = SvPV(sv, na);
+ gv = (GV*)POPs;
+ ref = Nullsv;
+ sv = Nullsv;
+ switch (elem ? *elem : '\0')
+ {
+ case 'A':
+ if (strEQ(elem, "ARRAY"))
+ ref = (SV*)GvAV(gv);
+ break;
+ case 'C':
+ if (strEQ(elem, "CODE"))
+ ref = (SV*)GvCVu(gv);
+ break;
+ case 'F':
+ if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
+ ref = (SV*)GvIOp(gv);
+ break;
+ case 'G':
+ if (strEQ(elem, "GLOB"))
+ ref = (SV*)gv;
+ break;
+ case 'H':
+ if (strEQ(elem, "HASH"))
+ ref = (SV*)GvHV(gv);
+ break;
+ case 'I':
+ if (strEQ(elem, "IO"))
+ ref = (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"))
+ ref = GvSV(gv);
+ break;
+ }
+ if (ref)
+ sv = newRV(ref);
+ if (sv)
+ sv_2mortal(sv);
+ else
+ sv = &sv_undef;
+ XPUSHs(sv);
+ RETURN;
+}
+
/* Pattern matching */
PP(pp_study)
@@ -364,13 +512,12 @@ PP(pp_study)
register I32 ch;
register I32 *sfirst;
register I32 *snext;
- I32 retval;
STRLEN len;
- s = (unsigned char*)(SvPV(sv, len));
- pos = len;
- if (sv == lastscream)
- SvSCREAM_off(sv);
+ if (sv == lastscream) {
+ if (SvSCREAM(sv))
+ RETPUSHYES;
+ }
else {
if (lastscream) {
SvSCREAM_off(lastscream);
@@ -378,10 +525,11 @@ PP(pp_study)
}
lastscream = SvREFCNT_inc(sv);
}
- if (pos <= 0) {
- retval = 0;
- goto ret;
- }
+
+ s = (unsigned char*)(SvPV(sv, len));
+ pos = len;
+ if (pos <= 0)
+ RETPUSHNO;
if (pos > maxscream) {
if (maxscream < 0) {
maxscream = pos + 80;
@@ -411,21 +559,11 @@ PP(pp_study)
else
snext[pos] = -pos;
sfirst[ch] = pos;
-
- /* If there were any case insensitive searches, we must assume they
- * all are. This speeds up insensitive searches much more than
- * it slows down sensitive ones.
- */
- if (sawi)
- sfirst[fold[ch]] = pos;
}
SvSCREAM_on(sv);
sv_magic(sv, Nullsv, 'g', Nullch, 0); /* piggyback on m//g magic */
- retval = 1;
- ret:
- XPUSHs(sv_2mortal(newSViv((I32)retval)));
- RETURN;
+ RETPUSHYES;
}
PP(pp_trans)
@@ -491,11 +629,11 @@ PP(pp_defined)
RETPUSHNO;
switch (SvTYPE(sv)) {
case SVt_PVAV:
- if (AvMAX(sv) >= 0 || SvRMAGICAL(sv))
+ if (AvMAX(sv) >= 0 || SvGMAGICAL(sv))
RETPUSHYES;
break;
case SVt_PVHV:
- if (HvARRAY(sv) || SvRMAGICAL(sv))
+ if (HvARRAY(sv) || SvGMAGICAL(sv))
RETPUSHYES;
break;
case SVt_PVCV:
@@ -516,8 +654,10 @@ PP(pp_undef)
dSP;
SV *sv;
- if (!op->op_private)
+ if (!op->op_private) {
+ EXTEND(SP, 1);
RETPUSHUNDEF;
+ }
sv = POPs;
if (!sv)
@@ -540,16 +680,21 @@ PP(pp_undef)
hv_undef((HV*)sv);
break;
case SVt_PVCV:
- cv_undef((CV*)sv);
- sub_generation++;
+ if (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)) {
- sv_setsv(sv, &sv_undef);
- break;
- }
+ if (SvFAKE(sv))
+ sv_setsv(sv, &sv_undef);
+ break;
default:
- if (SvPOK(sv) && SvLEN(sv)) {
+ if (SvTYPE(sv) >= SVt_PV && SvPVX(sv) && SvLEN(sv)) {
(void)SvOOK_off(sv);
Safefree(SvPVX(sv));
SvPV_set(sv, Nullch);
@@ -565,9 +710,13 @@ PP(pp_undef)
PP(pp_predec)
{
dSP;
- if (SvIOK(TOPs)) {
+ 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) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
+ SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
sv_dec(TOPs);
@@ -578,10 +727,14 @@ PP(pp_predec)
PP(pp_postinc)
{
dSP; dTARGET;
+ if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ croak(no_modify);
sv_setsv(TARG, TOPs);
- if (SvIOK(TOPs)) {
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ SvIVX(TOPs) != IV_MAX)
+ {
++SvIVX(TOPs);
- SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
+ SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
sv_inc(TOPs);
@@ -595,10 +748,14 @@ PP(pp_postinc)
PP(pp_postdec)
{
dSP; dTARGET;
+ if(SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
+ croak(no_modify);
sv_setsv(TARG, TOPs);
- if (SvIOK(TOPs)) {
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
+ SvIVX(TOPs) != IV_MIN)
+ {
--SvIVX(TOPs);
- SvFLAGS(TOPs) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
+ SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
sv_dec(TOPs);
@@ -633,25 +790,24 @@ PP(pp_divide)
{
dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
- dPOPnv;
- if (value == 0.0)
+ dPOPPOPnnrl;
+ double value;
+ if (right == 0.0)
DIE("Illegal division by zero");
#ifdef SLOPPYDIVIDE
/* insure that 20./5. == 4. */
{
- double x;
- I32 k;
- x = POPn;
- if ((double)I_32(x) == x &&
- (double)I_32(value) == value &&
- (k = I_32(x)/I_32(value))*I_32(value) == I_32(x)) {
+ 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 = x/value;
+ value = left / right;
}
}
#else
- value = POPn / value;
+ value = left / right;
#endif
PUSHn( value );
RETURN;
@@ -662,21 +818,47 @@ PP(pp_modulo)
{
dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
{
- register unsigned long tmpulong;
- register long tmplong;
- I32 value;
+ 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);
+ }
- tmpulong = (unsigned long) POPn;
- if (tmpulong == 0L)
- DIE("Illegal modulus zero");
- value = TOPn;
- if (value >= 0.0)
- value = (I32)(((unsigned long)value) % tmpulong);
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ IV i = SvIVX(POPs);
+ left = (left_neg = (i < 0)) ? -i : i;
+ }
else {
- tmplong = (long)value;
- value = (I32)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
+ double n = POPn;
+ left = U_V((left_neg = (n < 0)) ? -n : n);
}
- SETi(value);
+
+ 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)
+ sv_setiv(TARG, (IV) -ans);
+ else
+ sv_setnv(TARG, -(double)ans);
+ }
+ else
+ sv_setuv(TARG, ans);
+ PUSHTARG;
RETURN;
}
}
@@ -720,16 +902,17 @@ PP(pp_repeat)
}
SvSetSV(TARG, tmpstr);
SvPV_force(TARG, len);
- if (count >= 1) {
- SvGROW(TARG, (count * len) + 1);
- if (count > 1)
+ 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;
+ SvCUR(TARG) *= count;
+ }
*SvEND(TARG) = '\0';
- (void)SvPOK_only(TARG);
}
- else
- sv_setsv(TARG, &sv_no);
+ (void)SvPOK_only(TARG);
PUSHTARG;
}
RETURN;
@@ -740,7 +923,7 @@ PP(pp_subtract)
{
dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
- dPOPTOPnnrl;
+ dPOPTOPnnrl_ul;
SETn( left - right );
RETURN;
}
@@ -750,9 +933,18 @@ PP(pp_left_shift)
{
dSP; dATARGET; tryAMAGICbin(lshift,opASSIGN);
{
- dPOPTOPiirl;
- SETi( left << right );
- RETURN;
+ IBW shift = POPi;
+ if (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;
}
}
@@ -760,8 +952,17 @@ PP(pp_right_shift)
{
dSP; dATARGET; tryAMAGICbin(rshift,opASSIGN);
{
- dPOPTOPiirl;
- SETi( left >> right );
+ IBW shift = POPi;
+ if (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;
}
}
@@ -771,7 +972,7 @@ PP(pp_lt)
dSP; tryAMAGICbinSET(lt,0);
{
dPOPnv;
- SETs((TOPn < value) ? &sv_yes : &sv_no);
+ SETs(boolSV(TOPn < value));
RETURN;
}
}
@@ -781,7 +982,7 @@ PP(pp_gt)
dSP; tryAMAGICbinSET(gt,0);
{
dPOPnv;
- SETs((TOPn > value) ? &sv_yes : &sv_no);
+ SETs(boolSV(TOPn > value));
RETURN;
}
}
@@ -791,7 +992,7 @@ PP(pp_le)
dSP; tryAMAGICbinSET(le,0);
{
dPOPnv;
- SETs((TOPn <= value) ? &sv_yes : &sv_no);
+ SETs(boolSV(TOPn <= value));
RETURN;
}
}
@@ -801,7 +1002,7 @@ PP(pp_ge)
dSP; tryAMAGICbinSET(ge,0);
{
dPOPnv;
- SETs((TOPn >= value) ? &sv_yes : &sv_no);
+ SETs(boolSV(TOPn >= value));
RETURN;
}
}
@@ -811,7 +1012,7 @@ PP(pp_ne)
dSP; tryAMAGICbinSET(ne,0);
{
dPOPnv;
- SETs((TOPn != value) ? &sv_yes : &sv_no);
+ SETs(boolSV(TOPn != value));
RETURN;
}
}
@@ -823,12 +1024,16 @@ PP(pp_ncmp)
dPOPTOPnnrl;
I32 value;
- if (left > right)
- value = 1;
+ if (left == right)
+ value = 0;
else if (left < right)
value = -1;
- else
- value = 0;
+ else if (left > right)
+ value = 1;
+ else {
+ SETs(&sv_undef);
+ RETURN;
+ }
SETi(value);
RETURN;
}
@@ -839,7 +1044,10 @@ PP(pp_slt)
dSP; tryAMAGICbinSET(slt,0);
{
dPOPTOPssrl;
- SETs( sv_cmp(left, right) < 0 ? &sv_yes : &sv_no );
+ int cmp = ((op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp < 0));
RETURN;
}
}
@@ -849,7 +1057,10 @@ PP(pp_sgt)
dSP; tryAMAGICbinSET(sgt,0);
{
dPOPTOPssrl;
- SETs( sv_cmp(left, right) > 0 ? &sv_yes : &sv_no );
+ int cmp = ((op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp > 0));
RETURN;
}
}
@@ -859,7 +1070,10 @@ PP(pp_sle)
dSP; tryAMAGICbinSET(sle,0);
{
dPOPTOPssrl;
- SETs( sv_cmp(left, right) <= 0 ? &sv_yes : &sv_no );
+ int cmp = ((op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp <= 0));
RETURN;
}
}
@@ -869,7 +1083,20 @@ PP(pp_sge)
dSP; tryAMAGICbinSET(sge,0);
{
dPOPTOPssrl;
- SETs( sv_cmp(left, right) >= 0 ? &sv_yes : &sv_no );
+ int cmp = ((op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETs(boolSV(cmp >= 0));
+ RETURN;
+ }
+}
+
+PP(pp_seq)
+{
+ dSP; tryAMAGICbinSET(seq,0);
+ {
+ dPOPTOPssrl;
+ SETs(boolSV(sv_eq(left, right)));
RETURN;
}
}
@@ -879,7 +1106,7 @@ PP(pp_sne)
dSP; tryAMAGICbinSET(sne,0);
{
dPOPTOPssrl;
- SETs( !sv_eq(left, right) ? &sv_yes : &sv_no );
+ SETs(boolSV(!sv_eq(left, right)));
RETURN;
}
}
@@ -889,19 +1116,28 @@ PP(pp_scmp)
dSP; dTARGET; tryAMAGICbin(scmp,0);
{
dPOPTOPssrl;
- SETi( sv_cmp(left, right) );
+ int cmp = ((op->op_private & OPpLOCALE)
+ ? sv_cmp_locale(left, right)
+ : sv_cmp(left, right));
+ SETi( cmp );
RETURN;
}
}
-PP(pp_bit_and) {
+PP(pp_bit_and)
+{
dSP; dATARGET; tryAMAGICbin(band,opASSIGN);
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
- unsigned long value = U_L(SvNV(left));
- value = value & U_L(SvNV(right));
- SETn((double)value);
+ if (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(op->op_type, TARG, left, right);
@@ -917,9 +1153,14 @@ PP(pp_bit_xor)
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
- unsigned long value = U_L(SvNV(left));
- value = value ^ U_L(SvNV(right));
- SETn((double)value);
+ if (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(op->op_type, TARG, left, right);
@@ -935,9 +1176,14 @@ PP(pp_bit_or)
{
dPOPTOPssrl;
if (SvNIOKp(left) || SvNIOKp(right)) {
- unsigned long value = U_L(SvNV(left));
- value = value | U_L(SvNV(right));
- SETn((double)value);
+ if (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(op->op_type, TARG, left, right);
@@ -954,12 +1200,14 @@ PP(pp_negate)
dTOPss;
if (SvGMAGICAL(sv))
mg_get(sv);
- if (SvNIOKp(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 (isALPHA(*s) || *s == '_') {
+ if (isIDFIRST(*s)) {
sv_setpvn(TARG, "-", 1);
sv_catsv(TARG, sv);
}
@@ -982,7 +1230,7 @@ PP(pp_not)
#ifdef OVERLOAD
dSP; tryAMAGICunSET(not);
#endif /* OVERLOAD */
- *stack_sp = SvTRUE(*stack_sp) ? &sv_no : &sv_yes;
+ *stack_sp = boolSV(!SvTRUE(*stack_sp));
return NORMAL;
}
@@ -991,18 +1239,20 @@ PP(pp_complement)
dSP; dTARGET; tryAMAGICun(compl);
{
dTOPss;
- register I32 anum;
-
if (SvNIOKp(sv)) {
- IV iv = ~SvIV(sv);
- if (iv < 0)
- SETn( (double) ~U_L(SvNV(sv)) );
- else
- SETi( iv );
+ if (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);
@@ -1055,6 +1305,8 @@ PP(pp_i_modulo)
dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
{
dPOPTOPiirl;
+ if (!right)
+ DIE("Illegal modulus zero");
SETi( left % right );
RETURN;
}
@@ -1085,7 +1337,7 @@ PP(pp_i_lt)
dSP; tryAMAGICbinSET(lt,0);
{
dPOPTOPiirl;
- SETs((left < right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left < right));
RETURN;
}
}
@@ -1095,7 +1347,7 @@ PP(pp_i_gt)
dSP; tryAMAGICbinSET(gt,0);
{
dPOPTOPiirl;
- SETs((left > right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left > right));
RETURN;
}
}
@@ -1105,7 +1357,7 @@ PP(pp_i_le)
dSP; tryAMAGICbinSET(le,0);
{
dPOPTOPiirl;
- SETs((left <= right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left <= right));
RETURN;
}
}
@@ -1115,7 +1367,7 @@ PP(pp_i_ge)
dSP; tryAMAGICbinSET(ge,0);
{
dPOPTOPiirl;
- SETs((left >= right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left >= right));
RETURN;
}
}
@@ -1125,7 +1377,7 @@ PP(pp_i_eq)
dSP; tryAMAGICbinSET(eq,0);
{
dPOPTOPiirl;
- SETs((left == right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left == right));
RETURN;
}
}
@@ -1135,7 +1387,7 @@ PP(pp_i_ne)
dSP; tryAMAGICbinSET(ne,0);
{
dPOPTOPiirl;
- SETs((left != right) ? &sv_yes : &sv_no);
+ SETs(boolSV(left != right));
RETURN;
}
}
@@ -1211,6 +1463,10 @@ PP(pp_rand)
value = POPn;
if (value == 0.0)
value = 1.0;
+ if (!srand_called) {
+ (void)srand((unsigned)seed());
+ srand_called = TRUE;
+ }
#if RANDBITS == 31
value = rand() * value / 2147483648.0;
#else
@@ -1231,20 +1487,69 @@ PP(pp_rand)
PP(pp_srand)
{
dSP;
- I32 anum;
- Time_t when;
-
- if (MAXARG < 1) {
- (void)time(&when);
- anum = when;
- }
+ UV anum;
+ if (MAXARG < 1)
+ anum = seed();
else
- anum = POPi;
- (void)srand(anum);
+ anum = POPu;
+ (void)srand((unsigned)anum);
+ srand_called = TRUE;
EXTEND(SP, 1);
RETPUSHYES;
}
+static U32
+seed()
+{
+ /*
+ * 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
+
+ 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)stack_sp;
+#ifndef PLAN9 /* XXX Plan9 assembler chokes on this; fix needed */
+ u += SEED_C5 * (U32)(UV)&when;
+#endif
+ return u;
+}
+
PP(pp_exp)
{
dSP; dTARGET; tryAMAGICun(exp);
@@ -1263,8 +1568,10 @@ PP(pp_log)
{
double value;
value = POPn;
- if (value <= 0.0)
+ if (value <= 0.0) {
+ SET_NUMERIC_STANDARD();
DIE("Can't take log of %g", value);
+ }
value = log(value);
XPUSHn(value);
RETURN;
@@ -1277,8 +1584,10 @@ PP(pp_sqrt)
{
double value;
value = POPn;
- if (value < 0.0)
+ if (value < 0.0) {
+ SET_NUMERIC_STANDARD();
DIE("Can't take sqrt of %g", value);
+ }
value = sqrt(value);
XPUSHn(value);
RETURN;
@@ -1288,15 +1597,28 @@ PP(pp_sqrt)
PP(pp_int)
{
dSP; dTARGET;
- double value;
- value = POPn;
- if (value >= 0.0)
- (void)modf(value, &value);
- else {
- (void)modf(-value, &value);
- value = -value;
+ {
+ 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);
+ }
}
- XPUSHn(value);
RETURN;
}
@@ -1304,37 +1626,39 @@ PP(pp_abs)
{
dSP; dTARGET; tryAMAGICun(abs);
{
- double value;
- value = POPn;
-
- if (value < 0.0)
- value = -value;
+ double value = TOPn;
+ IV iv;
- XPUSHn(value);
- RETURN;
+ 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)
{
dSP; dTARGET;
char *tmps;
- unsigned long value;
I32 argtype;
tmps = POPp;
- value = scan_hex(tmps, 99, &argtype);
- if ((IV)value >= 0)
- XPUSHi(value);
- else
- XPUSHn(U_V(value));
+ XPUSHu(scan_hex(tmps, 99, &argtype));
RETURN;
}
PP(pp_oct)
{
dSP; dTARGET;
- unsigned long value;
+ UV value;
I32 argtype;
char *tmps;
@@ -1347,10 +1671,7 @@ PP(pp_oct)
value = scan_hex(++tmps, 99, &argtype);
else
value = scan_oct(tmps, 99, &argtype);
- if ((IV)value >= 0)
- XPUSHi(value);
- else
- XPUSHn(U_V(value));
+ XPUSHu(value);
RETURN;
}
@@ -1371,44 +1692,76 @@ PP(pp_substr)
STRLEN curlen;
I32 pos;
I32 rem;
+ I32 fail;
I32 lvalue = op->op_flags & OPf_MOD;
char *tmps;
I32 arybase = curcop->cop_arybase;
if (MAXARG > 2)
len = POPi;
- pos = POPi - arybase;
+ pos = POPi;
sv = POPs;
tmps = SvPV(sv, curlen);
- if (pos < 0)
- pos += curlen + arybase;
- if (pos < 0 || pos > curlen) {
- if (dowarn || lvalue)
+ 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 (dowarn || lvalue)
warn("substr outside of string");
RETPUSHUNDEF;
}
else {
- if (MAXARG < 3)
- len = curlen;
- else if (len < 0) {
- len += curlen - pos;
- if (len < 0)
- len = 0;
- }
tmps += pos;
- rem = curlen - pos; /* rem=how many bytes left*/
- if (rem > len)
- rem = len;
sv_setpvn(TARG, tmps, rem);
if (lvalue) { /* it's an lvalue! */
- if (!SvGMAGICAL(sv))
- (void)SvPOK_only(sv);
+ if (!SvGMAGICAL(sv)) {
+ if (SvROK(sv)) {
+ SvPV_force(sv,na);
+ if (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) = 's';
+ LvTYPE(TARG) = 'x';
LvTARG(TARG) = sv;
LvTARGOFF(TARG) = pos;
LvTARGLEN(TARG) = rem;
@@ -1487,7 +1840,7 @@ PP(pp_vec)
}
}
- sv_setiv(TARG, (I32)retnum);
+ sv_setiv(TARG, (IV)retnum);
PUSHs(TARG);
RETURN;
}
@@ -1564,7 +1917,14 @@ PP(pp_rindex)
PP(pp_sprintf)
{
dSP; dMARK; dORIGMARK; dTARGET;
+#ifdef USE_LOCALE_NUMERIC
+ if (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;
@@ -1636,8 +1996,15 @@ PP(pp_ucfirst)
SETs(sv);
}
s = SvPV_force(sv, na);
- if (isLOWER(*s))
- *s = toUPPER(*s);
+ if (*s) {
+ if (op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toUPPER_LC(*s);
+ }
+ else
+ *s = toUPPER(*s);
+ }
RETURN;
}
@@ -1655,8 +2022,15 @@ PP(pp_lcfirst)
SETs(sv);
}
s = SvPV_force(sv, na);
- if (isUPPER(*s))
- *s = toLOWER(*s);
+ if (*s) {
+ if (op->op_private & OPpLOCALE) {
+ TAINT;
+ SvTAINTED_on(sv);
+ *s = toLOWER_LC(*s);
+ }
+ else
+ *s = toLOWER(*s);
+ }
SETs(sv);
RETURN;
@@ -1667,7 +2041,6 @@ PP(pp_uc)
dSP;
SV *sv = TOPs;
register char *s;
- register char *send;
STRLEN len;
if (!SvPADTMP(sv)) {
@@ -1676,12 +2049,21 @@ PP(pp_uc)
sv = TARG;
SETs(sv);
}
+
s = SvPV_force(sv, len);
- send = s + len;
- while (s < send) {
- if (isLOWER(*s))
- *s = toUPPER(*s);
- s++;
+ if (len) {
+ register char *send = s + len;
+
+ if (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;
}
@@ -1691,7 +2073,6 @@ PP(pp_lc)
dSP;
SV *sv = TOPs;
register char *s;
- register char *send;
STRLEN len;
if (!SvPADTMP(sv)) {
@@ -1700,12 +2081,21 @@ PP(pp_lc)
sv = TARG;
SETs(sv);
}
+
s = SvPV_force(sv, len);
- send = s + len;
- while (s < send) {
- if (isUPPER(*s))
- *s = toLOWER(*s);
- s++;
+ if (len) {
+ register char *send = s + len;
+
+ if (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;
}
@@ -1789,27 +2179,23 @@ PP(pp_each)
dSP; dTARGET;
HV *hash = (HV*)POPs;
HE *entry;
- I32 i;
- char *tmps;
+ I32 gimme = GIMME_V;
PUTBACK;
- entry = hv_iternext(hash); /* might clobber stack_sp */
+ entry = hv_iternext(hash); /* might clobber stack_sp */
SPAGAIN;
EXTEND(SP, 2);
if (entry) {
- tmps = hv_iterkey(entry, &i); /* won't clobber stack_sp */
- if (!i)
- tmps = "";
- PUSHs(sv_2mortal(newSVpv(tmps, i)));
- if (GIMME == G_ARRAY) {
+ PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
+ if (gimme == G_ARRAY) {
PUTBACK;
- sv_setsv(TARG, hv_iterval(hash, entry)); /* might clobber stack_sp */
+ sv_setsv(TARG, hv_iterval(hash, entry)); /* might hit stack_sp */
SPAGAIN;
PUSHs(TARG);
}
}
- else if (GIMME == G_SCALAR)
+ else if (gimme == G_SCALAR)
RETPUSHUNDEF;
RETURN;
@@ -1828,20 +2214,39 @@ PP(pp_keys)
PP(pp_delete)
{
dSP;
+ I32 gimme = GIMME_V;
+ I32 discard = (gimme == G_VOID) ? G_DISCARD : 0;
SV *sv;
- SV *tmpsv = POPs;
- HV *hv = (HV*)POPs;
- char *tmps;
- STRLEN len;
- if (SvTYPE(hv) != SVt_PVHV) {
- DIE("Not a HASH reference");
+ HV *hv;
+
+ if (op->op_private & OPpSLICE) {
+ dMARK; dORIGMARK;
+ hv = (HV*)POPs;
+ if (SvTYPE(hv) != SVt_PVHV)
+ DIE("Not a HASH reference");
+ while (++MARK <= SP) {
+ sv = hv_delete_ent(hv, *MARK, discard, 0);
+ *MARK = sv ? sv : &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)
+ DIE("Not a HASH reference");
+ sv = hv_delete_ent(hv, keysv, discard, 0);
+ if (!sv)
+ sv = &sv_undef;
+ if (!discard)
+ PUSHs(sv);
}
- tmps = SvPV(tmpsv, len);
- sv = hv_delete(hv, tmps, len,
- op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0);
- if (!sv)
- RETPUSHUNDEF;
- PUSHs(sv);
RETURN;
}
@@ -1850,13 +2255,11 @@ PP(pp_exists)
dSP;
SV *tmpsv = POPs;
HV *hv = (HV*)POPs;
- char *tmps;
STRLEN len;
if (SvTYPE(hv) != SVt_PVHV) {
DIE("Not a HASH reference");
}
- tmps = SvPV(tmpsv, len);
- if (hv_exists(hv, tmps, len))
+ if (hv_exists_ent(hv, tmpsv, 0))
RETPUSHYES;
RETPUSHNO;
}
@@ -1864,23 +2267,22 @@ PP(pp_exists)
PP(pp_hslice)
{
dSP; dMARK; dORIGMARK;
- register SV **svp;
+ register HE *he;
register HV *hv = (HV*)POPs;
register I32 lval = op->op_flags & OPf_MOD;
if (SvTYPE(hv) == SVt_PVHV) {
while (++MARK <= SP) {
- STRLEN keylen;
- char *key = SvPV(*MARK, keylen);
+ SV *keysv = *MARK;
- svp = hv_fetch(hv, key, keylen, lval);
+ he = hv_fetch_ent(hv, keysv, lval, 0);
if (lval) {
- if (!svp || *svp == &sv_undef)
- DIE(no_helem, key);
+ if (!he || HeVAL(he) == &sv_undef)
+ DIE(no_helem, SvPV(keysv, na));
if (op->op_private & OPpLVAL_INTRO)
- save_svref(svp);
+ save_svref(&HeVAL(he));
}
- *MARK = svp ? *svp : &sv_undef;
+ *MARK = he ? HeVAL(he) : &sv_undef;
}
}
if (GIMME != G_ARRAY) {
@@ -1954,7 +2356,7 @@ PP(pp_lslice)
if (ix >= max || !(*lelem = firstrelem[ix]))
*lelem = &sv_undef;
}
- if (!is_something_there && (SvOKp(*lelem) || SvGMAGICAL(*lelem)))
+ if (!is_something_there && (SvOK(*lelem) || SvGMAGICAL(*lelem)))
is_something_there = TRUE;
}
if (is_something_there)
@@ -1966,29 +2368,27 @@ PP(pp_lslice)
PP(pp_anonlist)
{
- dSP; dMARK;
+ dSP; dMARK; dORIGMARK;
I32 items = SP - MARK;
- SP = MARK;
- XPUSHs((SV*)sv_2mortal((SV*)av_make(items, MARK+1)));
+ SV *av = sv_2mortal((SV*)av_make(items, MARK+1));
+ SP = ORIGMARK; /* av_make() might realloc stack_sp */
+ XPUSHs(av);
RETURN;
}
PP(pp_anonhash)
{
dSP; dMARK; dORIGMARK;
- STRLEN len;
HV* hv = (HV*)sv_2mortal((SV*)newHV());
while (MARK < SP) {
SV* key = *++MARK;
- char *tmps;
SV *val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
- else
+ else if (dowarn)
warn("Odd number of elements in hash list");
- tmps = SvPV(key,len);
- (void)hv_store(hv,tmps,len,val,0);
+ (void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
XPUSHs((SV*)hv);
@@ -2012,11 +2412,13 @@ PP(pp_splice)
SP++;
if (++MARK < SP) {
- offset = SvIVx(*MARK);
+ offset = i = SvIVx(*MARK);
if (offset < 0)
offset += AvFILL(ary) + 1;
else
offset -= curcop->cop_arybase;
+ if (offset < 0)
+ DIE(no_aelem, i);
if (++MARK < SP) {
length = SvIVx(*MARK++);
if (length < 0)
@@ -2029,12 +2431,6 @@ PP(pp_splice)
offset = 0;
length = AvMAX(ary) + 1;
}
- if (offset < 0) {
- length += offset;
- offset = 0;
- if (length < 0)
- length = 0;
- }
if (offset > AvFILL(ary) + 1)
offset = AvFILL(ary) + 1;
after = AvFILL(ary) + 1 - (offset + length);
@@ -2049,6 +2445,12 @@ PP(pp_splice)
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) {
@@ -2061,15 +2463,20 @@ PP(pp_splice)
MEXTEND(MARK, length);
Copy(AvARRAY(ary)+offset, MARK, length, SV*);
if (AvREAL(ary)) {
- for (i = length, dst = MARK; i; i--)
- sv_2mortal(*dst++); /* free them eventualy */
+ EXTEND_MORTAL(length);
+ for (i = length, dst = MARK; i; i--) {
+ if (!SvIMMORTAL(*dst))
+ sv_2mortal(*dst); /* free them eventualy */
+ dst++;
+ }
}
MARK += length - 1;
}
else {
*MARK = AvARRAY(ary)[offset+length-1];
if (AvREAL(ary)) {
- sv_2mortal(*MARK);
+ if (!SvIMMORTAL(*MARK))
+ sv_2mortal(*MARK);
for (i = length - 1, dst = &AvARRAY(ary)[offset]; i > 0; i--)
SvREFCNT_dec(*dst++); /* free them now */
}
@@ -2155,8 +2562,12 @@ PP(pp_splice)
if (length) {
Copy(tmparyval, MARK, length, SV*);
if (AvREAL(ary)) {
- for (i = length, dst = MARK; i; i--)
- sv_2mortal(*dst++); /* free them eventualy */
+ EXTEND_MORTAL(length);
+ for (i = length, dst = MARK; i; i--) {
+ if (!SvIMMORTAL(*dst))
+ sv_2mortal(*dst); /* free them eventualy */
+ dst++;
+ }
}
Safefree(tmparyval);
}
@@ -2165,7 +2576,8 @@ PP(pp_splice)
else if (length--) {
*MARK = tmparyval[length];
if (AvREAL(ary)) {
- sv_2mortal(*MARK);
+ if (!SvIMMORTAL(*MARK))
+ sv_2mortal(*MARK);
while (length-- > 0)
SvREFCNT_dec(tmparyval[length]);
}
@@ -2200,7 +2612,7 @@ PP(pp_pop)
dSP;
AV *av = (AV*)POPs;
SV *sv = av_pop(av);
- if (sv != &sv_undef && AvREAL(av))
+ if (!SvIMMORTAL(sv) && AvREAL(av))
(void)sv_2mortal(sv);
PUSHs(sv);
RETURN;
@@ -2214,7 +2626,7 @@ PP(pp_shift)
EXTEND(SP, 1);
if (!sv)
RETPUSHUNDEF;
- if (sv != &sv_undef && AvREAL(av))
+ if (!SvIMMORTAL(sv) && AvREAL(av))
(void)sv_2mortal(sv);
PUSHs(sv);
RETURN;
@@ -2264,7 +2676,7 @@ PP(pp_reverse)
if (SP - MARK > 1)
do_join(TARG, &sv_no, MARK, SP);
else
- sv_setsv(TARG, *SP);
+ sv_setsv(TARG, (SP > MARK) ? *SP : GvSV(defgv));
up = SvPV_force(TARG, len);
if (len > 1) {
down = SvPVX(TARG) + len - 1;
@@ -2281,12 +2693,43 @@ PP(pp_reverse)
RETURN;
}
+static SV *
+mul128(sv, m)
+ 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 *new = newSVpv("0000000000", 10);
+
+ sv_catsv(new, sv);
+ SvREFCNT_dec(sv); /* free old sv */
+ sv = new;
+ 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. */
PP(pp_unpack)
{
dSP;
dPOPPOPssrl;
+ SV **oldsp = sp;
+ I32 gimme = GIMME_V;
SV *sv;
STRLEN llen;
STRLEN rlen;
@@ -2319,8 +2762,9 @@ PP(pp_unpack)
register U32 culong;
double cdouble;
static char* bitcount = 0;
+ int commas = 0;
- if (GIMME != G_ARRAY) { /* arrange to do first one only */
+ 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 == '%') {
@@ -2333,7 +2777,9 @@ PP(pp_unpack)
}
while (pat < patend) {
reparse:
- datumtype = *pat++;
+ datumtype = *pat++ & 0xFF;
+ if (isSPACE(datumtype))
+ continue;
if (pat >= patend)
len = 1;
else if (*pat == '*') {
@@ -2349,6 +2795,10 @@ PP(pp_unpack)
len = (datumtype != '@');
switch(datumtype) {
default:
+ croak("Invalid type in unpack: '%c'", (int)datumtype);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && dowarn)
+ warn("Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
if (len == 1 && pat[-1] != '1')
@@ -2508,12 +2958,13 @@ PP(pp_unpack)
}
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, (I32)aint);
+ sv_setiv(sv, (IV)aint);
PUSHs(sv_2mortal(sv));
}
}
@@ -2530,32 +2981,34 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
auint = *s++ & 255;
sv = NEWSV(37, 0);
- sv_setiv(sv, (I32)auint);
+ sv_setiv(sv, (IV)auint);
PUSHs(sv_2mortal(sv));
}
}
break;
case 's':
- along = (strend - s) / sizeof(I16);
+ along = (strend - s) / SIZE16;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &ashort, 1, I16);
- s += sizeof(I16);
+ COPY16(s, &ashort);
+ s += SIZE16;
culong += ashort;
}
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &ashort, 1, I16);
- s += sizeof(I16);
+ COPY16(s, &ashort);
+ s += SIZE16;
sv = NEWSV(38, 0);
- sv_setiv(sv, (I32)ashort);
+ sv_setiv(sv, (IV)ashort);
PUSHs(sv_2mortal(sv));
}
}
@@ -2563,13 +3016,13 @@ PP(pp_unpack)
case 'v':
case 'n':
case 'S':
- along = (strend - s) / sizeof(U16);
+ along = (strend - s) / SIZE16;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &aushort, 1, U16);
- s += sizeof(U16);
+ COPY16(s, &aushort);
+ s += SIZE16;
#ifdef HAS_NTOHS
if (datumtype == 'n')
aushort = ntohs(aushort);
@@ -2583,9 +3036,10 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &aushort, 1, U16);
- s += sizeof(U16);
+ COPY16(s, &aushort);
+ s += SIZE16;
sv = NEWSV(39, 0);
#ifdef HAS_NTOHS
if (datumtype == 'n')
@@ -2595,7 +3049,7 @@ PP(pp_unpack)
if (datumtype == 'v')
aushort = vtohs(aushort);
#endif
- sv_setiv(sv, (I32)aushort);
+ sv_setiv(sv, (IV)aushort);
PUSHs(sv_2mortal(sv));
}
}
@@ -2616,11 +3070,12 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
Copy(s, &aint, 1, int);
s += sizeof(int);
sv = NEWSV(40, 0);
- sv_setiv(sv, (I32)aint);
+ sv_setiv(sv, (IV)aint);
PUSHs(sv_2mortal(sv));
}
}
@@ -2641,23 +3096,24 @@ PP(pp_unpack)
}
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_setiv(sv, (I32)auint);
+ sv_setuv(sv, (UV)auint);
PUSHs(sv_2mortal(sv));
}
}
break;
case 'l':
- along = (strend - s) / sizeof(I32);
+ along = (strend - s) / SIZE32;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &along, 1, I32);
- s += sizeof(I32);
+ COPY32(s, &along);
+ s += SIZE32;
if (checksum > 32)
cdouble += (double)along;
else
@@ -2666,11 +3122,12 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &along, 1, I32);
- s += sizeof(I32);
+ COPY32(s, &along);
+ s += SIZE32;
sv = NEWSV(42, 0);
- sv_setiv(sv, (I32)along);
+ sv_setiv(sv, (IV)along);
PUSHs(sv_2mortal(sv));
}
}
@@ -2678,13 +3135,13 @@ PP(pp_unpack)
case 'V':
case 'N':
case 'L':
- along = (strend - s) / sizeof(U32);
+ along = (strend - s) / SIZE32;
if (len > along)
len = along;
if (checksum) {
while (len-- > 0) {
- Copy(s, &aulong, 1, U32);
- s += sizeof(U32);
+ COPY32(s, &aulong);
+ s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
aulong = ntohl(aulong);
@@ -2701,10 +3158,10 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
- Copy(s, &aulong, 1, U32);
- s += sizeof(U32);
- sv = NEWSV(43, 0);
+ COPY32(s, &aulong);
+ s += SIZE32;
#ifdef HAS_NTOHL
if (datumtype == 'N')
aulong = ntohl(aulong);
@@ -2713,7 +3170,8 @@ PP(pp_unpack)
if (datumtype == 'V')
aulong = vtohl(aulong);
#endif
- sv_setnv(sv, (double)aulong);
+ sv = NEWSV(43, 0);
+ sv_setuv(sv, (UV)aulong);
PUSHs(sv_2mortal(sv));
}
}
@@ -2723,6 +3181,7 @@ PP(pp_unpack)
if (len > along)
len = along;
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
if (sizeof(char*) > strend - s)
break;
@@ -2736,6 +3195,47 @@ PP(pp_unpack)
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, 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)
@@ -2752,6 +3252,7 @@ PP(pp_unpack)
#ifdef HAS_QUAD
case 'q':
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
if (s + sizeof(Quad_t) > strend)
aquad = 0;
@@ -2760,12 +3261,16 @@ PP(pp_unpack)
s += sizeof(Quad_t);
}
sv = NEWSV(42, 0);
- sv_setiv(sv, (IV)aquad);
+ 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':
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
if (s + sizeof(unsigned Quad_t) > strend)
auquad = 0;
@@ -2774,7 +3279,10 @@ PP(pp_unpack)
s += sizeof(unsigned Quad_t);
}
sv = NEWSV(43, 0);
- sv_setiv(sv, (IV)auquad);
+ if (aquad <= UV_MAX)
+ sv_setuv(sv, (UV)auquad);
+ else
+ sv_setnv(sv, (double)auquad);
PUSHs(sv_2mortal(sv));
}
break;
@@ -2794,6 +3302,7 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
Copy(s, &afloat, 1, float);
s += sizeof(float);
@@ -2817,6 +3326,7 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
Copy(s, &adouble, 1, double);
s += sizeof(double);
@@ -2829,6 +3339,8 @@ PP(pp_unpack)
case 'u':
along = (strend - s) * 3 / 4;
sv = NEWSV(42, along);
+ if (along)
+ SvPOK_on(sv);
while (s < strend && *s > ' ' && *s < 'a') {
I32 a, b, c, d;
char hunk[4];
@@ -2891,15 +3403,17 @@ PP(pp_unpack)
}
else {
if (checksum < 32) {
- along = (1 << checksum) - 1;
- culong &= (U32)along;
+ aulong = (1 << checksum) - 1;
+ culong &= aulong;
}
- sv_setnv(sv, (double)culong);
+ sv_setuv(sv, (UV)culong);
}
XPUSHs(sv_2mortal(sv));
checksum = 0;
}
}
+ if (sp == oldsp && gimme == G_SCALAR)
+ PUSHs(&sv_undef);
RETURN;
}
@@ -2930,6 +3444,85 @@ register I32 len;
sv_catpvn(sv, "\n", 1);
}
+static SV *
+is_an_int(s, l)
+ char *s;
+ STRLEN l;
+{
+ SV *result = newSVpv("", l);
+ char *result_c = SvPV(result, 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(pnum, done)
+ SV *pnum; /* must be '\0' terminated */
+ bool *done;
+{
+ STRLEN len;
+ char *s = SvPV(pnum, len);
+ int m = 0;
+ int r = 0;
+ char *t = s;
+
+ *done = 1;
+ while (*t) {
+ int i;
+
+ i = m * 10 + (*t - '0');
+ m = i & 0x7F;
+ r = (i >> 7); /* r < 10 */
+ if (r) {
+ *done = 0;
+ }
+ *(t++) = '0' + r;
+ }
+ *(t++) = '\0';
+ SvCUR_set(pnum, (STRLEN) (t - s));
+ return (m);
+}
+
+
PP(pp_pack)
{
dSP; dMARK; dORIGMARK; dTARGET;
@@ -2959,13 +3552,16 @@ PP(pp_pack)
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++ : &sv_no)
- datumtype = *pat++;
+ datumtype = *pat++ & 0xFF;
+ if (isSPACE(datumtype))
+ continue;
if (*pat == '*') {
len = strchr("@Xxu", datumtype) ? 0 : items;
pat++;
@@ -2979,6 +3575,10 @@ PP(pp_pack)
len = 1;
switch(datumtype) {
default:
+ croak("Invalid type in pack: '%c'", (int)datumtype);
+ case ',': /* grandfather in commas but with a warning */
+ if (commas++ == 0 && dowarn)
+ warn("Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
DIE("%% may only be used in unpack");
@@ -3181,7 +3781,7 @@ PP(pp_pack)
#ifdef HAS_HTONS
ashort = htons(ashort);
#endif
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ CAT16(cat, &ashort);
}
break;
case 'v':
@@ -3191,7 +3791,7 @@ PP(pp_pack)
#ifdef HAS_HTOVS
ashort = htovs(ashort);
#endif
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ CAT16(cat, &ashort);
}
break;
case 'S':
@@ -3199,16 +3799,86 @@ PP(pp_pack)
while (len-- > 0) {
fromstr = NEXTFROM;
ashort = (I16)SvIV(fromstr);
- sv_catpvn(cat, (char*)&ashort, sizeof(I16));
+ CAT16(cat, &ashort);
}
break;
case 'I':
while (len-- > 0) {
fromstr = NEXTFROM;
- auint = U_I(SvNV(fromstr));
+ 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;
@@ -3219,35 +3889,35 @@ PP(pp_pack)
case 'N':
while (len-- > 0) {
fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
+ aulong = SvUV(fromstr);
#ifdef HAS_HTONL
aulong = htonl(aulong);
#endif
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ CAT32(cat, &aulong);
}
break;
case 'V':
while (len-- > 0) {
fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
+ aulong = SvUV(fromstr);
#ifdef HAS_HTOVL
aulong = htovl(aulong);
#endif
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ CAT32(cat, &aulong);
}
break;
case 'L':
while (len-- > 0) {
fromstr = NEXTFROM;
- aulong = U_L(SvNV(fromstr));
- sv_catpvn(cat, (char*)&aulong, sizeof(U32));
+ aulong = SvUV(fromstr);
+ CAT32(cat, &aulong);
}
break;
case 'l':
while (len-- > 0) {
fromstr = NEXTFROM;
along = SvIV(fromstr);
- sv_catpvn(cat, (char*)&along, sizeof(I32));
+ CAT32(cat, &along);
}
break;
#ifdef HAS_QUAD
@@ -3272,7 +3942,21 @@ PP(pp_pack)
case 'p':
while (len-- > 0) {
fromstr = NEXTFROM;
- aptr = SvPV_force(fromstr, na); /* XXX Error if TEMP? */
+ if (fromstr == &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 (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
+ warn("Attempt to pack pointer to temporary value");
+ if (SvPOK(fromstr) || SvNIOK(fromstr))
+ aptr = SvPV(fromstr,na);
+ else
+ aptr = SvPV_force(fromstr,na);
+ }
sv_catpvn(cat, (char*)&aptr, sizeof(char*));
}
break;
@@ -3314,7 +3998,8 @@ PP(pp_split)
STRLEN len;
register char *s = SvPV(sv, len);
char *strend = s + len;
- register PMOP *pm = (PMOP*)POPs;
+ register PMOP *pm;
+ register REGEXP *rx;
register SV *dstr;
register char *m;
I32 iters = 0;
@@ -3324,13 +4009,22 @@ PP(pp_split)
I32 origlimit = limit;
I32 realarray = 0;
I32 base;
- AV *oldstack = stack;
- register REGEXP *rx = pm->op_pmregexp;
- I32 gimme = GIMME;
+ AV *oldstack = curstack;
+ I32 gimme = GIMME_V;
I32 oldsave = savestack_ix;
+#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)
@@ -3347,13 +4041,19 @@ PP(pp_split)
av_extend(ary,0);
av_clear(ary);
/* temporarily switch stacks */
- SWITCHSTACK(stack, ary);
+ SWITCHSTACK(curstack, ary);
}
base = SP - stack_base;
orig = s;
if (pm->op_pmflags & PMf_SKIPWHITE) {
- while (isSPACE(*s))
- s++;
+ 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(multiline);
@@ -3364,17 +4064,25 @@ PP(pp_split)
limit = maxiters + 2;
if (pm->op_pmflags & PMf_WHITE) {
while (--limit) {
- /*SUPPRESS 530*/
- for (m = s; m < strend && !isSPACE(*m); m++) ;
+ 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 (!realarray)
sv_2mortal(dstr);
XPUSHs(dstr);
- /*SUPPRESS 530*/
- for (s = m + 1; s < strend && isSPACE(*s); s++) ;
+
+ s = m + 1;
+ while (s < strend &&
+ ((pm->op_pmflags & PMf_LOCALE)
+ ? isSPACE_LC(*s) : isSPACE(*s)))
+ ++s;
}
}
else if (strEQ("^", rx->precomp)) {
@@ -3392,23 +4100,13 @@ PP(pp_split)
s = m;
}
}
- else if (pm->op_pmshort) {
+ else if (pm->op_pmshort && !rx->nparens) {
i = SvCUR(pm->op_pmshort);
if (i == 1) {
- I32 fold = (pm->op_pmflags & PMf_FOLD);
i = *SvPVX(pm->op_pmshort);
- if (fold && isUPPER(i))
- i = toLOWER(i);
while (--limit) {
- if (fold) {
- for ( m = s;
- m < strend && *m != i &&
- (!isUPPER(*m) || toLOWER(*m) != i);
- m++) /*SUPPRESS 530*/
- ;
- }
- else /*SUPPRESS 530*/
- for (m = s; m < strend && *m != i; m++) ;
+ /*SUPPRESS 530*/
+ for (m = s; m < strend && *m != i; m++) ;
if (m >= strend)
break;
dstr = NEWSV(30, m-s);
@@ -3438,7 +4136,9 @@ PP(pp_split)
else {
maxiters += (strend - s) * rx->nparens;
while (s < strend && --limit &&
- pregexec(rx, s, strend, orig, 1, Nullsv, TRUE) ) {
+ pregexec(rx, s, strend, orig, 1, Nullsv, TRUE))
+ {
+ TAINT_IF(rx->exec_tainted);
if (rx->subbase
&& rx->subbase != orig) {
m = s;
@@ -3486,11 +4186,16 @@ PP(pp_split)
iters++;
}
else if (!origlimit) {
- while (iters > 0 && SvCUR(TOPs) == 0)
+ while (iters > 0 && (!TOPs || !SvANY(TOPs) || SvCUR(TOPs) == 0))
iters--, SP--;
}
if (realarray) {
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*);
diff --git a/gnu/usr.bin/perl/pp.h b/gnu/usr.bin/perl/pp.h
index 44a3ebeb723..3c3bdcf9c07 100644
--- a/gnu/usr.bin/perl/pp.h
+++ b/gnu/usr.bin/perl/pp.h
@@ -1,6 +1,6 @@
/* pp.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -55,24 +55,26 @@
#define POPp (SvPVx(POPs, 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, 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 (stack_max - p < (n)) { \
- sp = stack_grow(sp,p, (int) (n)); \
+#define EXTEND(p,n) STMT_START { if (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 (stack_max - p < (n)) { \
- int markoff = mark - stack_base; \
- sp = stack_grow(sp,p,(int) (n)); \
- mark = stack_base + markoff; \
+#define MEXTEND(p,n) STMT_START {if (stack_max - p < (n)) { \
+ int markoff = mark - stack_base; \
+ sp = stack_grow(sp,p,(int) (n)); \
+ mark = stack_base + markoff; \
} } STMT_END
#define PUSHs(s) (*++sp = (s))
@@ -80,22 +82,21 @@
#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
-
-#ifdef OVERLOAD
-#define SETsv(sv) STMT_START { sv_setsv(TARG, (sv)); SETTARG; } STMT_END
-#endif /* OVERLOAD */
+#define SETu(u) STMT_START { sv_setuv(TARG, (UV)(u)); SETTARG; } STMT_END
#define dTOPss SV *sv = TOPs
#define dPOPss SV *sv = POPs
@@ -103,14 +104,35 @@
#define dPOPnv double value = POPn
#define dTOPiv IV value = TOPi
#define dPOPiv IV value = POPi
-
-#define dPOPPOPssrl SV *right = POPs; SV *left = POPs
-#define dPOPPOPnnrl double right = POPn; double left = POPn
-#define dPOPPOPiirl IV right = POPi; IV left = POPi
-
-#define dPOPTOPssrl SV *right = POPs; SV *left = TOPs
-#define dPOPTOPnnrl double right = POPn; double left = TOPn
-#define dPOPTOPiirl IV right = POPi; IV left = TOPi
+#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) || !(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(&sv_yes))
#define RETPUSHNO RETURNX(PUSHs(&sv_no))
@@ -127,7 +149,13 @@
stack_base = AvARRAY(t); \
stack_max = stack_base + AvMAX(t); \
sp = stack_sp = stack_base + AvFILL(t); \
- stack = t;
+ curstack = t;
+
+#define EXTEND_MORTAL(n) \
+ STMT_START { \
+ if (tmps_ix + (n) >= tmps_max) \
+ Renew(tmps_stack, tmps_max = tmps_ix + (n) + 1, SV*); \
+ } STMT_END
#ifdef OVERLOAD
@@ -169,10 +197,13 @@
} \
} STMT_END
-#define tryAMAGICun(meth) tryAMAGICunW(meth,SETsv)
+#define tryAMAGICun tryAMAGICunSET
#define tryAMAGICunSET(meth) tryAMAGICunW(meth,SETs)
#define opASSIGN (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 */
diff --git a/gnu/usr.bin/perl/pp_ctl.c b/gnu/usr.bin/perl/pp_ctl.c
index e57e88a1679..516e41e5b1c 100644
--- a/gnu/usr.bin/perl/pp_ctl.c
+++ b/gnu/usr.bin/perl/pp_ctl.c
@@ -1,6 +1,6 @@
/* pp_ctl.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -23,16 +23,20 @@
#define WORD_ALIGN sizeof(U16)
#endif
+#define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
+
+static OP *docatch _((OP *o));
static OP *doeval _((int gimme));
-static OP *dofindlabel _((OP *op, char *label, OP **opstack));
+static OP *dofindlabel _((OP *op, 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 void save_lines _((AV *array, SV *sv));
-static int sortcmp _((const void *, const void *));
static int sortcv _((const void *, const void *));
+static int sortcmp _((const void *, const void *));
+static int sortcmp_locale _((const void *, const void *));
static I32 sortcxix;
@@ -46,10 +50,14 @@ PP(pp_wantarray)
if (cxix < 0)
RETPUSHUNDEF;
- if (cxstack[cxix].blk_gimme == G_ARRAY)
+ switch (cxstack[cxix].blk_gimme) {
+ case G_ARRAY:
RETPUSHYES;
- else
+ case G_SCALAR:
RETPUSHNO;
+ default:
+ RETPUSHUNDEF;
+ }
}
PP(pp_regcmaybe)
@@ -86,7 +94,7 @@ PP(pp_regcomp) {
pm->op_pmflags |= PMf_WHITE;
if (pm->op_pmflags & PMf_KEEP) {
- pm->op_pmflags &= ~PMf_RUNTIME; /* no point compiling again */
+ pm->op_private &= ~OPpRUNTIME; /* no point compiling again */
hoistmust(pm);
cLOGOP->op_first->op_next = op->op_next;
}
@@ -104,14 +112,15 @@ PP(pp_substcont)
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)
+ cx->sb_rxtainted = SvTAINTED(TOPs);
sv_catsv(dstr, POPs);
- if (rx->subbase)
- Safefree(rx->subbase);
- rx->subbase = cx->sb_subbase;
/* Are we done */
if (cx->sb_once || !pregexec(rx, s, cx->sb_strend, orig,
@@ -120,6 +129,8 @@ PP(pp_substcont)
SV *targ = cx->sb_targ;
sv_catpvn(dstr, s, cx->sb_strend - s);
+ TAINT_IF(cx->sb_rxtainted || rx->exec_tainted);
+
(void)SvOOK_off(targ);
Safefree(SvPVX(targ));
SvPVX(targ) = SvPVX(dstr);
@@ -127,9 +138,10 @@ PP(pp_substcont)
SvLEN_set(targ, SvLEN(dstr));
SvPVX(dstr) = 0;
sv_free(dstr);
-
(void)SvPOK_only(targ);
SvSETMAGIC(targ);
+ SvTAINT(targ);
+
PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
LEAVE_SCOPE(cx->sb_oldsave);
POPSUBST(cx);
@@ -146,12 +158,76 @@ PP(pp_substcont)
cx->sb_m = m = rx->startp[0];
sv_catpvn(dstr, s, m-s);
cx->sb_s = rx->endp[0];
- cx->sb_subbase = rx->subbase;
-
- rx->subbase = Nullch; /* so recursion works */
+ cx->sb_rxtainted |= rx->exec_tainted;
+ rxres_save(&cx->sb_rxres, rx);
RETURNOP(pm->op_pmreplstart);
}
+void
+rxres_save(rsp, rx)
+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(rsp, rx)
+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(rsp)
+void **rsp;
+{
+ UV *p = (UV*)*rsp;
+
+ if (p) {
+ Safefree((char*)(*p));
+ Safefree(p);
+ *rsp = Null(void*);
+ }
+}
+
PP(pp_formline)
{
dSP; dMARK; dORIGMARK;
@@ -174,7 +250,7 @@ PP(pp_formline)
bool gotsome;
STRLEN len;
- if (!SvCOMPILED(form)) {
+ if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
SvREADONLY_off(form);
doparseform(form);
}
@@ -212,9 +288,9 @@ PP(pp_formline)
case FF_END: name = "END"; break;
}
if (arg >= 0)
- fprintf(stderr, "%-16s%ld\n", name, (long) arg);
+ PerlIO_printf(PerlIO_stderr(), "%-16s%ld\n", name, (long) arg);
else
- fprintf(stderr, "%-16s\n", name);
+ PerlIO_printf(PerlIO_stderr(), "%-16s\n", name);
} )
switch (*fpc++) {
case FF_LINEMARK:
@@ -376,6 +452,8 @@ PP(pp_formline)
}
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 {
@@ -450,7 +528,7 @@ PP(pp_grepstart)
if (stack_base + *markstack_ptr == sp) {
(void)POPMARK;
- if (GIMME != G_ARRAY)
+ if (GIMME_V == G_SCALAR)
XPUSHs(&sv_no);
RETURNOP(op->op_next->op_next);
}
@@ -513,6 +591,7 @@ PP(pp_mapwhile)
/* All done yet? */
if (markstack_ptr[-1] > *markstack_ptr) {
I32 items;
+ I32 gimme = GIMME_V;
(void)POPMARK; /* pop top */
LEAVE; /* exit outer scope */
@@ -520,12 +599,12 @@ PP(pp_mapwhile)
items = --*markstack_ptr - markstack_ptr[-1];
(void)POPMARK; /* pop dst */
SP = stack_base + POPMARK; /* pop original mark */
- if (GIMME != G_ARRAY) {
+ if (gimme == G_SCALAR) {
dTARGET;
XPUSHi(items);
- RETURN;
}
- SP += items;
+ else if (gimme == G_ARRAY)
+ SP += items;
RETURN;
}
else {
@@ -574,7 +653,7 @@ PP(pp_sort)
if (!(cv && CvROOT(cv))) {
if (gv) {
SV *tmpstr = sv_newmortal();
- gv_efullname(tmpstr, gv);
+ gv_efullname3(tmpstr, gv, Nullch);
if (cv && CvXSUB(cv))
DIE("Xsub \"%s\" called in sort", SvPVX(tmpstr));
DIE("Undefined sort subroutine \"%s\" called",
@@ -590,7 +669,7 @@ PP(pp_sort)
sortcop = CvSTART(cv);
SAVESPTR(CvROOT(cv)->op_ppaddr);
CvROOT(cv)->op_ppaddr = ppaddr[OP_NULL];
-
+
SAVESPTR(curpad);
curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
}
@@ -604,10 +683,9 @@ PP(pp_sort)
while (MARK < SP) { /* This may or may not shift down one here. */
/*SUPPRESS 560*/
if (*up = *++MARK) { /* Weed out nulls. */
- if (!SvPOK(*up))
+ SvTEMP_off(*up);
+ if (!sortcop && !SvPOK(*up))
(void)sv_2pv(*up, &na);
- else
- SvTEMP_off(*up);
up++;
}
}
@@ -617,17 +695,19 @@ PP(pp_sort)
AV *oldstack;
CONTEXT *cx;
SV** newsp;
+ bool oldcatch = CATCH_GET;
SAVETMPS;
SAVESPTR(op);
- oldstack = stack;
+ oldstack = curstack;
if (!sortstack) {
sortstack = newAV();
AvREAL_off(sortstack);
av_extend(sortstack, 32);
}
- SWITCHSTACK(stack, sortstack);
+ CATCH_SET(TRUE);
+ SWITCHSTACK(curstack, sortstack);
if (sortstash != stash) {
firstgv = gv_fetchpv("a", TRUE, SVt_PV);
secondgv = gv_fetchpv("b", TRUE, SVt_PV);
@@ -636,20 +716,31 @@ PP(pp_sort)
SAVESPTR(GvSV(firstgv));
SAVESPTR(GvSV(secondgv));
- PUSHBLOCK(cx, CXt_LOOP, stack_base);
+
+ PUSHBLOCK(cx, CXt_NULL, stack_base);
+ if (!(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 */
+ }
sortcxix = cxstack_ix;
qsort((char*)(myorigmark+1), max, sizeof(SV*), sortcv);
POPBLOCK(cx,curpm);
SWITCHSTACK(sortstack, oldstack);
+ CATCH_SET(oldcatch);
}
LEAVE;
}
else {
if (max > 1) {
MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */
- qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp);
+ qsort((char*)(ORIGMARK+1), max, sizeof(SV*),
+ (op->op_private & OPpLOCALE) ? sortcmp_locale : sortcmp);
}
}
stack_sp = ORIGMARK + max;
@@ -682,6 +773,7 @@ PP(pp_flip)
sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
if (op->op_flags & OPf_SPECIAL) {
sv_setiv(targ, 1);
+ SETs(targ);
RETURN;
}
else {
@@ -707,14 +799,16 @@ PP(pp_flop)
I32 max;
if (SvNIOKp(left) || !SvPOKp(left) ||
- (looks_like_number(left) && *SvPVX(left) != '0') ) {
+ (looks_like_number(left) && *SvPVX(left) != '0') )
+ {
i = SvIV(left);
max = SvIV(right);
- if (max > i)
+ if (max >= i) {
+ EXTEND_MORTAL(max - i + 1);
EXTEND(SP, max - i + 1);
+ }
while (i <= max) {
- sv = sv_mortalcopy(&sv_no);
- sv_setiv(sv,i++);
+ sv = sv_2mortal(newSViv(i++));
PUSHs(sv);
}
}
@@ -774,14 +868,18 @@ char *label;
if (dowarn)
warn("Exiting eval via %s", op_name[op->op_type]);
break;
+ case CXt_NULL:
+ if (dowarn)
+ warn("Exiting pseudo-block via %s", op_name[op->op_type]);
+ return -1;
case CXt_LOOP:
if (!cx->blk_loop.label ||
strNE(label, cx->blk_loop.label) ) {
- DEBUG_l(deb("(Skipping label #%d %s)\n",
- i, cx->blk_loop.label));
+ DEBUG_l(deb("(Skipping label #%ld %s)\n",
+ (long)i, cx->blk_loop.label));
continue;
}
- DEBUG_l( deb("(Found label #%d %s)\n", i, label));
+ DEBUG_l( deb("(Found label #%ld %s)\n", (long)i, label));
return i;
}
}
@@ -791,16 +889,29 @@ char *label;
I32
dowantarray()
{
+ I32 gimme = block_gimme();
+ return (gimme == G_VOID) ? G_SCALAR : gimme;
+}
+
+I32
+block_gimme()
+{
I32 cxix;
cxix = dopoptosub(cxstack_ix);
if (cxix < 0)
- return G_SCALAR;
+ return G_VOID;
- if (cxstack[cxix].blk_gimme == G_ARRAY)
- return G_ARRAY;
- else
+ 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);
+ }
}
static I32
@@ -816,7 +927,7 @@ I32 startingblock;
continue;
case CXt_EVAL:
case CXt_SUB:
- DEBUG_l( deb("(Found sub #%d)\n", i));
+ DEBUG_l( deb("(Found sub #%ld)\n", (long)i));
return i;
}
}
@@ -835,7 +946,7 @@ I32 startingblock;
default:
continue;
case CXt_EVAL:
- DEBUG_l( deb("(Found eval #%d)\n", i));
+ DEBUG_l( deb("(Found eval #%ld)\n", (long)i));
return i;
}
}
@@ -853,7 +964,7 @@ I32 startingblock;
switch (cx->cx_type) {
case CXt_SUBST:
if (dowarn)
- warn("Exiting substitition via %s", op_name[op->op_type]);
+ warn("Exiting substitution via %s", op_name[op->op_type]);
break;
case CXt_SUB:
if (dowarn)
@@ -863,8 +974,12 @@ I32 startingblock;
if (dowarn)
warn("Exiting eval via %s", op_name[op->op_type]);
break;
+ case CXt_NULL:
+ if (dowarn)
+ warn("Exiting pseudo-block via %s", op_name[op->op_type]);
+ return -1;
case CXt_LOOP:
- DEBUG_l( deb("(Found loop #%d)\n", i));
+ DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
return i;
}
}
@@ -880,11 +995,14 @@ I32 cxix;
I32 optype;
while (cxstack_ix > cxix) {
- cx = &cxstack[cxstack_ix--];
- DEBUG_l(fprintf(stderr, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
- block_type[cx->cx_type]));
+ cx = &cxstack[cxstack_ix];
+ DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
+ (long) cxstack_ix+1, 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;
@@ -894,53 +1012,13 @@ I32 cxix;
case CXt_LOOP:
POPLOOP(cx);
break;
- case CXt_SUBST:
+ case CXt_NULL:
break;
}
+ cxstack_ix--;
}
}
-#ifdef I_STDARG
-OP *
-die(char* pat, ...)
-#else
-/*VARARGS0*/
-OP *
-die(pat, va_alist)
- char *pat;
- va_dcl
-#endif
-{
- va_list args;
- char *message;
- int oldrunlevel = runlevel;
- int was_in_eval = in_eval;
- HV *stash;
- GV *gv;
- CV *cv;
-
-#ifdef I_STDARG
- va_start(args, pat);
-#else
- va_start(args);
-#endif
- message = mess(pat, &args);
- va_end(args);
- if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
- dSP;
-
- PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
- PUTBACK;
- perl_call_sv((SV*)cv, G_DISCARD);
- }
- restartop = die_where(message);
- if ((!restartop && was_in_eval) || oldrunlevel > 1)
- Siglongjmp(top_env, 3);
- return restartop;
-}
-
OP *
die_where(message)
char *message;
@@ -980,7 +1058,7 @@ char *message;
POPBLOCK(cx,curpm);
if (cx->cx_type != CXt_EVAL) {
- fprintf(stderr, "panic: die %s", message);
+ PerlIO_printf(PerlIO_stderr(), "panic: die %s", message);
my_exit(1);
}
POPEVAL(cx);
@@ -991,28 +1069,17 @@ char *message;
LEAVE;
- if (optype == OP_REQUIRE)
- DIE("%s", SvPVx(GvSV(errgv), na));
+ if (optype == OP_REQUIRE) {
+ char* msg = SvPVx(GvSV(errgv), na);
+ DIE("%s", *msg ? msg : "Compilation failed in require");
+ }
return pop_return();
}
}
- fputs(message, stderr);
- (void)Fflush(stderr);
- if (e_tmpname) {
- if (e_fp) {
- fclose(e_fp);
- e_fp = Nullfp;
- }
- (void)UNLINK(e_tmpname);
- Safefree(e_tmpname);
- e_tmpname = Nullch;
- }
- statusvalue = SHIFTSTATUS(statusvalue);
-#ifdef VMS
- my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
-#else
- my_exit((I32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
-#endif
+ PerlIO_printf(PerlIO_stderr(), "%s",message);
+ PerlIO_flush(PerlIO_stderr());
+ my_failure_exit();
+ /* NOTREACHED */
return 0;
}
@@ -1064,6 +1131,7 @@ PP(pp_caller)
register I32 cxix = dopoptosub(cxstack_ix);
register CONTEXT *cx;
I32 dbcxix;
+ I32 gimme;
SV *sv;
I32 count = 0;
@@ -1107,7 +1175,7 @@ PP(pp_caller)
RETURN;
if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
sv = NEWSV(49, 0);
- gv_efullname(sv, CvGV(cxstack[cxix].blk_sub.cv));
+ gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
PUSHs(sv_2mortal(sv));
PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
}
@@ -1115,7 +1183,11 @@ PP(pp_caller)
PUSHs(sv_2mortal(newSVpv("(eval)",0)));
PUSHs(sv_2mortal(newSViv(0)));
}
- PUSHs(sv_2mortal(newSViv((I32)cx->blk_gimme)));
+ gimme = (I32)cx->blk_gimme;
+ if (gimme == G_VOID)
+ PUSHs(&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);
@@ -1155,8 +1227,8 @@ sortcv(a, b)
const void *a;
const void *b;
{
- SV **str1 = (SV **) a;
- SV **str2 = (SV **) b;
+ SV * const *str1 = (SV * const *)a;
+ SV * const *str2 = (SV * const *)b;
I32 oldsaveix = savestack_ix;
I32 oldscopeix = scopestack_ix;
I32 result;
@@ -1182,33 +1254,15 @@ sortcmp(a, b)
const void *a;
const void *b;
{
- register SV *str1 = *(SV **) a;
- register SV *str2 = *(SV **) b;
- I32 retval;
-
- if (!SvPOKp(str1)) {
- if (!SvPOKp(str2))
- return 0;
- else
- return -1;
- }
- if (!SvPOKp(str2))
- return 1;
+ return sv_cmp(*(SV * const *)a, *(SV * const *)b);
+}
- if (SvCUR(str1) < SvCUR(str2)) {
- /*SUPPRESS 560*/
- if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1)))
- return retval;
- else
- return -1;
- }
- /*SUPPRESS 560*/
- else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2)))
- return retval;
- else if (SvCUR(str1) == SvCUR(str2))
- return 0;
- else
- return 1;
+static int
+sortcmp_locale(a, b)
+const void *a;
+const void *b;
+{
+ return sv_cmp_locale(*(SV * const *)a, *(SV * const *)b);
}
PP(pp_reset)
@@ -1258,7 +1312,7 @@ PP(pp_dbstate)
SAVETMPS;
SAVEI32(debug);
- SAVESPTR(stack_sp);
+ SAVESTACK_POS();
debug = 0;
hasargs = 0;
sp = stack_sp;
@@ -1285,7 +1339,7 @@ PP(pp_enteriter)
{
dSP; dMARK;
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
SV **svp;
ENTER;
@@ -1302,14 +1356,11 @@ PP(pp_enteriter)
PUSHBLOCK(cx, CXt_LOOP, SP);
PUSHLOOP(cx, svp, MARK);
- if (op->op_flags & OPf_STACKED) {
- AV* av = (AV*)POPs;
- cx->blk_loop.iterary = av;
- cx->blk_loop.iterix = -1;
- }
+ if (op->op_flags & OPf_STACKED)
+ cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
else {
- cx->blk_loop.iterary = stack;
- AvFILL(stack) = sp - stack_base;
+ cx->blk_loop.iterary = curstack;
+ AvFILL(curstack) = sp - stack_base;
cx->blk_loop.iterix = MARK - stack_base;
}
@@ -1320,7 +1371,7 @@ PP(pp_enterloop)
{
dSP;
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
@@ -1336,6 +1387,7 @@ PP(pp_leaveloop)
{
dSP;
register CONTEXT *cx;
+ struct block_loop cxloop;
I32 gimme;
SV **newsp;
PMOP *newpm;
@@ -1343,27 +1395,33 @@ PP(pp_leaveloop)
POPBLOCK(cx,newpm);
mark = newsp;
- POPLOOP(cx);
- if (gimme == G_SCALAR) {
- if (op->op_private & OPpLEAVE_VOID)
- ;
- else {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
- else
- *++newsp = &sv_undef;
- }
+ 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 = &sv_undef;
}
else {
- while (mark < SP)
+ while (mark < SP) {
*++newsp = sv_mortalcopy(*++mark);
+ TAINT_NOT; /* Each item is independent */
+ }
}
- curpm = newpm; /* Don't pop $1 et al till now */
- sp = newsp;
+ SP = newsp;
+ PUTBACK;
+
+ POPLOOP2(); /* Stack values are safe: release loop vars ... */
+ curpm = newpm; /* ... and pop $1 et al */
+
LEAVE;
LEAVE;
- RETURN;
+ return NORMAL;
}
PP(pp_return)
@@ -1371,16 +1429,18 @@ PP(pp_return)
dSP; dMARK;
I32 cxix;
register CONTEXT *cx;
+ struct block_sub cxsub;
+ bool popsub2 = FALSE;
I32 gimme;
SV **newsp;
PMOP *newpm;
I32 optype = 0;
- if (stack == sortstack) {
- if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) {
+ if (curstack == sortstack) {
+ if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) <= sortcxix) {
if (cxstack_ix > sortcxix)
dounwind(sortcxix);
- AvARRAY(stack)[1] = *SP;
+ AvARRAY(curstack)[1] = *SP;
stack_sp = stack_base + 1;
return 0;
}
@@ -1395,13 +1455,15 @@ PP(pp_return)
POPBLOCK(cx,newpm);
switch (cx->cx_type) {
case CXt_SUB:
- POPSUB(cx);
+ 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(incgv), name, strlen(name), G_DISCARD);
DIE("%s did not return a true value", name);
@@ -1409,22 +1471,31 @@ PP(pp_return)
break;
default:
DIE("panic: return");
- break;
}
+ TAINT_NOT;
if (gimme == G_SCALAR) {
if (MARK < SP)
- *++newsp = sv_mortalcopy(*SP);
+ *++newsp = (popsub2 && SvTEMP(*SP))
+ ? *SP : sv_mortalcopy(*SP);
else
*++newsp = &sv_undef;
}
- else {
- while (MARK < SP)
- *++newsp = sv_mortalcopy(*++MARK);
+ else if (gimme == G_ARRAY) {
+ while (++MARK <= SP) {
+ *++newsp = (popsub2 && SvTEMP(*MARK))
+ ? *MARK : sv_mortalcopy(*MARK);
+ TAINT_NOT; /* Each item is independent */
+ }
}
- curpm = newpm; /* Don't pop $1 et al till now */
stack_sp = newsp;
+ /* Stack values are safe: */
+ if (popsub2) {
+ POPSUB2(); /* release CV and @_ ... */
+ }
+ curpm = newpm; /* ... and pop $1 et al */
+
LEAVE;
return pop_return();
}
@@ -1434,6 +1505,9 @@ PP(pp_last)
dSP;
I32 cxix;
register CONTEXT *cx;
+ struct block_loop cxloop;
+ struct block_sub cxsub;
+ I32 pop2 = 0;
I32 gimme;
I32 optype;
OP *nextop;
@@ -1457,38 +1531,55 @@ PP(pp_last)
POPBLOCK(cx,newpm);
switch (cx->cx_type) {
case CXt_LOOP:
- POPLOOP(cx);
- nextop = cx->blk_loop.last_op->op_next;
- LEAVE;
+ POPLOOP1(cx); /* Delay POPLOOP2 until stack values are safe */
+ pop2 = CXt_LOOP;
+ nextop = cxloop.last_op->op_next;
break;
- case CXt_EVAL:
- POPEVAL(cx);
+ case CXt_SUB:
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+ pop2 = CXt_SUB;
nextop = pop_return();
break;
- case CXt_SUB:
- POPSUB(cx);
+ case CXt_EVAL:
+ POPEVAL(cx);
nextop = pop_return();
break;
default:
DIE("panic: last");
- break;
}
+ TAINT_NOT;
if (gimme == G_SCALAR) {
- if (mark < SP)
- *++newsp = sv_mortalcopy(*SP);
+ if (MARK < SP)
+ *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
+ ? *SP : sv_mortalcopy(*SP);
else
*++newsp = &sv_undef;
}
- else {
- while (mark < SP)
- *++newsp = sv_mortalcopy(*++mark);
+ else if (gimme == G_ARRAY) {
+ while (++MARK <= SP) {
+ *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
+ ? *MARK : sv_mortalcopy(*MARK);
+ TAINT_NOT; /* Each item is independent */
+ }
}
- curpm = newpm; /* Don't pop $1 et al till now */
- sp = newsp;
+ 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;
+ }
+ curpm = newpm; /* ... and pop $1 et al */
LEAVE;
- RETURNOP(nextop);
+ return nextop;
}
PP(pp_next)
@@ -1544,19 +1635,27 @@ PP(pp_redo)
static OP* lastgotoprobe;
static OP *
-dofindlabel(op,label,opstack)
+dofindlabel(op,label,opstack,oplimit)
OP *op;
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 (op->op_type == OP_LEAVE ||
op->op_type == OP_SCOPE ||
op->op_type == OP_LEAVELOOP ||
op->op_type == OP_LEAVETRY)
- *ops++ = cUNOP->op_first;
+ {
+ *ops++ = cUNOP->op_first;
+ if (ops >= oplimit)
+ croak(too_deep);
+ }
*ops = 0;
if (op->op_flags & OPf_KIDS) {
/* First try all the kids at this level, since that's likeliest. */
@@ -1568,15 +1667,12 @@ OP **opstack;
for (kid = cUNOP->op_first; kid; kid = kid->op_sibling) {
if (kid == lastgotoprobe)
continue;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
- if (ops > opstack &&
- (ops[-1]->op_type == OP_NEXTSTATE ||
- ops[-1]->op_type == OP_DBSTATE))
- *ops = kid;
- else
- *ops++ = kid;
- }
- if (op = dofindlabel(kid,label,ops))
+ 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 (op = dofindlabel(kid, label, ops, oplimit))
return op;
}
}
@@ -1596,7 +1692,8 @@ PP(pp_goto)
OP *retop = 0;
I32 ix;
register CONTEXT *cx;
- OP *enterops[64];
+#define GOTO_DEPTH 64
+ OP *enterops[GOTO_DEPTH];
char *label;
int do_dump = (op->op_type == OP_DUMP);
@@ -1616,7 +1713,7 @@ PP(pp_goto)
if (!CvROOT(cv) && !CvXSUB(cv)) {
if (CvGV(cv)) {
SV *tmpstr = sv_newmortal();
- gv_efullname(tmpstr, CvGV(cv));
+ gv_efullname3(tmpstr, CvGV(cv), Nullch);
DIE("Goto undefined subroutine &%s",SvPVX(tmpstr));
}
DIE("Goto undefined subroutine");
@@ -1634,8 +1731,11 @@ PP(pp_goto)
AV* av = cx->blk_sub.argarray;
items = AvFILL(av) + 1;
- Copy(AvARRAY(av), ++stack_sp, items, SV*);
+ stack_sp++;
+ EXTEND(stack_sp, items); /* @_ could have been extended. */
+ Copy(AvARRAY(av), stack_sp, items, SV*);
stack_sp += items;
+ SvREFCNT_dec(GvAV(defgv));
GvAV(defgv) = cx->blk_sub.savearray;
AvREAL_off(av);
av_clear(av);
@@ -1661,6 +1761,7 @@ PP(pp_goto)
sp = stack_base + items;
}
else {
+ stack_sp--; /* There is no cv arg. */
(void)(*CvXSUB(cv))(cv);
}
LEAVE;
@@ -1676,8 +1777,7 @@ PP(pp_goto)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
if (CvDEPTH(cv) == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",
- GvENAME(CvGV(cv)));
+ sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILL(padlist)) {
AV *newpad = newAV();
SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
@@ -1686,8 +1786,10 @@ PP(pp_goto)
for ( ;ix > 0; ix--) {
if (svp[ix] != &sv_undef) {
char *name = SvPVX(svp[ix]);
- if (SvFLAGS(svp[ix]) & SVf_FAKE) {
- /* outer lexical? */
+ if ((SvFLAGS(svp[ix]) & SVf_FAKE)
+ || *name == '&')
+ {
+ /* outer lexical or anon code */
av_store(newpad, ix,
SvREFCNT_inc(oldpad[ix]) );
}
@@ -1725,7 +1827,7 @@ PP(pp_goto)
cx->blk_sub.savearray = GvAV(defgv);
cx->blk_sub.argarray = av;
- GvAV(defgv) = cx->blk_sub.argarray;
+ GvAV(defgv) = (AV*)SvREFCNT_inc(av);
++mark;
if (items >= AvMAX(av) + 1) {
@@ -1750,6 +1852,15 @@ PP(pp_goto)
mark++;
}
}
+ if (PERLDB_SUB && curstash != debstash) {
+ /*
+ * We do not care about using sv to call CV;
+ * it's for informational purposes only.
+ */
+ SV *sv = GvSV(DBsub);
+ save_item(sv);
+ gv_efullname3(sv, CvGV(cv), Nullch);
+ }
RETURNOP(CvSTART(cv));
}
}
@@ -1773,9 +1884,6 @@ PP(pp_goto)
for (ix = cxstack_ix; ix >= 0; ix--) {
cx = &cxstack[ix];
switch (cx->cx_type) {
- case CXt_SUB:
- gotoprobe = CvROOT(cx->blk_sub.cv);
- break;
case CXt_EVAL:
gotoprobe = eval_root; /* XXX not good for nested eval */
break;
@@ -1790,14 +1898,22 @@ PP(pp_goto)
else
gotoprobe = 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");
- else
- gotoprobe = main_root;
+ gotoprobe = main_root;
break;
}
- retop = dofindlabel(gotoprobe, label, enterops);
+ retop = dofindlabel(gotoprobe, label,
+ enterops, enterops + GOTO_DEPTH);
if (retop)
break;
lastgotoprobe = gotoprobe;
@@ -1824,6 +1940,11 @@ PP(pp_goto)
OP *oldop = op;
for (ix = 1; enterops[ix]; ix++) {
op = enterops[ix];
+ /* Eventually we may want to stack the needed arguments
+ * for each op. For now, we punt on the hard ones. */
+ if (op->op_type == OP_ENTERITER)
+ DIE("Can't \"goto\" into the middle of a foreach loop",
+ label);
(*op->op_ppaddr)();
}
op = oldop;
@@ -1843,9 +1964,9 @@ PP(pp_goto)
do_undump = FALSE;
}
- if (stack == signalstack) {
+ if (curstack == signalstack) {
restartop = retop;
- Siglongjmp(top_env, 3);
+ JMPENV_JUMP(3);
}
RETURNOP(retop);
@@ -1858,8 +1979,13 @@ PP(pp_exit)
if (MAXARG < 1)
anum = 0;
- else
+ else {
anum = SvIVx(POPs);
+#ifdef VMSISH_EXIT
+ if (anum == 1 && VMSISH_EXIT)
+ anum = 0;
+#endif
+ }
my_exit(anum);
PUSHs(&sv_undef);
RETURN;
@@ -1934,29 +2060,74 @@ SV *sv;
}
static OP *
+docatch(o)
+OP *o;
+{
+ int ret;
+ I32 oldrunlevel = runlevel;
+ OP *oldop = op;
+ dJMPENV;
+
+ op = o;
+#ifdef DEBUGGING
+ assert(CATCH_GET == TRUE);
+ DEBUG_l(deb("(Setting up local jumplevel, runlevel = %ld)\n", (long)runlevel+1));
+#endif
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ default: /* topmost level handles it */
+ JMPENV_POP;
+ runlevel = oldrunlevel;
+ op = oldop;
+ JMPENV_JUMP(ret);
+ /* NOTREACHED */
+ case 3:
+ if (!restartop) {
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ break;
+ }
+ op = restartop;
+ restartop = 0;
+ /* FALL THROUGH */
+ case 0:
+ runops();
+ break;
+ }
+ JMPENV_POP;
+ runlevel = oldrunlevel;
+ op = oldop;
+ return Nullop;
+}
+
+static OP *
doeval(gimme)
int gimme;
{
dSP;
OP *saveop = op;
HV *newstash;
+ CV *caller;
AV* comppadlist;
in_eval = 1;
+ PUSHMARK(SP);
+
/* set up a scratch pad */
- SAVEINT(padix);
+ SAVEI32(padix);
SAVESPTR(curpad);
SAVESPTR(comppad);
SAVESPTR(comppad_name);
- SAVEINT(comppad_name_fill);
- SAVEINT(min_intro_pending);
- SAVEINT(max_intro_pending);
+ SAVEI32(comppad_name_fill);
+ SAVEI32(min_intro_pending);
+ SAVEI32(max_intro_pending);
+ caller = compcv;
SAVESPTR(compcv);
compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)compcv, SVt_PVCV);
+ CvUNIQUE_on(compcv);
comppad = newAV();
comppad_name = newAV();
@@ -1971,6 +2142,10 @@ int gimme;
av_store(comppadlist, 0, (SV*)comppad_name);
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(compcv) = comppadlist;
+
+ if (saveop->op_type != OP_REQUIRE)
+ CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
+
SAVEFREESV(compcv);
/* make sure we compile in the right package */
@@ -1992,7 +2167,10 @@ int gimme;
curcop->cop_arybase = 0;
SvREFCNT_dec(rs);
rs = newSVpv("\n", 1);
- sv_setpv(GvSV(errgv),"");
+ if (saveop->op_flags & OPf_SPECIAL)
+ in_eval |= 4;
+ else
+ sv_setpv(GvSV(errgv),"");
if (yyparse() || error_count || !eval_root) {
SV **newsp;
I32 gimme;
@@ -2004,13 +2182,16 @@ int gimme;
op_free(eval_root);
eval_root = Nullop;
}
+ SP = stack_base + POPMARK; /* pop original mark */
POPBLOCK(cx,curpm);
POPEVAL(cx);
pop_return();
lex_end();
LEAVE;
- if (optype == OP_REQUIRE)
- DIE("%s", SvPVx(GvSV(errgv), na));
+ if (optype == OP_REQUIRE) {
+ char* msg = SvPVx(GvSV(errgv), na);
+ DIE("%s", *msg ? msg : "Compilation failed in require");
+ }
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
RETPUSHUNDEF;
@@ -2019,15 +2200,33 @@ int gimme;
rs = SvREFCNT_inc(nrs);
compiling.cop_line = 0;
SAVEFREEOP(eval_root);
- if (gimme & G_ARRAY)
+ if (gimme & G_VOID)
+ scalarvoid(eval_root);
+ else if (gimme & G_ARRAY)
list(eval_root);
else
scalar(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*)compiling.cop_filegv);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ }
+ }
+
/* compiled okay, so do it */
+ CvDEPTH(compcv) = 1;
+
+ SP = stack_base + POPMARK; /* pop original mark */
+ op = saveop; /* The caller may need it. */
RETURNOP(eval_start);
}
@@ -2037,13 +2236,15 @@ PP(pp_require)
register CONTEXT *cx;
SV *sv;
char *name;
- char *tmpname;
+ char *tryname;
+ SV *namesv = Nullsv;
SV** svp;
I32 gimme = G_SCALAR;
- FILE *tryrsfp = 0;
+ PerlIO *tryrsfp = 0;
sv = POPs;
if (SvNIOKp(sv) && !SvPOKp(sv)) {
+ SET_NUMERIC_STANDARD();
if (atof(patchlevel) + 0.00000999 < SvNV(sv))
DIE("Perl %s required--this is only version %s, stopped",
SvPV(sv,na),patchlevel);
@@ -2060,59 +2261,77 @@ PP(pp_require)
/* prepare to compile file */
- tmpname = savepv(name);
- if (*tmpname == '/' ||
- (*tmpname == '.' &&
- (tmpname[1] == '/' ||
- (tmpname[1] == '.' && tmpname[2] == '/')))
+ if (*name == '/' ||
+ (*name == '.' &&
+ (name[1] == '/' ||
+ (name[1] == '.' && name[2] == '/')))
#ifdef DOSISH
- || (tmpname[0] && tmpname[1] == ':')
+ || (name[0] && name[1] == ':')
+#endif
+#ifdef WIN32
+ || (name[0] == '\\' && name[1] == '\\') /* UNC path */
#endif
#ifdef VMS
- || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') &&
- (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>')))
+ || (strchr(name,':') || ((*name == '[' || *name == '<') &&
+ (isALNUM(name[1]) || strchr("$-_]>",name[1]))))
#endif
)
{
- tryrsfp = fopen(tmpname,"r");
+ tryname = name;
+ tryrsfp = PerlIO_open(name,"r");
}
else {
AV *ar = GvAVn(incgv);
I32 i;
-
- for (i = 0; i <= AvFILL(ar); i++) {
#ifdef VMS
- if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL)
- continue;
- strcat(buf,name);
+ 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), na);
+#ifdef VMS
+ char *unixdir;
+ if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
+ continue;
+ sv_setpv(namesv, unixdir);
+ sv_catpv(namesv, unixname);
#else
- (void)sprintf(buf, "%s/%s",
- SvPVx(*av_fetch(ar, i, TRUE), na), name);
+ sv_setpvf(namesv, "%s/%s", dir, name);
#endif
- tryrsfp = fopen(buf, "r");
- if (tryrsfp) {
- char *s = buf;
-
- if (*s == '.' && s[1] == '/')
- s += 2;
- Safefree(tmpname);
- tmpname = savepv(s);
- break;
+ tryname = SvPVX(namesv);
+ tryrsfp = PerlIO_open(tryname, "r");
+ if (tryrsfp) {
+ if (tryname[0] == '.' && tryname[1] == '/')
+ tryname += 2;
+ break;
+ }
}
}
}
SAVESPTR(compiling.cop_filegv);
- compiling.cop_filegv = gv_fetchfile(tmpname);
- Safefree(tmpname);
- tmpname = Nullch;
+ compiling.cop_filegv = gv_fetchfile(tryrsfp ? tryname : name);
+ SvREFCNT_dec(namesv);
if (!tryrsfp) {
if (op->op_type == OP_REQUIRE) {
- sprintf(tokenbuf,"Can't locate %s in @INC", name);
- if (instr(tokenbuf,".h "))
- strcat(tokenbuf," (change .h to .ph maybe?)");
- if (instr(tokenbuf,".ph "))
- strcat(tokenbuf," (did you run h2ph?)");
- DIE("%s",tokenbuf);
+ SV *msg = sv_2mortal(newSVpvf("Can't locate %s in @INC", name));
+ SV *dirmsgsv = NEWSV(0, 0);
+ AV *ar = GvAVn(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), na);
+ sv_setpvf(dirmsgsv, " %s", dir);
+ sv_catsv(msg, dirmsgsv);
+ }
+ sv_catpvn(msg, ")", 1);
+ SvREFCNT_dec(dirmsgsv);
+ DIE("%_", msg);
}
RETPUSHUNDEF;
@@ -2145,7 +2364,7 @@ PP(pp_require)
compiling.cop_line = 0;
PUTBACK;
- return doeval(G_SCALAR);
+ return DOCATCH(doeval(G_SCALAR));
}
PP(pp_dofile)
@@ -2158,9 +2377,11 @@ PP(pp_entereval)
dSP;
register CONTEXT *cx;
dPOPss;
- I32 gimme = GIMME;
- char tmpbuf[32];
+ I32 gimme = GIMME_V, was = sub_generation;
+ char tmpbuf[TYPE_DIGITS(long) + 12];
+ char *safestr;
STRLEN len;
+ OP *ret;
if (!SvPV(sv,len) || !len)
RETPUSHUNDEF;
@@ -2173,10 +2394,16 @@ PP(pp_entereval)
/* switch to eval mode */
SAVESPTR(compiling.cop_filegv);
- sprintf(tmpbuf, "_<(eval %d)", ++evalseq);
+ sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++evalseq);
compiling.cop_filegv = gv_fetchfile(tmpbuf+2);
compiling.cop_line = 1;
- SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf));
+ /* 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(defstash, safestr, strlen(safestr));
SAVEI32(hints);
hints = op->op_targ;
@@ -2186,10 +2413,15 @@ PP(pp_entereval)
/* prepare to compile string */
- if (perldb && curstash != debstash)
+ if (PERLDB_LINE && curstash != debstash)
save_lines(GvAV(compiling.cop_filegv), linestr);
PUTBACK;
- return doeval(gimme);
+ ret = doeval(gimme);
+ if (PERLDB_INTER && was != sub_generation /* Some subs defined here. */
+ && ret != op->op_next) { /* Successive compilation. */
+ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
+ }
+ return DOCATCH(ret);
}
PP(pp_leaveeval)
@@ -2201,53 +2433,89 @@ PP(pp_leaveeval)
I32 gimme;
register CONTEXT *cx;
OP *retop;
+ U8 save_flags = op -> op_flags;
I32 optype;
POPBLOCK(cx,newpm);
POPEVAL(cx);
retop = pop_return();
- if (gimme == G_SCALAR) {
- if (op->op_private & OPpLEAVE_VOID)
- MARK = newsp;
+ 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 {
- MARK = newsp + 1;
- if (MARK <= SP) {
- if (SvFLAGS(TOPs) & SVs_TEMP)
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
- }
- else {
- MEXTEND(mark,0);
- *MARK = &sv_undef;
- }
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
}
- SP = MARK;
}
else {
- for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(TOPs) & SVs_TEMP))
+ /* in case LEAVE wipes old return values */
+ for (mark = newsp + 1; mark <= SP; mark++) {
+ if (!(SvFLAGS(*mark) & SVs_TEMP)) {
*mark = sv_mortalcopy(*mark);
- /* in case LEAVE wipes old return values */
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
}
curpm = newpm; /* Don't pop $1 et al till now */
- if (optype != OP_ENTEREVAL) {
- char *name = cx->blk_eval.old_name;
+ /*
+ * 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 (AvFILL(comppad_name) >= 0) {
+ SV **svp = AvARRAY(comppad_name);
+ I32 ix;
+ for (ix = AvFILL(comppad_name); ix >= 0; ix--) {
+ SV *sv = svp[ix];
+ if (sv && sv != &sv_undef && *SvPVX(sv) == '&') {
+ SvREFCNT_dec(sv);
+ svp[ix] = &sv_undef;
+
+ sv = curpad[ix];
+ if (CvCLONE(sv)) {
+ SvREFCNT_dec(CvOUTSIDE(sv));
+ CvOUTSIDE(sv) = Nullcv;
+ }
+ else {
+ SvREFCNT_dec(sv);
+ sv = NEWSV(0,0);
+ SvPADTMP_on(sv);
+ curpad[ix] = sv;
+ }
+ }
+ }
+ }
- if (!(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
- /* Unassume the success we assumed earlier. */
- (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
+#ifdef DEBUGGING
+ assert(CvDEPTH(compcv) == 1);
+#endif
+ CvDEPTH(compcv) = 0;
- if (optype == OP_REQUIRE)
- retop = die("%s did not return a true value", name);
- }
+ 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(incgv), name, strlen(name), G_DISCARD);
+ retop = die("%s did not return a true value", name);
}
lex_end();
LEAVE;
- sv_setpv(GvSV(errgv),"");
+
+ if (!(save_flags & OPf_SPECIAL))
+ sv_setpv(GvSV(errgv),"");
RETURNOP(retop);
}
@@ -2256,7 +2524,7 @@ PP(pp_entertry)
{
dSP;
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
@@ -2268,7 +2536,8 @@ PP(pp_entertry)
in_eval = 1;
sv_setpv(GvSV(errgv),"");
- RETURN;
+ PUTBACK;
+ return DOCATCH(op->op_next);
}
PP(pp_leavetry)
@@ -2285,29 +2554,31 @@ PP(pp_leavetry)
POPEVAL(cx);
pop_return();
- if (gimme == G_SCALAR) {
- if (op->op_private & OPpLEAVE_VOID)
- MARK = newsp;
+ 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 {
- 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 = &sv_undef;
- }
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
}
SP = MARK;
}
else {
- for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)))
+ /* 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);
- /* in case LEAVE wipes old return values */
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
}
curpm = newpm; /* Don't pop $1 et al till now */
@@ -2334,7 +2605,10 @@ SV *sv;
register I32 arg;
bool ischop;
- New(804, fops, (send - s)*3+2, U16); /* Almost certainly too long... */
+ 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) {
@@ -2367,13 +2641,12 @@ SV *sv;
skipspaces++;
arg -= skipspaces;
if (arg) {
- if (postspace) {
+ if (postspace)
*fpc++ = FF_SPACE;
- postspace = FALSE;
- }
*fpc++ = FF_LITERAL;
*fpc++ = arg;
}
+ postspace = FALSE;
if (s <= send)
skipspaces--;
if (skipspaces) {
@@ -2489,5 +2762,6 @@ SV *sv;
}
Copy(fops, s, arg, U16);
Safefree(fops);
+ sv_magic(sv, Nullsv, 'f', Nullch, 0);
SvCOMPILED_on(sv);
}
diff --git a/gnu/usr.bin/perl/pp_hot.c b/gnu/usr.bin/perl/pp_hot.c
index 8fe39f37f7b..e1f4476dda8 100644
--- a/gnu/usr.bin/perl/pp_hot.c
+++ b/gnu/usr.bin/perl/pp_hot.c
@@ -1,6 +1,6 @@
/* pp_hot.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -76,64 +76,6 @@ PP(pp_gv)
RETURN;
}
-PP(pp_gelem)
-{
- GV *gv;
- SV *sv;
- SV *ref;
- char *elem;
- dSP;
-
- sv = POPs;
- elem = SvPV(sv, na);
- gv = (GV*)POPs;
- ref = Nullsv;
- sv = Nullsv;
- switch (elem ? *elem : '\0')
- {
- case 'A':
- if (strEQ(elem, "ARRAY"))
- ref = (SV*)GvAV(gv);
- break;
- case 'C':
- if (strEQ(elem, "CODE"))
- ref = (SV*)GvCV(gv);
- break;
- case 'F':
- if (strEQ(elem, "FILEHANDLE"))
- ref = (SV*)GvIOp(gv);
- break;
- case 'G':
- if (strEQ(elem, "GLOB"))
- ref = (SV*)gv;
- break;
- case 'H':
- if (strEQ(elem, "HASH"))
- ref = (SV*)GvHV(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"))
- ref = GvSV(gv);
- break;
- }
- if (ref)
- sv = newRV(ref);
- if (sv)
- sv_2mortal(sv);
- else
- sv = &sv_undef;
- XPUSHs(sv);
- RETURN;
-}
-
PP(pp_and)
{
dSP;
@@ -154,13 +96,9 @@ PP(pp_sassign)
SV *temp;
temp = left; left = right; right = temp;
}
- if (tainting && tainted && (!SvGMAGICAL(left) || !SvSMAGICAL(left) ||
- !((mg = mg_find(left, 't')) && mg->mg_len & 1)))
- {
+ if (tainting && tainted && !SvTAINTED(left))
TAINT_NOT;
- }
- SvSetSV(right, left);
- SvSETMAGIC(right);
+ SvSetMagicSV(right, left);
SETs(right);
RETURN;
}
@@ -185,16 +123,6 @@ PP(pp_unstack)
return NORMAL;
}
-PP(pp_seq)
-{
- dSP; tryAMAGICbinSET(seq,0);
- {
- dPOPTOPssrl;
- SETs( sv_eq(left, right) ? &sv_yes : &sv_no );
- RETURN;
- }
-}
-
PP(pp_concat)
{
dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
@@ -208,12 +136,15 @@ PP(pp_concat)
}
else if (SvGMAGICAL(TARG))
mg_get(TARG);
- else if (!SvOK(TARG)) {
- s = SvPV_force(TARG, len);
+ else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) {
sv_setpv(TARG, ""); /* Suppress warning. */
+ s = SvPV_force(TARG, len);
}
s = SvPV(right,len);
- sv_catpvn(TARG,s,len);
+ if (SvOK(TARG))
+ sv_catpvn(TARG,s,len);
+ else
+ sv_setpvn(TARG,s,len); /* suppress warning */
SETTARG;
RETURN;
}
@@ -226,8 +157,8 @@ PP(pp_padsv)
if (op->op_flags & OPf_MOD) {
if (op->op_private & OPpLVAL_INTRO)
SAVECLEARSV(curpad[op->op_targ]);
- else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
- provide_ref(op, curpad[op->op_targ]);
+ else if (op->op_private & OPpDEREF)
+ vivify_ref(curpad[op->op_targ], op->op_private & OPpDEREF);
}
RETURN;
}
@@ -243,7 +174,7 @@ PP(pp_eq)
dSP; tryAMAGICbinSET(eq,0);
{
dPOPnv;
- SETs((TOPn == value) ? &sv_yes : &sv_no);
+ SETs(boolSV(TOPn == value));
RETURN;
}
}
@@ -251,9 +182,13 @@ PP(pp_eq)
PP(pp_preinc)
{
dSP;
- if (SvIOK(TOPs)) {
+ 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) &= ~(SVf_NOK|SVf_POK|SVp_NOK|SVp_POK);
+ SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else
sv_inc(TOPs);
@@ -276,7 +211,7 @@ PP(pp_add)
{
dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
{
- dPOPTOPnnrl;
+ dPOPTOPnnrl_ul;
SETn( left + right );
RETURN;
}
@@ -304,7 +239,19 @@ PP(pp_join)
PP(pp_pushre)
{
dSP;
+#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(&op, &LvTARGOFF(sv), 1, OP*);
+ XPUSHs(sv);
+#else
XPUSHs((SV*)op);
+#endif
RETURN;
}
@@ -315,16 +262,36 @@ PP(pp_print)
dSP; dMARK; dORIGMARK;
GV *gv;
IO *io;
- register FILE *fp;
+ register PerlIO *fp;
+ MAGIC *mg;
if (op->op_flags & OPf_STACKED)
gv = (GV*)*++MARK;
else
gv = defoutgv;
+ if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+ if (MARK == ORIGMARK) {
+ EXTEND(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 (dowarn) {
SV* sv = sv_newmortal();
- gv_fullname(sv,gv);
+ gv_fullname3(sv, gv, Nullch);
warn("Filehandle %s never opened", SvPV(sv,na));
}
@@ -334,7 +301,7 @@ PP(pp_print)
else if (!(fp = IoOFP(io))) {
if (dowarn) {
SV* sv = sv_newmortal();
- gv_fullname(sv,gv);
+ gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
warn("Filehandle %s opened only for input", SvPV(sv,na));
else
@@ -351,7 +318,7 @@ PP(pp_print)
break;
MARK++;
if (MARK <= SP) {
- if (fwrite1(ofs, 1, ofslen, fp) == 0 || ferror(fp)) {
+ if (PerlIO_write(fp, ofs, ofslen) == 0 || PerlIO_error(fp)) {
MARK--;
break;
}
@@ -369,11 +336,11 @@ PP(pp_print)
goto just_say_no;
else {
if (orslen)
- if (fwrite1(ors, 1, orslen, fp) == 0 || ferror(fp))
+ if (PerlIO_write(fp, ors, orslen) == 0 || PerlIO_error(fp))
goto just_say_no;
if (IoFLAGS(io) & IOf_FLUSH)
- if (Fflush(fp) == EOF)
+ if (PerlIO_flush(fp) == EOF)
goto just_say_no;
}
}
@@ -390,7 +357,6 @@ PP(pp_print)
PP(pp_rv2av)
{
dSP; dPOPss;
-
AV *av;
if (SvROK(sv)) {
@@ -398,8 +364,6 @@ PP(pp_rv2av)
av = (AV*)SvRV(sv);
if (SvTYPE(av) != SVt_PVAV)
DIE("Not an ARRAY reference");
- if (op->op_private & OPpLVAL_INTRO)
- av = (AV*)save_svref((SV**)sv);
if (op->op_flags & OPf_REF) {
PUSHs((SV*)av);
RETURN;
@@ -414,6 +378,8 @@ PP(pp_rv2av)
}
}
else {
+ GV *gv;
+
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
@@ -426,6 +392,8 @@ PP(pp_rv2av)
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "an ARRAY");
+ if (dowarn)
+ warn(warn_uninit);
if (GIMME == G_ARRAY)
RETURN;
RETPUSHUNDEF;
@@ -433,11 +401,13 @@ PP(pp_rv2av)
sym = SvPV(sv,na);
if (op->op_private & HINT_STRICT_REFS)
DIE(no_symref, sym, "an ARRAY");
- sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
+ } else {
+ gv = (GV*)sv;
}
- av = GvAVn(sv);
+ av = GvAVn(gv);
if (op->op_private & OPpLVAL_INTRO)
- av = save_ary(sv);
+ av = save_ary(gv);
if (op->op_flags & OPf_REF) {
PUSHs((SV*)av);
RETURN;
@@ -461,9 +431,7 @@ PP(pp_rv2av)
PP(pp_rv2hv)
{
-
dSP; dTOPss;
-
HV *hv;
if (SvROK(sv)) {
@@ -471,8 +439,6 @@ PP(pp_rv2hv)
hv = (HV*)SvRV(sv);
if (SvTYPE(hv) != SVt_PVHV)
DIE("Not a HASH reference");
- if (op->op_private & OPpLVAL_INTRO)
- hv = (HV*)save_svref((SV**)sv);
if (op->op_flags & OPf_REF) {
SETs((SV*)hv);
RETURN;
@@ -487,6 +453,8 @@ PP(pp_rv2hv)
}
}
else {
+ GV *gv;
+
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
@@ -499,6 +467,8 @@ PP(pp_rv2hv)
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a HASH");
+ if (dowarn)
+ warn(warn_uninit);
if (GIMME == G_ARRAY) {
SP--;
RETURN;
@@ -508,11 +478,13 @@ PP(pp_rv2hv)
sym = SvPV(sv,na);
if (op->op_private & HINT_STRICT_REFS)
DIE(no_symref, sym, "a HASH");
- sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
+ gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
+ } else {
+ gv = (GV*)sv;
}
- hv = GvHVn(sv);
+ hv = GvHVn(gv);
if (op->op_private & OPpLVAL_INTRO)
- hv = save_hash(sv);
+ hv = save_hash(gv);
if (op->op_flags & OPf_REF) {
SETs((SV*)hv);
RETURN;
@@ -526,10 +498,9 @@ PP(pp_rv2hv)
}
else {
dTARGET;
- if (HvFILL(hv)) {
- sprintf(buf, "%d/%d", HvFILL(hv), HvMAX(hv)+1);
- sv_setpv(TARG, buf);
- }
+ if (HvFILL(hv))
+ sv_setpvf(TARG, "%ld/%ld",
+ (long)HvFILL(hv), (long)HvMAX(hv) + 1);
else
sv_setiv(TARG, 0);
SETTARG;
@@ -551,6 +522,7 @@ PP(pp_aassign)
register SV *sv;
register AV *ary;
+ I32 gimme;
HV *hash;
I32 i;
int magic;
@@ -564,8 +536,10 @@ PP(pp_aassign)
if (op->op_private & OPpASSIGN_COMMON) {
for (relem = firstrelem; relem <= lastrelem; relem++) {
/*SUPPRESS 560*/
- if (sv = *relem)
+ if (sv = *relem) {
+ TAINT_NOT; /* Each item is independent */
*relem = sv_mortalcopy(sv);
+ }
}
}
@@ -574,7 +548,7 @@ PP(pp_aassign)
ary = Null(AV*);
hash = Null(HV*);
while (lelem <= lastlelem) {
- tainted = 0; /* Each item stands on its own, taintwise. */
+ TAINT_NOT; /* Each item stands on its own, taintwise. */
sv = *lelem++;
switch (SvTYPE(sv)) {
case SVt_PVAV:
@@ -582,20 +556,25 @@ PP(pp_aassign)
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;
- (void)av_store(ary,i++,sv);
- if (magic)
- mg_set(sv);
- tainted = 0;
+ 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: {
- char *tmps;
SV *tmpstr;
hash = (HV*)sv;
@@ -604,20 +583,26 @@ PP(pp_aassign)
while (relem < lastrelem) { /* gobble up all the rest */
STRLEN len;
+ HE *didstore;
if (*relem)
sv = *(relem++);
else
sv = &sv_no, relem++;
- tmps = SvPV(sv, len);
tmpstr = NEWSV(29,0);
if (*relem)
sv_setsv(tmpstr,*relem); /* value */
*(relem++) = tmpstr;
- (void)hv_store(hash,tmps,len,tmpstr,0);
- if (magic)
- mg_set(tmpstr);
- tainted = 0;
+ 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 && dowarn)
+ warn("Odd number of elements in hash list");
}
break;
default:
@@ -704,20 +689,25 @@ PP(pp_aassign)
tainting |= (uid && (euid != uid || egid != gid));
}
delaymagic = 0;
- if (GIMME == G_ARRAY) {
+
+ 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);
- RETURN;
- }
- else {
- dTARGET;
- SP = firstrelem;
-
- SETi(lastrelem - firstrelem + 1);
- RETURN;
+ lelem = firstlelem + (relem - firstrelem);
+ while (relem <= SP)
+ *relem++ = (lelem <= lastlelem) ? *lelem++ : &sv_undef;
}
+ RETURN;
}
PP(pp_match)
@@ -735,6 +725,7 @@ PP(pp_match)
STRLEN len;
I32 minmatch = 0;
I32 oldsave = savestack_ix;
+ I32 update_minmatch = 1;
if (op->op_flags & OPf_STACKED)
TARG = POPs;
@@ -746,6 +737,7 @@ PP(pp_match)
strend = s + len;
if (!s)
DIE("panic: do_match");
+ TAINT_NOT;
if (pm->op_pmflags & PMf_USED) {
if (gimme == G_ARRAY)
@@ -765,12 +757,14 @@ PP(pp_match)
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;
}
}
}
if (!rx->nparens && !global)
gimme = G_SCALAR; /* accidental array context? */
- safebase = (gimme == G_ARRAY) || global;
+ safebase = (((gimme == G_ARRAY) || global || !rx->nparens)
+ && !sawampersand);
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
SAVEINT(multiline);
multiline = pm->op_pmflags & PMf_MULTILINE;
@@ -779,9 +773,10 @@ PP(pp_match)
play_it_again:
if (global && rx->startp[0]) {
t = s = rx->endp[0];
- if (s > strend)
+ if ((s + rx->minlen) > strend)
goto nope;
- minmatch = (s == rx->startp[0]);
+ if (update_minmatch++)
+ minmatch = (s == rx->startp[0]);
}
if (pm->op_pmshort) {
if (pm->op_pmflags & PMf_SCANFIRST) {
@@ -808,15 +803,10 @@ play_it_again:
s = t;
}
else if (!multiline) {
- if (*SvPVX(pm->op_pmshort) != *s ||
- bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
- if (pm->op_pmflags & PMf_FOLD) {
- if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) )
- goto nope;
- }
- else
- goto nope;
- }
+ if (*SvPVX(pm->op_pmshort) != *s
+ || (pm->op_pmslen > 1
+ && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen)))
+ goto nope;
}
if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
SvREFCNT_dec(pm->op_pmshort);
@@ -824,8 +814,8 @@ play_it_again:
}
}
if (pregexec(rx, s, strend, truebase, minmatch,
- SvSCREAM(TARG) ? TARG : Nullsv,
- safebase)) {
+ SvSCREAM(TARG) ? TARG : Nullsv, safebase))
+ {
curpm = pm;
if (pm->op_pmflags & PMf_ONCE)
pm->op_pmflags |= PMf_USED;
@@ -836,6 +826,7 @@ play_it_again:
/*NOTREACHED*/
gotcha:
+ TAINT_IF(rx->exec_tainted);
if (gimme == G_ARRAY) {
I32 iters, i, len;
@@ -845,6 +836,7 @@ play_it_again:
else
i = 0;
EXTEND(SP, iters + i);
+ EXTEND_MORTAL(iters + i);
for (i = !i; i <= iters; i++) {
PUSHs(sv_newmortal());
/*SUPPRESS 560*/
@@ -855,6 +847,7 @@ play_it_again:
}
if (global) {
truebase = rx->subbeg;
+ strend = rx->subend;
if (rx->startp[0] && rx->startp[0] == rx->endp[0])
++rx->endp[0];
goto play_it_again;
@@ -872,24 +865,25 @@ play_it_again:
mg = mg_find(TARG, 'g');
}
if (rx->startp[0]) {
- mg->mg_len = rx->endp[0] - truebase;
+ 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;
}
- else
- mg->mg_len = -1;
}
LEAVE_SCOPE(oldsave);
RETPUSHYES;
}
yup:
+ TAINT_IF(rx->exec_tainted);
++BmUSEFUL(pm->op_pmshort);
curpm = pm;
if (pm->op_pmflags & PMf_ONCE)
pm->op_pmflags |= PMf_USED;
+ Safefree(rx->subbase);
+ rx->subbase = Nullch;
if (global) {
rx->subbeg = truebase;
rx->subend = strend;
@@ -900,8 +894,6 @@ yup:
if (sawampersand) {
char *tmps;
- if (rx->subbase)
- Safefree(rx->subbase);
tmps = rx->subbase = savepvn(t, strend-t);
rx->subbeg = tmps;
rx->subend = tmps + (strend-t);
@@ -916,7 +908,7 @@ nope:
++BmUSEFUL(pm->op_pmshort);
ret_no:
- if (global) {
+ if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
MAGIC* mg = mg_find(TARG, 'g');
if (mg)
@@ -936,10 +928,24 @@ do_readline()
register SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
- FILE *fp;
+ PerlIO *fp;
register IO *io = GvIO(last_in_gv);
register I32 type = op->op_type;
+ I32 gimme = GIMME_V;
+ MAGIC *mg;
+ if (SvMAGICAL(last_in_gv) && (mg = mg_find((SV*)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);
@@ -976,7 +982,7 @@ do_readline()
char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
$DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
- FILE *tmpfp;
+ PerlIO *tmpfp;
STRLEN i;
struct dsc$descriptor_s wilddsc
= {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
@@ -1006,7 +1012,7 @@ do_readline()
break;
}
}
- if ((tmpfp = fopen(tmpfnam,"w+","fop=dlt")) != NULL) {
+ if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
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,
@@ -1016,7 +1022,7 @@ do_readline()
*(end++) = '\n'; *end = '\0';
for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
if (hasdir) {
- if (isunix) trim_unixpath(rstr,SvPVX(tmpglob));
+ if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
begin = rstr;
}
else {
@@ -1024,7 +1030,7 @@ do_readline()
while (*(--begin) != ']' && *begin != '>') ;
++begin;
}
- ok = (fputs(begin,tmpfp) != EOF);
+ ok = (PerlIO_puts(tmpfp,begin) != EOF);
}
if (cxt) (void)lib$find_file_end(&cxt);
if (ok && sts != RMS$_NMF &&
@@ -1033,23 +1039,30 @@ do_readline()
if (!(sts & 1)) {
SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
}
- fclose(tmpfp);
+ PerlIO_close(tmpfp);
fp = NULL;
}
else {
- rewind(tmpfp);
+ 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
sv_setpv(tmpcmd, "perlglob ");
sv_catsv(tmpcmd, tmpglob);
sv_catpv(tmpcmd, " |");
-#else
-#ifdef CSH
+#endif /* !OS2 */
+#else /* !DOSISH */
+#if defined(CSH)
sv_setpvn(tmpcmd, cshname, cshlen);
sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
sv_catsv(tmpcmd, tmpglob);
@@ -1063,7 +1076,7 @@ do_readline()
sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
#endif
#endif /* !CSH */
-#endif /* !MSDOS */
+#endif /* !DOSISH */
(void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
FALSE, 0, 0, Nullfp);
fp = IoIFP(io);
@@ -1077,18 +1090,16 @@ do_readline()
if (!fp) {
if (dowarn && io && !(IoFLAGS(io) & IOf_START))
warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
- if (GIMME == G_SCALAR) {
+ if (gimme == G_SCALAR) {
(void)SvOK_off(TARG);
PUSHTARG;
}
RETURN;
}
- if (GIMME == G_ARRAY) {
- sv = sv_2mortal(NEWSV(57, 80));
- offset = 0;
- }
- else {
+ 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)
@@ -1098,9 +1109,13 @@ do_readline()
else
offset = 0;
}
+ else {
+ sv = sv_2mortal(NEWSV(57, 80));
+ offset = 0;
+ }
for (;;) {
if (!sv_gets(sv, fp, offset)) {
- clearerr(fp);
+ PerlIO_clearerr(fp);
if (IoFLAGS(io) & IOf_ARGV) {
fp = nextargv(last_in_gv);
if (fp)
@@ -1109,20 +1124,23 @@ do_readline()
IoFLAGS(io) |= IOf_START;
}
else if (type == OP_GLOB) {
- (void)do_close(last_in_gv, FALSE);
+ if (do_close(last_in_gv, FALSE) & ~0xFF)
+ warn("internal error: glob failed");
}
- if (GIMME == G_SCALAR) {
+ 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 (tainting) {
- tainted = TRUE;
- SvTAINT(sv); /* Anything from the outside world...*/
- }
if (type == OP_GLOB) {
char *tmps;
@@ -1142,7 +1160,7 @@ do_readline()
continue;
}
}
- if (GIMME == G_ARRAY) {
+ if (gimme == G_ARRAY) {
if (SvLEN(sv) - SvCUR(sv) > 20) {
SvLEN_set(sv, SvCUR(sv)+1);
Renew(SvPVX(sv), SvLEN(sv), char);
@@ -1150,7 +1168,7 @@ do_readline()
sv = sv_2mortal(NEWSV(58, 80));
continue;
}
- else if (!tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
+ 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);
@@ -1166,19 +1184,14 @@ PP(pp_enter)
{
dSP;
register CONTEXT *cx;
- I32 gimme;
-
- /*
- * We don't just use the GIMME macro here because it assumes there's
- * already a context, which ain't necessarily so at initial startup.
- */
+ I32 gimme = OP_GIMME(op, -1);
- if (op->op_flags & OPf_KNOW)
- gimme = op->op_flags & OPf_LIST;
- else if (cxstack_ix >= 0)
- gimme = cxstack[cxstack_ix].blk_gimme;
- else
- gimme = G_SCALAR;
+ if (gimme == -1) {
+ if (cxstack_ix >= 0)
+ gimme = cxstack[cxstack_ix].blk_gimme;
+ else
+ gimme = G_SCALAR;
+ }
ENTER;
@@ -1191,25 +1204,41 @@ PP(pp_enter)
PP(pp_helem)
{
dSP;
- SV** svp;
+ HE* he;
SV *keysv = POPs;
- STRLEN keylen;
- char *key = SvPV(keysv, keylen);
HV *hv = (HV*)POPs;
- I32 lval = op->op_flags & OPf_MOD;
+ U32 lval = op->op_flags & OPf_MOD;
+ U32 defer = op->op_private & OPpLVAL_DEFER;
if (SvTYPE(hv) != SVt_PVHV)
RETPUSHUNDEF;
- svp = hv_fetch(hv, key, keylen, lval);
+ he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
if (lval) {
- if (!svp || *svp == &sv_undef)
- DIE(no_helem, key);
- if (op->op_private & OPpLVAL_INTRO)
- save_svref(svp);
- else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
- provide_ref(op, *svp);
+ if (!he || HeVAL(he) == &sv_undef) {
+ SV* lv;
+ SV* key2;
+ if (!defer)
+ DIE(no_helem, SvPV(keysv, 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 (op->op_private & OPpLVAL_INTRO) {
+ if (HvNAME(hv) && isGV(HeVAL(he)))
+ save_gp((GV*)HeVAL(he), !(op->op_flags & OPf_SPECIAL));
+ else
+ save_svref(&HeVAL(he));
+ }
+ else if (op->op_private & OPpDEREF)
+ vivify_ref(HeVAL(he), op->op_private & OPpDEREF);
}
- PUSHs(svp ? *svp : &sv_undef);
+ PUSHs(he ? HeVAL(he) : &sv_undef);
RETURN;
}
@@ -1229,35 +1258,38 @@ PP(pp_leave)
POPBLOCK(cx,newpm);
- if (op->op_flags & OPf_KNOW)
- gimme = op->op_flags & OPf_LIST;
- else if (cxstack_ix >= 0)
- gimme = cxstack[cxstack_ix].blk_gimme;
- else
- gimme = G_SCALAR;
+ gimme = OP_GIMME(op, -1);
+ if (gimme == -1) {
+ if (cxstack_ix >= 0)
+ gimme = cxstack[cxstack_ix].blk_gimme;
+ else
+ gimme = G_SCALAR;
+ }
- if (gimme == G_SCALAR) {
- if (op->op_private & OPpLEAVE_VOID)
- SP = newsp;
+ 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 {
- 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 = &sv_undef;
- }
- SP = MARK;
+ MEXTEND(mark,0);
+ *MARK = &sv_undef;
}
+ SP = MARK;
}
- else {
- for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
+ 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);
- /* in case LEAVE wipes old return values */
+ TAINT_NOT; /* Each item is independent */
+ }
+ }
}
curpm = newpm; /* Don't pop $1 et al till now */
@@ -1270,27 +1302,45 @@ PP(pp_iter)
{
dSP;
register CONTEXT *cx;
- SV *sv;
+ 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 (av == stack && cx->blk_loop.iterix >= cx->blk_oldsp)
+ if (cx->blk_loop.iterix >= (av == curstack ? cx->blk_oldsp : AvFILL(av)))
RETPUSHNO;
- if (cx->blk_loop.iterix >= AvFILL(av))
- RETPUSHNO;
+ SvREFCNT_dec(*cx->blk_loop.itervar);
- if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) {
+ if (sv = AvARRAY(av)[++cx->blk_loop.iterix])
SvTEMP_off(sv);
- *cx->blk_loop.itervar = sv;
- }
else
- *cx->blk_loop.itervar = &sv_undef;
+ sv = &sv_undef;
+ if (av != 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) = -1;
+ sv = (SV*)lv;
+ }
+ *cx->blk_loop.itervar = SvREFCNT_inc(sv);
RETPUSHYES;
}
@@ -1310,6 +1360,7 @@ PP(pp_subst)
I32 maxiters;
register I32 i;
bool once;
+ bool rxtainted;
char *orig;
I32 safebase;
register REGEXP *rx = pm->op_pmregexp;
@@ -1317,17 +1368,22 @@ PP(pp_subst)
int force_on_match = 0;
I32 oldsave = savestack_ix;
- if (pm->op_pmflags & PMf_CONST) /* known replacement string? */
- dstr = POPs;
+ /* known replacement string? */
+ dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
if (op->op_flags & OPf_STACKED)
TARG = POPs;
else {
TARG = GvSV(defgv);
EXTEND(SP,1);
}
+ if (SvREADONLY(TARG)
+ || (SvTYPE(TARG) > SVt_PVLV
+ && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
+ croak(no_modify);
s = SvPV(TARG, len);
- if (!SvPOKp(TARG) || SvREADONLY(TARG) || (SvTYPE(TARG) == SVt_PVGV))
+ if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
force_on_match = 1;
+ TAINT_NOT;
force_it:
if (!pm || !s)
@@ -1340,7 +1396,7 @@ PP(pp_subst)
pm = curpm;
rx = pm->op_pmregexp;
}
- safebase = ((!rx || !rx->nparens) && !sawampersand);
+ safebase = (!rx->nparens && !sawampersand);
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
SAVEINT(multiline);
multiline = pm->op_pmflags & PMf_MULTILINE;
@@ -1367,139 +1423,122 @@ PP(pp_subst)
s = m;
}
else if (!multiline) {
- if (*SvPVX(pm->op_pmshort) != *s ||
- bcmp(SvPVX(pm->op_pmshort), s, pm->op_pmslen) ) {
- if (pm->op_pmflags & PMf_FOLD) {
- if (ibcmp((U8*)SvPVX(pm->op_pmshort), (U8*)s, pm->op_pmslen) )
- goto nope;
- }
- else
- goto nope;
- }
+ if (*SvPVX(pm->op_pmshort) != *s
+ || (pm->op_pmslen > 1
+ && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen)))
+ goto nope;
}
if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
SvREFCNT_dec(pm->op_pmshort);
pm->op_pmshort = Nullsv; /* opt is being useless */
}
}
+
+ /* only replace once? */
once = !(rpm->op_pmflags & PMf_GLOBAL);
- if (rpm->op_pmflags & PMf_CONST) { /* known replacement string? */
- c = SvPV(dstr, clen);
- if (clen <= rx->minlen) {
- /* can do inplace substitution */
- if (pregexec(rx, s, strend, orig, 0,
- SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
- if (force_on_match) {
- force_on_match = 0;
- s = SvPV_force(TARG, len);
- goto force_it;
+
+ /* known replacement string? */
+ c = dstr ? SvPV(dstr, clen) : Nullch;
+
+ /* can do inplace substitution? */
+ if (c && clen <= rx->minlen && safebase) {
+ if (! pregexec(rx, s, strend, orig, 0,
+ SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
+ PUSHs(&sv_no);
+ LEAVE_SCOPE(oldsave);
+ RETURN;
+ }
+ if (force_on_match) {
+ force_on_match = 0;
+ s = SvPV_force(TARG, len);
+ goto force_it;
+ }
+ d = s;
+ curpm = pm;
+ SvSCREAM_off(TARG); /* disable possible screamer */
+ if (once) {
+ rxtainted = rx->exec_tainted;
+ 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;
}
- if (rx->subbase) /* oops, no we can't */
- goto long_way;
- d = s;
- curpm = pm;
- SvSCREAM_off(TARG); /* disable possible screamer */
- if (once) {
- 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);
- (void)SvPOK_only(TARG);
- SvSETMAGIC(TARG);
- PUSHs(&sv_yes);
- LEAVE_SCOPE(oldsave);
- RETURN;
- }
- /*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);
- (void)SvPOK_only(TARG);
- SvSETMAGIC(TARG);
- PUSHs(&sv_yes);
- LEAVE_SCOPE(oldsave);
- RETURN;
- }
- else if (clen) {
- d -= clen;
- sv_chop(TARG, d);
- Copy(c, d, clen, char);
- (void)SvPOK_only(TARG);
- SvSETMAGIC(TARG);
- PUSHs(&sv_yes);
- LEAVE_SCOPE(oldsave);
- RETURN;
- }
- else {
- sv_chop(TARG, d);
- (void)SvPOK_only(TARG);
- SvSETMAGIC(TARG);
- PUSHs(&sv_yes);
- LEAVE_SCOPE(oldsave);
- RETURN;
- }
- /* NOTREACHED */
+ i = strend - d;
+ if (i > 0) {
+ Move(d, m, i, char);
+ m += i;
}
- do {
- if (iters++ > maxiters)
- DIE("Substitution loop");
- 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 (pregexec(rx, s, strend, orig, s == m,
- Nullsv, TRUE)); /* (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 Null */
+ *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);
+ PUSHs(&sv_yes);
+ }
+ else {
+ rxtainted = 0;
+ do {
+ if (iters++ > maxiters)
+ DIE("Substitution loop");
+ rxtainted |= rx->exec_tainted;
+ m = rx->startp[0];
+ /*SUPPRESS 560*/
+ if (i = m - s) {
+ if (s != d)
+ Move(s, d, i, char);
+ d += i;
}
- (void)SvPOK_only(TARG);
- SvSETMAGIC(TARG);
- PUSHs(sv_2mortal(newSViv((I32)iters)));
- LEAVE_SCOPE(oldsave);
- RETURN;
+ if (clen) {
+ Copy(c, d, clen, char);
+ d += clen;
+ }
+ s = rx->endp[0];
+ } while (pregexec(rx, s, strend, orig, s == m,
+ Nullsv, TRUE)); /* 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 */
}
- PUSHs(&sv_no);
- LEAVE_SCOPE(oldsave);
- RETURN;
+ TAINT_IF(rxtainted);
+ PUSHs(sv_2mortal(newSViv((I32)iters)));
}
+ (void)SvPOK_only(TARG);
+ SvSETMAGIC(TARG);
+ SvTAINT(TARG);
+ LEAVE_SCOPE(oldsave);
+ RETURN;
}
- else
- c = Nullch;
+
if (pregexec(rx, s, strend, orig, 0,
- SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
- long_way:
+ SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
goto force_it;
}
+ rxtainted = rx->exec_tainted;
dstr = NEWSV(25, sv_len(TARG));
sv_setpvn(dstr, m, s-m);
curpm = pm;
@@ -1511,6 +1550,7 @@ PP(pp_subst)
do {
if (iters++ > maxiters)
DIE("Substitution loop");
+ rxtainted |= rx->exec_tainted;
if (rx->subbase && rx->subbase != orig) {
m = s;
s = orig;
@@ -1525,10 +1565,11 @@ PP(pp_subst)
sv_catpvn(dstr, c, clen);
if (once)
break;
- } while (pregexec(rx, s, strend, orig, s == m, Nullsv,
- safebase));
+ } while (pregexec(rx, s, strend, orig, s == m, Nullsv, safebase));
sv_catpvn(dstr, s, strend - s);
+ TAINT_IF(rxtainted);
+
(void)SvOOK_off(TARG);
Safefree(SvPVX(TARG));
SvPVX(TARG) = SvPVX(dstr);
@@ -1539,16 +1580,17 @@ PP(pp_subst)
(void)SvPOK_only(TARG);
SvSETMAGIC(TARG);
+ SvTAINT(TARG);
PUSHs(sv_2mortal(newSViv((I32)iters)));
LEAVE_SCOPE(oldsave);
RETURN;
}
- PUSHs(&sv_no);
- LEAVE_SCOPE(oldsave);
- RETURN;
+ goto ret_no;
nope:
++BmUSEFUL(pm->op_pmshort);
+
+ret_no:
PUSHs(&sv_no);
LEAVE_SCOPE(oldsave);
RETURN;
@@ -1566,18 +1608,19 @@ PP(pp_grepwhile)
/* All done yet? */
if (stack_base + *markstack_ptr > sp) {
I32 items;
+ I32 gimme = GIMME_V;
LEAVE; /* exit outer scope */
(void)POPMARK; /* pop src */
items = --*markstack_ptr - markstack_ptr[-1];
(void)POPMARK; /* pop dst */
SP = stack_base + POPMARK; /* pop original mark */
- if (GIMME != G_ARRAY) {
+ if (gimme == G_SCALAR) {
dTARGET;
XPUSHi(items);
- RETURN;
}
- SP += items;
+ else if (gimme == G_ARRAY)
+ SP += items;
RETURN;
}
else {
@@ -1602,40 +1645,36 @@ PP(pp_leavesub)
PMOP *newpm;
I32 gimme;
register CONTEXT *cx;
+ struct block_sub cxsub;
POPBLOCK(cx,newpm);
- POPSUB(cx);
-
+ POPSUB1(cx); /* Delay POPSUB2 until stack values are safe */
+
+ TAINT_NOT;
if (gimme == G_SCALAR) {
MARK = newsp + 1;
if (MARK <= SP)
- if (SvFLAGS(TOPs) & SVs_TEMP)
- *MARK = TOPs;
- else
- *MARK = sv_mortalcopy(TOPs);
+ *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
else {
- MEXTEND(mark,0);
+ MEXTEND(MARK, 0);
*MARK = &sv_undef;
}
SP = MARK;
}
- else {
- for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(*mark) & SVs_TEMP))
- *mark = sv_mortalcopy(*mark);
- /* in case LEAVE wipes old return values */
- }
-
- if (cx->blk_sub.hasargs) { /* You don't exist; go away. */
- AV* av = cx->blk_sub.argarray;
-
- av_clear(av);
- AvREAL_off(av);
+ 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 */
+ }
+ }
}
- curpm = newpm; /* Don't pop $1 et al till now */
+ PUTBACK;
+
+ POPSUB2(); /* Stack values are safe: release CV and @_ ... */
+ curpm = newpm; /* ... and pop $1 et al */
LEAVE;
- PUTBACK;
return pop_return();
}
@@ -1647,6 +1686,7 @@ PP(pp_entersub)
register CV *cv;
register CONTEXT *cx;
I32 gimme;
+ bool hasargs = (op->op_flags & OPf_STACKED) != 0;
if (!sv)
DIE("Not a CODE reference");
@@ -1655,11 +1695,19 @@ PP(pp_entersub)
if (!SvROK(sv)) {
char *sym;
- if (sv == &sv_yes) /* unfound import, ignore */
+ if (sv == &sv_yes) { /* unfound import, ignore */
+ if (hasargs)
+ SP = stack_base + POPMARK;
RETURN;
- if (!SvOK(sv))
+ }
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
+ }
+ else
+ sym = SvPV(sv, na);
+ if (!sym)
DIE(no_usym, "a subroutine");
- sym = SvPV(sv,na);
if (op->op_private & HINT_STRICT_REFS)
DIE(no_symref, sym, "a subroutine");
cv = perl_get_cv(sym, TRUE);
@@ -1676,7 +1724,7 @@ PP(pp_entersub)
cv = (CV*)sv;
break;
case SVt_PVGV:
- if (!(cv = GvCV((GV*)sv)))
+ if (!(cv = GvCVu((GV*)sv)))
cv = sv_2cv(sv, &stash, &gv, TRUE);
break;
}
@@ -1689,46 +1737,49 @@ PP(pp_entersub)
DIE("Not a CODE reference");
if (!CvROOT(cv) && !CvXSUB(cv)) {
- if (gv = CvGV(cv)) {
- SV *tmpstr;
- GV *ngv;
- if (SvFAKE(cv) && GvCV(gv) != cv) { /* autoloaded stub? */
- cv = GvCV(gv);
- if (SvTYPE(sv) == SVt_PVGV) {
- SvREFCNT_dec(GvCV((GV*)sv));
- GvCV((GV*)sv) = (CV*)SvREFCNT_inc((SV*)cv);
- }
- goto retry;
- }
- tmpstr = sv_newmortal();
- gv_efullname(tmpstr, gv);
- ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD");
- if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */
- gv = ngv;
- sv_setsv(GvSV(CvGV(cv)), tmpstr); /* Set CV's $AUTOLOAD */
- if (tainting)
- sv_unmagic(GvSV(CvGV(cv)), 't');
- goto retry;
- }
- else
- DIE("Undefined subroutine &%s called",SvPVX(tmpstr));
+ GV* autogv;
+ SV* subname;
+
+ /* 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;
}
- DIE("Undefined subroutine called");
+ /* sorry */
+ subname = sv_newmortal();
+ gv_efullname3(subname, gv, Nullch);
+ DIE("Undefined subroutine &%s called", SvPVX(subname));
}
- gimme = GIMME;
- if ((op->op_private & OPpENTERSUB_DB) && !CvXSUB(cv)) {
+ gimme = GIMME_V;
+ if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) {
+ SV *oldsv = sv;
sv = GvSV(DBsub);
save_item(sv);
- if (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) {
- /* GV is potentially non-unique */
+ gv = CvGV(cv);
+ if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+ || strEQ(GvNAME(gv), "END")
+ || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+ !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv)
+ && (gv = (GV*)oldsv) ))) { /* Use GV from the stack as a fallback. */
+ /* GV is potentially non-unique, or contain different CV. */
sv_setsv(sv, newRV((SV*)cv));
}
else {
- gv = CvGV(cv);
- gv_efullname(sv,gv);
+ gv_efullname3(sv, gv, Nullch);
}
cv = GvCV(DBsub);
+ if (CvXSUB(cv)) curcopdb = curcop;
if (!cv)
DIE("No DBsub routine");
}
@@ -1738,6 +1789,7 @@ PP(pp_entersub)
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--;
@@ -1753,6 +1805,30 @@ PP(pp_entersub)
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 = GvAV(defgv);
+ I32 items = AvFILL(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 ;
+ }
+ }
+ if (curcopdb) { /* We assume that the first
+ XSUB in &DB::sub is the
+ called one. */
+ SAVESPTR(curcop);
+ curcop = curcopdb;
+ curcopdb = NULL;
+ }
+ /* Do we need to open block here? XXXX */
(void)(*CvXSUB(cv))(cv);
/* Enforce some sanity in scalar context. */
@@ -1770,7 +1846,6 @@ PP(pp_entersub)
else {
dMARK;
register I32 items = SP - MARK;
- I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
AV* padlist = CvPADLIST(cv);
SV** svp = AvARRAY(padlist);
push_return(op->op_next);
@@ -1780,8 +1855,9 @@ PP(pp_entersub)
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
- if (CvDEPTH(cv) == 100 && dowarn)
- warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv)));
+ if (CvDEPTH(cv) == 100 && dowarn
+ && !(PERLDB_SUB && cv == GvCV(DBsub)))
+ sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILL(padlist)) {
AV *av;
AV *newpad = newAV();
@@ -1791,9 +1867,10 @@ PP(pp_entersub)
for ( ;ix > 0; ix--) {
if (svp[ix] != &sv_undef) {
char *name = SvPVX(svp[ix]);
- if (SvFLAGS(svp[ix]) & SVf_FAKE) { /* outer lexical? */
- av_store(newpad, ix,
- SvREFCNT_inc(oldpad[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 == '@')
@@ -1831,7 +1908,7 @@ PP(pp_entersub)
}
cx->blk_sub.savearray = GvAV(defgv);
cx->blk_sub.argarray = av;
- GvAV(defgv) = cx->blk_sub.argarray;
+ GvAV(defgv) = (AV*)SvREFCNT_inc(av);
++MARK;
if (items > AvMAX(av) + 1) {
@@ -1860,44 +1937,85 @@ PP(pp_entersub)
}
}
+void
+sub_crush_depth(cv)
+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)
{
dSP;
SV** svp;
I32 elem = POPi;
- AV *av = (AV*)POPs;
- I32 lval = op->op_flags & OPf_MOD;
+ AV* av = (AV*)POPs;
+ U32 lval = op->op_flags & OPf_MOD;
+ U32 defer = (op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
if (elem > 0)
elem -= curcop->cop_arybase;
if (SvTYPE(av) != SVt_PVAV)
RETPUSHUNDEF;
- svp = av_fetch(av, elem, lval);
+ svp = av_fetch(av, elem, lval && !defer);
if (lval) {
- if (!svp || *svp == &sv_undef)
- DIE(no_aelem, elem);
+ if (!svp || *svp == &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 (op->op_private & OPpLVAL_INTRO)
save_svref(svp);
- else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
- provide_ref(op, *svp);
+ else if (op->op_private & OPpDEREF)
+ vivify_ref(*svp, op->op_private & OPpDEREF);
}
PUSHs(svp ? *svp : &sv_undef);
RETURN;
}
void
-provide_ref(op, sv)
-OP* op;
+vivify_ref(sv, to_what)
SV* sv;
+U32 to_what;
{
if (SvGMAGICAL(sv))
mg_get(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
croak(no_modify);
- (void)SvUPGRADE(sv, SVt_RV);
- SvRV(sv) = (op->op_private & OPpDEREF_HV ?
- (SV*)newHV() : (SV*)newAV());
+ 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(0);
+ break;
+ case OPpDEREF_AV:
+ SvRV(sv) = (SV*)newAV();
+ break;
+ case OPpDEREF_HV:
+ SvRV(sv) = (SV*)newHV();
+ break;
+ }
SvROK_on(sv);
SvSETMAGIC(sv);
}
@@ -1909,60 +2027,72 @@ PP(pp_method)
SV* sv;
SV* ob;
GV* gv;
- SV* nm;
+ HV* stash;
+ char* name;
+ char* packname;
+ STRLEN packlen;
+
+ if (SvROK(TOPs)) {
+ sv = SvRV(TOPs);
+ if (SvTYPE(sv) == SVt_PVCV) {
+ SETs(sv);
+ RETURN;
+ }
+ }
- nm = TOPs;
+ name = SvPV(TOPs, na);
sv = *(stack_base + TOPMARK + 1);
- gv = 0;
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvROK(sv))
ob = (SV*)SvRV(sv);
else {
GV* iogv;
- char* packname = 0;
+ packname = Nullch;
if (!SvOK(sv) ||
- !(packname = SvPV(sv, na)) ||
+ !(packname = SvPV(sv, packlen)) ||
!(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
- char *name = SvPV(nm, na);
- HV *stash;
- if (!packname || !isALPHA(*packname))
-DIE("Can't call method \"%s\" without a package or object reference", name);
- if (!(stash = gv_stashpv(packname, FALSE))) {
- if (gv_stashpv("UNIVERSAL", FALSE))
- stash = gv_stashpv(packname, TRUE);
- else
- DIE("Can't call method \"%s\" in empty package \"%s\"",
- name, packname);
- }
- gv = gv_fetchmethod(stash,name);
- if (!gv)
- DIE("Can't locate object method \"%s\" via package \"%s\"",
- name, packname);
- SETs(gv);
- RETURN;
+ if (!packname || !isIDFIRST(*packname))
+ DIE("Can't call method \"%s\" without a package or object reference", name);
+ stash = gv_stashpvn(packname, packlen, TRUE);
+ goto fetch;
}
- *(stack_base + TOPMARK + 1) = sv_2mortal(newRV(iogv));
+ *(stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
}
- if (!ob || !SvOBJECT(ob)) {
- char *name = SvPV(nm, na);
+ if (!ob || !SvOBJECT(ob))
DIE("Can't call method \"%s\" on unblessed reference", name);
- }
- if (!gv) { /* nothing cached */
- char *name = SvPV(nm, na);
- gv = gv_fetchmethod(SvSTASH(ob),name);
- if (!gv)
- DIE("Can't locate object method \"%s\" via package \"%s\"",
- name, HvNAME(SvSTASH(ob)));
- }
+ stash = SvSTASH(ob);
+
+ fetch:
+ gv = gv_fetchmethod(stash, name);
+ if (!gv) {
+ char* leaf = name;
+ char* sep = Nullch;
+ char* p;
- SETs(gv);
+ 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 ? 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/gnu/usr.bin/perl/pp_sys.c b/gnu/usr.bin/perl/pp_sys.c
index ba1f105a06b..d574b2e8528 100644
--- a/gnu/usr.bin/perl/pp_sys.c
+++ b/gnu/usr.bin/perl/pp_sys.c
@@ -1,6 +1,6 @@
/* pp_sys.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -17,21 +17,17 @@
#include "EXTERN.h"
#include "perl.h"
-/* XXX Omit this -- it causes too much grief on mixed systems.
- Next time, I should force broken systems to unset i_unistd in
- hint files.
-*/
-#if 0
-# ifdef I_UNISTD
-# include <unistd.h>
-# endif
+/* XXX If this causes problems, set i_unistd=undef in the hint file. */
+#ifdef I_UNISTD
+# include <unistd.h>
#endif
-/* Put this after #includes because fork and vfork prototypes may
- conflict.
-*/
-#ifndef HAS_VFORK
-# define vfork fork
+#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 */
@@ -46,11 +42,9 @@
#ifdef HAS_SELECT
#ifdef I_SYS_SELECT
-#ifndef I_SYS_TIME
#include <sys/select.h>
#endif
#endif
-#endif
#ifdef HOST_NOT_FOUND
extern int h_errno;
@@ -77,7 +71,11 @@ extern int h_errno;
#endif
#ifdef I_UTIME
-#include <utime.h>
+# ifdef _MSC_VER
+# include <sys/utime.h>
+# else
+# include <utime.h>
+# endif
#endif
#ifdef I_FCNTL
#include <fcntl.h>
@@ -86,25 +84,111 @@ extern int h_errno;
#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 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)
{
dSP; dTARGET;
- FILE *fp;
+ PerlIO *fp;
char *tmps = POPp;
+ I32 gimme = GIMME_V;
+
TAINT_PROPER("``");
fp = my_popen(tmps, "r");
if (fp) {
- sv_setpv(TARG, ""); /* note that this preserves previous buffer */
- if (GIMME == G_SCALAR) {
+ if (gimme == G_VOID) {
+ while (PerlIO_read(fp, tokenbuf, sizeof tokenbuf) > 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;
@@ -120,13 +204,15 @@ PP(pp_backtick)
SvLEN_set(sv, SvCUR(sv)+1);
Renew(SvPVX(sv), SvLEN(sv), char);
}
+ SvTAINTED_on(sv);
}
}
- statusvalue = FIXSTATUS(my_pclose(fp));
+ STATUS_NATIVE_SET(my_pclose(fp));
+ TAINT; /* "I believe that this is not gratuitous!" */
}
else {
- statusvalue = -1;
- if (GIMME == G_SCALAR)
+ STATUS_NATIVE_SET(-1);
+ if (gimme == G_SCALAR)
RETPUSHUNDEF;
}
@@ -138,6 +224,17 @@ PP(pp_glob)
OP *result;
ENTER;
+#ifndef VMS
+ if (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(last_in_gv); /* We don't want this to be permanent. */
last_in_gv = (GV*)*stack_sp--;
@@ -147,7 +244,7 @@ PP(pp_glob)
#ifndef CSH
*SvPVX(rs) = '\n';
#endif /* !CSH */
-#endif /* !MSDOS */
+#endif /* !DOSISH */
result = do_readline();
LEAVE;
@@ -229,16 +326,18 @@ PP(pp_open)
if (MAXARG > 1)
sv = POPs;
- else if (SvTYPE(TOPs) == SVt_PVGV)
- sv = GvSV(TOPs);
- else
+ 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, 0, 0, Nullfp)) {
- IoLINES(GvIOp(gv)) = 0;
+ if (do_open(gv, tmps, len, FALSE, 0, 0, Nullfp))
PUSHi( (I32)forkprocess );
- }
else if (forkprocess == 0) /* we are a new child */
PUSHi(0);
else
@@ -256,7 +355,7 @@ PP(pp_close)
else
gv = (GV*)POPs;
EXTEND(SP, 1);
- PUSHs( do_close(gv, TRUE) ? &sv_yes : &sv_no );
+ PUSHs(boolSV(do_close(gv, TRUE)));
RETURN;
}
@@ -289,16 +388,16 @@ PP(pp_pipe_op)
if (pipe(fd) < 0)
goto badexit;
- IoIFP(rstio) = fdopen(fd[0], "r");
- IoOFP(wstio) = fdopen(fd[1], "w");
+ 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)) fclose(IoIFP(rstio));
+ if (IoIFP(rstio)) PerlIO_close(IoIFP(rstio));
else close(fd[0]);
- if (IoOFP(wstio)) fclose(IoOFP(wstio));
+ if (IoOFP(wstio)) PerlIO_close(IoOFP(wstio));
else close(fd[1]);
goto badexit;
}
@@ -317,13 +416,13 @@ PP(pp_fileno)
dSP; dTARGET;
GV *gv;
IO *io;
- FILE *fp;
+ PerlIO *fp;
if (MAXARG < 1)
RETPUSHUNDEF;
gv = (GV*)POPs;
if (!gv || !(io = GvIO(gv)) || !(fp = IoIFP(io)))
RETPUSHUNDEF;
- PUSHi(fileno(fp));
+ PUSHi(PerlIO_fileno(fp));
RETURN;
}
@@ -352,7 +451,7 @@ PP(pp_binmode)
dSP;
GV *gv;
IO *io;
- FILE *fp;
+ PerlIO *fp;
if (MAXARG < 1)
RETPUSHUNDEF;
@@ -361,23 +460,42 @@ PP(pp_binmode)
EXTEND(SP, 1);
if (!(io = GvIO(gv)) || !(fp = IoIFP(io)))
- RETSETUNDEF;
+ RETPUSHUNDEF;
#ifdef DOSISH
#ifdef atarist
- if (!Fflush(fp) && (fp->_flag |= _IOBIN))
+ if (!PerlIO_flush(fp) && (fp->_flag |= _IOBIN))
RETPUSHYES;
else
RETPUSHUNDEF;
#else
- if (setmode(fileno(fp), OP_BINARY) != -1)
+ if (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);
+ fp->flags |= _F_BIN;
+#endif
RETPUSHYES;
+ }
else
RETPUSHUNDEF;
#endif
#else
+#if defined(USEMYBINMODE)
+ if (my_binmode(fp,IoTYPE(io)) != NULL)
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+#else
RETPUSHYES;
#endif
+#endif
+
}
PP(pp_tie)
@@ -391,6 +509,7 @@ PP(pp_tie)
SV **mark = stack_base + ++*markstack_ptr; /* reuse in entersub */
I32 markoff = mark - stack_base - 1;
char *methname;
+ bool oldcatch = CATCH_GET;
varsv = mark[0];
if (SvTYPE(varsv) == SVt_PVHV)
@@ -403,26 +522,30 @@ PP(pp_tie)
methname = "TIESCALAR";
stash = gv_stashsv(mark[1], FALSE);
- if (!stash || !(gv = gv_fetchmethod(stash, methname)) || !GvCV(gv))
+ if (!stash || !(gv = gv_fetchmethod(stash, methname)))
DIE("Can't locate object method \"%s\" via package \"%s\"",
methname, SvPV(mark[1],na));
Zero(&myop, 1, BINOP);
myop.op_last = (OP *) &myop;
myop.op_next = Nullop;
- myop.op_flags = OPf_KNOW|OPf_STACKED;
+ myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+ CATCH_SET(TRUE);
ENTER;
SAVESPTR(op);
op = (OP *) &myop;
+ if (PERLDB_SUB && curstash != debstash)
+ op->op_private |= OPpENTERSUB_DB;
- XPUSHs(gv);
+ XPUSHs((SV*)GvCV(gv));
PUTBACK;
if (op = pp_entersub())
runops();
SPAGAIN;
+ CATCH_SET(oldcatch);
sv = TOPs;
if (sv_isobject(sv)) {
if (SvTYPE(varsv) == SVt_PVHV || SvTYPE(varsv) == SVt_PVAV) {
@@ -443,11 +566,29 @@ PP(pp_tie)
PP(pp_untie)
{
dSP;
- if (SvTYPE(TOPs) == SVt_PVHV || SvTYPE(TOPs) == SVt_PVAV)
- sv_unmagic(TOPs, 'P');
+ SV * sv ;
+
+ sv = POPs;
+
+ if (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(TOPs, 'q');
- RETSETYES;
+ sv_unmagic(sv, 'q');
+ RETPUSHYES;
}
PP(pp_tied)
@@ -481,28 +622,32 @@ PP(pp_dbmopen)
GV *gv;
BINOP myop;
SV *sv;
+ bool oldcatch = CATCH_GET;
hv = (HV*)POPs;
sv = sv_mortalcopy(&sv_no);
sv_setpv(sv, "AnyDBM_File");
stash = gv_stashsv(sv, FALSE);
- if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv)) {
+ if (!stash || !(gv = gv_fetchmethod(stash, "TIEHASH"))) {
PUTBACK;
perl_require_pv("AnyDBM_File.pm");
SPAGAIN;
- if (!(gv = gv_fetchmethod(stash, "TIEHASH")) || !GvCV(gv))
+ if (!(gv = gv_fetchmethod(stash, "TIEHASH")))
DIE("No dbm on this machine");
}
Zero(&myop, 1, BINOP);
myop.op_last = (OP *) &myop;
myop.op_next = Nullop;
- myop.op_flags = OPf_KNOW|OPf_STACKED;
+ myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+ CATCH_SET(TRUE);
ENTER;
SAVESPTR(op);
op = (OP *) &myop;
+ if (PERLDB_SUB && curstash != debstash)
+ op->op_private |= OPpENTERSUB_DB;
PUTBACK;
pp_pushmark();
@@ -514,7 +659,7 @@ PP(pp_dbmopen)
else
PUSHs(sv_2mortal(newSViv(O_RDWR)));
PUSHs(right);
- PUSHs(gv);
+ PUSHs((SV*)GvCV(gv));
PUTBACK;
if (op = pp_entersub())
@@ -531,7 +676,7 @@ PP(pp_dbmopen)
PUSHs(left);
PUSHs(sv_2mortal(newSViv(O_RDONLY)));
PUSHs(right);
- PUSHs(gv);
+ PUSHs((SV*)GvCV(gv));
PUTBACK;
if (op = pp_entersub())
@@ -539,6 +684,7 @@ PP(pp_dbmopen)
SPAGAIN;
}
+ CATCH_SET(oldcatch);
if (sv_isobject(TOPs))
sv_magic((SV*)hv, TOPs, 'P', Nullch, 0);
LEAVE;
@@ -588,7 +734,7 @@ PP(pp_sselect)
}
#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
-#ifdef __linux__
+#if defined(__linux__) || defined(OS2)
growsize = sizeof(fd_set);
#else
growsize = maxlen; /* little endians can use vecs directly */
@@ -710,12 +856,14 @@ PP(pp_select)
if (! hv)
XPUSHs(&sv_undef);
else {
- GV **gvp = hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
- if (gvp && *gvp == egv)
- gv_efullname(TARG, defoutgv);
- else
- sv_setsv(TARG, sv_2mortal(newRV(egv)));
- XPUSHTARG;
+ GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
+ if (gvp && *gvp == egv) {
+ gv_efullname3(TARG, defoutgv, Nullch);
+ XPUSHTARG;
+ }
+ else {
+ XPUSHs(sv_2mortal(newRV((SV*)egv)));
+ }
}
if (newdefout) {
@@ -731,6 +879,7 @@ PP(pp_getc)
{
dSP; dTARGET;
GV *gv;
+ MAGIC *mg;
if (MAXARG <= 0)
gv = stdingv;
@@ -738,11 +887,25 @@ PP(pp_getc)
gv = (GV*)POPs;
if (!gv)
gv = argvgv;
+
+ if (SvMAGICAL(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_IF(1);
+ TAINT;
sv_setpv(TARG, " ");
- *SvPVX(TARG) = getc(IoIFP(GvIOp(gv))); /* should never be EOF */
+ *SvPVX(TARG) = PerlIO_getc(IoIFP(GvIOp(gv))); /* should never be EOF */
PUSHTARG;
RETURN;
}
@@ -759,7 +922,7 @@ GV *gv;
OP *retop;
{
register CONTEXT *cx;
- I32 gimme = GIMME;
+ I32 gimme = GIMME_V;
AV* padlist = CvPADLIST(cv);
SV** svp = AvARRAY(padlist);
@@ -802,17 +965,18 @@ PP(pp_enterwrite)
fgv = gv;
cv = GvFORM(fgv);
-
if (!cv) {
if (fgv) {
SV *tmpsv = sv_newmortal();
- gv_efullname(tmpsv, gv);
+ gv_efullname3(tmpsv, fgv, Nullch);
DIE("Undefined format \"%s\" called",SvPVX(tmpsv));
}
DIE("Not a format reference");
}
- IoFLAGS(io) &= ~IOf_DIDTOP;
+ if (CvCLONE(cv))
+ cv = (CV*)sv_2mortal((SV*)cv_clone(cv));
+ IoFLAGS(io) &= ~IOf_DIDTOP;
return doform(cv,gv,op->op_next);
}
@@ -821,13 +985,13 @@ PP(pp_leavewrite)
dSP;
GV *gv = cxstack[cxstack_ix].blk_sub.gv;
register IO *io = GvIOp(gv);
- FILE *ofp = IoOFP(io);
- FILE *fp;
+ PerlIO *ofp = IoOFP(io);
+ PerlIO *fp;
SV **newsp;
I32 gimme;
register CONTEXT *cx;
- DEBUG_f(fprintf(stderr,"left=%ld, todo=%ld\n",
+ DEBUG_f(PerlIO_printf(Perl_debug_log, "left=%ld, todo=%ld\n",
(long)IoLINES_LEFT(io), (long)FmLINES(formtarget)));
if (IoLINES_LEFT(io) < FmLINES(formtarget) &&
formtarget != toptarget)
@@ -836,16 +1000,16 @@ PP(pp_leavewrite)
CV *cv;
if (!IoTOP_GV(io)) {
GV *topgv;
- char tmpbuf[256];
+ SV *topname;
if (!IoTOP_NAME(io)) {
if (!IoFMT_NAME(io))
IoFMT_NAME(io) = savepv(GvNAME(gv));
- sprintf(tmpbuf, "%s_TOP", IoFMT_NAME(io));
- topgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVFM);
+ 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(tmpbuf);
+ IoTOP_NAME(io) = savepv(SvPVX(topname));
else
IoTOP_NAME(io) = savepv("top");
}
@@ -868,13 +1032,13 @@ PP(pp_leavewrite)
s++;
}
if (s) {
- fwrite1(SvPVX(formtarget), s - SvPVX(formtarget), 1, ofp);
+ PerlIO_write(ofp, SvPVX(formtarget), s - SvPVX(formtarget));
sv_chop(formtarget, s);
FmLINES(formtarget) -= IoLINES_LEFT(io);
}
}
if (IoLINES_LEFT(io) >= 0 && IoPAGE(io) > 0)
- fwrite1(SvPVX(formfeed), SvCUR(formfeed), 1, ofp);
+ PerlIO_write(ofp, SvPVX(formfeed), SvCUR(formfeed));
IoLINES_LEFT(io) = IoPAGE_LEN(io);
IoPAGE(io)++;
formtarget = toptarget;
@@ -885,9 +1049,11 @@ PP(pp_leavewrite)
cv = GvFORM(fgv);
if (!cv) {
SV *tmpsv = sv_newmortal();
- gv_efullname(tmpsv, fgv);
+ 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,op);
}
@@ -911,15 +1077,15 @@ PP(pp_leavewrite)
if (dowarn)
warn("page overflow");
}
- if (!fwrite1(SvPVX(formtarget), 1, SvCUR(formtarget), ofp) ||
- ferror(fp))
+ if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) ||
+ PerlIO_error(fp))
PUSHs(&sv_no);
else {
FmLINES(formtarget) = 0;
SvCUR_set(formtarget, 0);
*SvEND(formtarget) = '\0';
if (IoFLAGS(io) & IOf_FLUSH)
- (void)Fflush(fp);
+ (void)PerlIO_flush(fp);
PUSHs(&sv_yes);
}
}
@@ -933,16 +1099,39 @@ PP(pp_prtf)
dSP; dMARK; dORIGMARK;
GV *gv;
IO *io;
- FILE *fp;
- SV *sv = NEWSV(0,0);
+ PerlIO *fp;
+ SV *sv;
+ MAGIC *mg;
if (op->op_flags & OPf_STACKED)
gv = (GV*)*++MARK;
else
gv = defoutgv;
+
+ if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
+ if (MARK == ORIGMARK) {
+ EXTEND(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 (dowarn) {
- gv_fullname(sv,gv);
+ gv_fullname3(sv, gv, Nullch);
warn("Filehandle %s never opened", SvPV(sv,na));
}
SETERRNO(EBADF,RMS$_IFI);
@@ -950,7 +1139,7 @@ PP(pp_prtf)
}
else if (!(fp = IoOFP(io))) {
if (dowarn) {
- gv_fullname(sv,gv);
+ gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
warn("Filehandle %s opened only for input", SvPV(sv,na));
else
@@ -960,12 +1149,18 @@ PP(pp_prtf)
goto just_say_no;
}
else {
+#ifdef USE_LOCALE_NUMERIC
+ if (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 (Fflush(fp) == EOF)
+ if (PerlIO_flush(fp) == EOF)
goto just_say_no;
}
SvREFCNT_dec(sv);
@@ -1015,15 +1210,35 @@ PP(pp_sysread)
GV *gv;
IO *io;
char *buffer;
- int length;
- int bufsize;
+ SSize_t length;
+ Sock_size_t bufsize;
SV *bufsv;
STRLEN blen;
+ MAGIC *mg;
gv = (GV*)*++MARK;
+ if ((op->op_type == OP_READ || op->op_type == OP_SYSREAD) &&
+ SvMAGICAL(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)
@@ -1038,20 +1253,27 @@ PP(pp_sysread)
goto say_undef;
#ifdef HAS_SOCKET
if (op->op_type == OP_RECV) {
- bufsize = sizeof buf;
+ char namebuf[MAXPATHLEN];
+#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
+ bufsize = sizeof (struct sockaddr_in);
+#else
+ bufsize = sizeof namebuf;
+#endif
buffer = SvGROW(bufsv, length+1);
- length = recvfrom(fileno(IoIFP(io)), buffer, length, offset,
- (struct sockaddr *)buf, &bufsize);
+ /* 'offset' means 'flags' here */
+ length = 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);
- if (tainting)
- sv_magic(bufsv, Nullsv, 't', Nullch, 0);
+ /* 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, buf, bufsize);
+ sv_setpvn(TARG, namebuf, bufsize);
PUSHs(TARG);
RETURN;
}
@@ -1059,28 +1281,43 @@ PP(pp_sysread)
if (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 (op->op_type == OP_SYSREAD) {
- length = read(fileno(IoIFP(io)), buffer+offset, length);
+ length = read(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
}
else
#ifdef HAS_SOCKET__bad_code_maybe
if (IoTYPE(io) == 's') {
- bufsize = sizeof buf;
- length = recvfrom(fileno(IoIFP(io)), buffer+offset, length, 0,
- (struct sockaddr *)buf, &bufsize);
+ char namebuf[MAXPATHLEN];
+#if defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)
+ bufsize = sizeof (struct sockaddr_in);
+#else
+ bufsize = sizeof namebuf;
+#endif
+ length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
+ (struct sockaddr *)namebuf, &bufsize);
}
else
#endif
- length = fread(buffer+offset, 1, length, IoIFP(io));
+ length = PerlIO_read(IoIFP(io), buffer+offset, length);
if (length < 0)
goto say_undef;
SvCUR_set(bufsv, length+offset);
*SvEND(bufsv) = '\0';
(void)SvPOK_only(bufsv);
SvSETMAGIC(bufsv);
- if (tainting)
- sv_magic(bufsv, Nullsv, 't', Nullch, 0);
+ /* 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;
@@ -1126,24 +1363,31 @@ PP(pp_send)
}
}
else if (op->op_type == OP_SYSWRITE) {
- if (MARK < SP)
+ if (MARK < SP) {
offset = SvIVx(*++MARK);
- else
+ 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 = write(fileno(IoIFP(io)), buffer+offset, length);
+ length = write(PerlIO_fileno(IoIFP(io)), buffer+offset, length);
}
#ifdef HAS_SOCKET
else if (SP > MARK) {
char *sockbuf;
STRLEN mlen;
sockbuf = SvPVx(*++MARK, mlen);
- length = sendto(fileno(IoIFP(io)), buffer, blen, length,
+ length = sendto(PerlIO_fileno(IoIFP(io)), buffer, blen, length,
(struct sockaddr *)sockbuf, mlen);
}
else
- length = send(fileno(IoIFP(io)), buffer, blen, length);
+ length = send(PerlIO_fileno(IoIFP(io)), buffer, blen, length);
+
#else
else
DIE(no_sock_func, "send");
@@ -1173,7 +1417,7 @@ PP(pp_eof)
gv = last_in_gv;
else
gv = last_in_gv = (GV*)POPs;
- PUSHs(!gv || do_eof(gv) ? &sv_yes : &sv_no);
+ PUSHs(boolSV(!gv || do_eof(gv)));
RETURN;
}
@@ -1192,13 +1436,25 @@ PP(pp_tell)
PP(pp_seek)
{
+ return pp_sysseek(ARGS);
+}
+
+PP(pp_sysseek)
+{
dSP;
GV *gv;
int whence = POPi;
long offset = POPl;
gv = last_in_gv = (GV*)POPs;
- PUSHs( do_seek(gv, offset, whence) ? &sv_yes : &sv_no );
+ if (op->op_type == OP_SEEK)
+ PUSHs(boolSV(do_seek(gv, offset, whence)));
+ else {
+ long n = do_sysseek(gv, offset, whence);
+ PUSHs((n < 0) ? &sv_undef
+ : sv_2mortal(n ? newSViv((IV)n)
+ : newSVpv(zero_but_true, ZBTLEN)));
+ }
RETURN;
}
@@ -1211,34 +1467,49 @@ PP(pp_truncate)
SETERRNO(0,0);
#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
-#ifdef HAS_TRUNCATE
- if (op->op_flags & OPf_SPECIAL) {
- tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO);
- if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
- ftruncate(fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
- result = 0;
- }
- else if (truncate(POPp, len) < 0)
- result = 0;
-#else
if (op->op_flags & OPf_SPECIAL) {
- tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO);
+ tmpgv = gv_fetchpv(POPp, FALSE, SVt_PVIO);
+ do_ftruncate:
+ TAINT_PROPER("truncate");
if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
- chsize(fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+#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 {
- int tmpfd;
+ 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;
+ }
- if ((tmpfd = open(POPp, 0)) < 0)
+ name = SvPV(sv, na);
+ TAINT_PROPER("truncate");
+#ifdef HAS_TRUNCATE
+ if (truncate(name, len) < 0)
result = 0;
- else {
- if (chsize(tmpfd, len) < 0)
+#else
+ {
+ int tmpfd;
+ if ((tmpfd = open(name, O_RDWR)) < 0)
result = 0;
- close(tmpfd);
+ else {
+ if (my_chsize(tmpfd, len) < 0)
+ result = 0;
+ close(tmpfd);
+ }
}
- }
#endif
+ }
if (result)
RETPUSHYES;
@@ -1262,7 +1533,7 @@ PP(pp_ioctl)
unsigned int func = U_I(POPn);
int optype = op->op_type;
char *s;
- int retval;
+ IV retval;
GV *gv = (GV*)POPs;
IO *io = GvIOn(gv);
@@ -1273,45 +1544,38 @@ PP(pp_ioctl)
if (SvPOK(argsv) || !SvNIOK(argsv)) {
STRLEN len;
+ STRLEN need;
s = SvPV_force(argsv, len);
- retval = IOCPARM_LEN(func);
- if (len < retval) {
- s = Sv_Grow(argsv, retval+1);
- SvCUR_set(argsv, retval);
+ 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);
-#ifdef DOSISH
- s = (char*)(long)retval; /* ouch */
-#else
s = (char*)retval; /* ouch */
-#endif
}
TAINT_PROPER(optype == OP_IOCTL ? "ioctl" : "fcntl");
if (optype == OP_IOCTL)
#ifdef HAS_IOCTL
- retval = ioctl(fileno(IoIFP(io)), func, s);
+ retval = ioctl(PerlIO_fileno(IoIFP(io)), func, s);
#else
DIE("ioctl is not implemented");
#endif
else
-#if defined(DOSISH) && !defined(OS2)
- DIE("fcntl is not implemented");
+#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
-# ifdef HAS_FCNTL
-# if defined(OS2) && defined(__EMX__)
- retval = fcntl(fileno(IoIFP(io)), func, (int)s);
-# else
- retval = fcntl(fileno(IoIFP(io)), func, s);
-# endif
-# else
DIE("fcntl is not implemented");
-# endif
#endif
if (SvPOK(argsv)) {
@@ -1328,7 +1592,7 @@ PP(pp_ioctl)
PUSHi(retval);
}
else {
- PUSHp("0 but true", 10);
+ PUSHp(zero_but_true, ZBTLEN);
}
RETURN;
}
@@ -1339,13 +1603,9 @@ PP(pp_flock)
I32 value;
int argtype;
GV *gv;
- FILE *fp;
-
-#if !defined(HAS_FLOCK) && defined(HAS_LOCKF)
-# define flock lockf_emulate_flock
-#endif
+ PerlIO *fp;
-#if defined(HAS_FLOCK) || defined(flock)
+#ifdef FLOCK
argtype = POPi;
if (MAXARG <= 0)
gv = last_in_gv;
@@ -1356,7 +1616,8 @@ PP(pp_flock)
else
fp = Nullfp;
if (fp) {
- value = (I32)(flock(fileno(fp), argtype) >= 0);
+ (void)PerlIO_flush(fp);
+ value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
}
else
value = 0;
@@ -1395,12 +1656,12 @@ PP(pp_socket)
fd = socket(domain, type, protocol);
if (fd < 0)
RETPUSHUNDEF;
- IoIFP(io) = fdopen(fd, "r"); /* stdio gets confused about sockets */
- IoOFP(io) = fdopen(fd, "w");
+ 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)) fclose(IoIFP(io));
- if (IoOFP(io)) fclose(IoOFP(io));
+ if (IoIFP(io)) PerlIO_close(IoIFP(io));
+ if (IoOFP(io)) PerlIO_close(IoOFP(io));
if (!IoIFP(io) && !IoOFP(io)) close(fd);
RETPUSHUNDEF;
}
@@ -1439,18 +1700,18 @@ PP(pp_sockpair)
TAINT_PROPER("socketpair");
if (socketpair(domain, type, protocol, fd) < 0)
RETPUSHUNDEF;
- IoIFP(io1) = fdopen(fd[0], "r");
- IoOFP(io1) = fdopen(fd[0], "w");
+ IoIFP(io1) = PerlIO_fdopen(fd[0], "r");
+ IoOFP(io1) = PerlIO_fdopen(fd[0], "w");
IoTYPE(io1) = 's';
- IoIFP(io2) = fdopen(fd[1], "r");
- IoOFP(io2) = fdopen(fd[1], "w");
+ 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)) fclose(IoIFP(io1));
- if (IoOFP(io1)) fclose(IoOFP(io1));
+ if (IoIFP(io1)) PerlIO_close(IoIFP(io1));
+ if (IoOFP(io1)) PerlIO_close(IoOFP(io1));
if (!IoIFP(io1) && !IoOFP(io1)) close(fd[0]);
- if (IoIFP(io2)) fclose(IoIFP(io2));
- if (IoOFP(io2)) fclose(IoOFP(io2));
+ if (IoIFP(io2)) PerlIO_close(IoIFP(io2));
+ if (IoOFP(io2)) PerlIO_close(IoOFP(io2));
if (!IoIFP(io2) && !IoOFP(io2)) close(fd[1]);
RETPUSHUNDEF;
}
@@ -1476,7 +1737,7 @@ PP(pp_bind)
addr = SvPV(addrsv, len);
TAINT_PROPER("bind");
- if (bind(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
+ if (bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
@@ -1506,7 +1767,7 @@ PP(pp_connect)
addr = SvPV(addrsv, len);
TAINT_PROPER("connect");
- if (connect(fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
+ if (connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len) >= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
@@ -1532,7 +1793,7 @@ PP(pp_listen)
if (!io || !IoIFP(io))
goto nuts;
- if (listen(fileno(IoIFP(io)), backlog) >= 0)
+ if (listen(PerlIO_fileno(IoIFP(io)), backlog) >= 0)
RETPUSHYES;
else
RETPUSHUNDEF;
@@ -1556,7 +1817,7 @@ PP(pp_accept)
register IO *nstio;
register IO *gstio;
struct sockaddr saddr; /* use a struct to avoid alignment problems */
- int len = sizeof saddr;
+ Sock_size_t len = sizeof saddr;
int fd;
ggv = (GV*)POPs;
@@ -1575,15 +1836,15 @@ PP(pp_accept)
if (IoIFP(nstio))
do_close(ngv, FALSE);
- fd = accept(fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
+ fd = accept(PerlIO_fileno(IoIFP(gstio)), (struct sockaddr *)&saddr, &len);
if (fd < 0)
goto badexit;
- IoIFP(nstio) = fdopen(fd, "r");
- IoOFP(nstio) = fdopen(fd, "w");
+ IoIFP(nstio) = PerlIO_fdopen(fd, "r");
+ IoOFP(nstio) = PerlIO_fdopen(fd, "w");
IoTYPE(nstio) = 's';
if (!IoIFP(nstio) || !IoOFP(nstio)) {
- if (IoIFP(nstio)) fclose(IoIFP(nstio));
- if (IoOFP(nstio)) fclose(IoOFP(nstio));
+ if (IoIFP(nstio)) PerlIO_close(IoIFP(nstio));
+ if (IoOFP(nstio)) PerlIO_close(IoOFP(nstio));
if (!IoIFP(nstio) && !IoOFP(nstio)) close(fd);
goto badexit;
}
@@ -1615,7 +1876,7 @@ PP(pp_shutdown)
if (!io || !IoIFP(io))
goto nuts;
- PUSHi( shutdown(fileno(IoIFP(io)), how) >= 0 );
+ PUSHi( shutdown(PerlIO_fileno(IoIFP(io)), how) >= 0 );
RETURN;
nuts:
@@ -1648,7 +1909,7 @@ PP(pp_ssockopt)
unsigned int lvl;
GV *gv;
register IO *io;
- int aint;
+ Sock_size_t len;
if (optype == OP_GSOCKOPT)
sv = sv_2mortal(NEWSV(22, 257));
@@ -1662,31 +1923,33 @@ PP(pp_ssockopt)
if (!io || !IoIFP(io))
goto nuts;
- fd = fileno(IoIFP(io));
+ fd = PerlIO_fileno(IoIFP(io));
switch (optype) {
case OP_GSOCKOPT:
SvGROW(sv, 257);
(void)SvPOK_only(sv);
SvCUR_set(sv,256);
*SvEND(sv) ='\0';
- aint = SvCUR(sv);
- if (getsockopt(fd, lvl, optname, SvPVX(sv), &aint) < 0)
+ len = SvCUR(sv);
+ if (getsockopt(fd, lvl, optname, SvPVX(sv), &len) < 0)
goto nuts2;
- SvCUR_set(sv,aint);
+ SvCUR_set(sv, len);
*SvEND(sv) ='\0';
PUSHs(sv);
break;
case OP_SSOCKOPT: {
- STRLEN len = 0;
- char *buf = 0;
- if (SvPOKp(sv))
- buf = SvPV(sv, len);
+ char *buf;
+ int aint;
+ if (SvPOKp(sv)) {
+ buf = SvPV(sv, na);
+ len = na;
+ }
else if (SvOK(sv)) {
aint = (int)SvIV(sv);
buf = (char*)&aint;
len = sizeof(int);
}
- if (setsockopt(fd, lvl, optname, buf, (int)len) < 0)
+ if (setsockopt(fd, lvl, optname, buf, len) < 0)
goto nuts2;
PUSHs(&sv_yes);
}
@@ -1724,28 +1987,45 @@ PP(pp_getpeername)
int fd;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
- int aint;
+ Sock_size_t len;
if (!io || !IoIFP(io))
goto nuts;
sv = sv_2mortal(NEWSV(22, 257));
(void)SvPOK_only(sv);
- SvCUR_set(sv,256);
+ len = 256;
+ SvCUR_set(sv, len);
*SvEND(sv) ='\0';
- aint = SvCUR(sv);
- fd = fileno(IoIFP(io));
+ fd = PerlIO_fileno(IoIFP(io));
switch (optype) {
case OP_GETSOCKNAME:
- if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0)
+ if (getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
goto nuts2;
break;
case OP_GETPEERNAME:
- if (getpeername(fd, (struct sockaddr *)SvPVX(sv), &aint) < 0)
+ if (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;
}
- SvCUR_set(sv,aint);
+#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;
@@ -1773,6 +2053,7 @@ PP(pp_stat)
{
dSP;
GV *tmpgv;
+ I32 gimme;
I32 max = 13;
if (op->op_flags & OPf_REF) {
@@ -1782,13 +2063,10 @@ PP(pp_stat)
laststype = OP_STAT;
statgv = tmpgv;
sv_setpv(statname, "");
- if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
- Fstat(fileno(IoIFP(GvIOn(tmpgv))), &statcache) < 0) {
- max = 0;
- laststatval = -1;
- }
+ laststatval = (GvIO(tmpgv) && IoIFP(GvIOp(tmpgv))
+ ? Fstat(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), &statcache) : -1);
}
- else if (laststatval < 0)
+ if (laststatval < 0)
max = 0;
}
else {
@@ -1817,25 +2095,36 @@ PP(pp_stat)
}
}
- EXTEND(SP, 13);
- if (GIMME != G_ARRAY) {
- if (max)
- RETPUSHYES;
- else
- RETPUSHUNDEF;
+ 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)statcache.st_dev)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_ino)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_mode)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
+#ifdef USE_STAT_RDEV
PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
+#else
+ PUSHs(sv_2mortal(newSVpv("", 0)));
+#endif
PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
+#ifdef BIG_TIME
+ PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime)));
+ PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime)));
+ PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime)));
+#else
PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
+#endif
#ifdef USE_STAT_BLOCKS
PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
@@ -2113,16 +2402,20 @@ PP(pp_fttty)
dSP;
int fd;
GV *gv;
- char *tmps;
- if (op->op_flags & OPf_REF) {
+ char *tmps = Nullch;
+
+ if (op->op_flags & OPf_REF)
gv = cGVOP->op_gv;
- tmps = "";
- }
+ 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 = fileno(IoIFP(GvIOp(gv)));
- else if (isDIGIT(*tmps))
+ fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
+ else if (tmps && isDIGIT(*tmps))
fd = atoi(tmps);
else
RETPUSHUNDEF;
@@ -2148,11 +2441,21 @@ PP(pp_fttext)
STDCHAR tbuf[512];
register STDCHAR *s;
register IO *io;
- SV *sv;
+ register SV *sv;
+ GV *gv;
- if (op->op_flags & OPf_REF) {
+ if (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 (cGVOP->op_gv == defgv) {
+ if (gv == defgv) {
if (statgv)
io = GvIO(statgv);
else {
@@ -2161,30 +2464,34 @@ PP(pp_fttext)
}
}
else {
- statgv = cGVOP->op_gv;
+ statgv = gv;
+ laststatval = -1;
sv_setpv(statname, "");
io = GvIO(statgv);
}
if (io && IoIFP(io)) {
-#ifdef FILE_base
- Fstat(fileno(IoIFP(io)), &statcache);
+ if (! PerlIO_has_base(IoIFP(io)))
+ DIE("-T and -B not implemented on filehandles");
+ laststatval = Fstat(PerlIO_fileno(IoIFP(io)), &statcache);
+ if (laststatval < 0)
+ RETPUSHUNDEF;
if (S_ISDIR(statcache.st_mode)) /* handle NFS glitch */
if (op->op_type == OP_FTTEXT)
RETPUSHNO;
else
RETPUSHYES;
- if (FILE_cnt(IoIFP(io)) <= 0) {
- i = getc(IoIFP(io));
+ if (PerlIO_get_cnt(IoIFP(io)) <= 0) {
+ i = PerlIO_getc(IoIFP(io));
if (i != EOF)
- (void)ungetc(i, IoIFP(io));
+ (void)PerlIO_ungetc(IoIFP(io),i);
}
- if (FILE_cnt(IoIFP(io)) <= 0) /* null file is anything */
+ if (PerlIO_get_cnt(IoIFP(io)) <= 0) /* null file is anything */
RETPUSHYES;
- len = FILE_bufsiz(IoIFP(io));
- s = FILE_base(IoIFP(io));
-#else
- DIE("-T and -B not implemented on filehandles");
-#endif
+ 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 (dowarn)
@@ -2196,9 +2503,10 @@ PP(pp_fttext)
}
else {
sv = POPs;
+ really_filename:
statgv = Nullgv;
+ laststatval = -1;
sv_setpv(statname, SvPV(sv, na));
- really_filename:
#ifdef HAS_OPEN3
i = open(SvPV(sv, na), O_RDONLY, 0);
#else
@@ -2209,7 +2517,9 @@ PP(pp_fttext)
warn(warn_nl, "open");
RETPUSHUNDEF;
}
- Fstat(i, &statcache);
+ laststatval = Fstat(i, &statcache);
+ if (laststatval < 0)
+ RETPUSHUNDEF;
len = read(i, tbuf, 512);
(void)close(i);
if (len <= 0) {
@@ -2348,13 +2658,15 @@ PP(pp_rename)
#ifdef HAS_RENAME
anum = rename(tmps, tmps2);
#else
- if (same_dirent(tmps2, tmps)) /* can always rename to same name */
- anum = 1;
- else {
- if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
- (void)UNLINK(tmps2);
- if (!(anum = link(tmps, tmps2)))
- anum = UNLINK(tmps);
+ if (!(anum = Stat(tmps, &statbuf))) {
+ if (same_dirent(tmps2, tmps)) /* can always rename to same name */
+ anum = 1;
+ else {
+ if (euid || Stat(tmps2, &statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
+ (void)UNLINK(tmps2);
+ if (!(anum = link(tmps, tmps2)))
+ anum = UNLINK(tmps);
+ }
}
#endif
SETi( anum >= 0 );
@@ -2394,7 +2706,12 @@ PP(pp_readlink)
dSP; 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);
@@ -2414,54 +2731,68 @@ dooneliner(cmd, filename)
char *cmd;
char *filename;
{
- char mybuf[8192];
- char *s,
- *save_filename = filename;
+ char *save_filename = filename;
+ char *cmdline;
+ char *s;
+ PerlIO *myfp;
int anum = 1;
- FILE *myfp;
- strcpy(mybuf, cmd);
- strcat(mybuf, " ");
- for (s = mybuf+strlen(mybuf); *filename; ) {
+ 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 = my_popen(mybuf, "r");
+ myfp = my_popen(cmdline, "r");
+ Safefree(cmdline);
+
if (myfp) {
- *mybuf = '\0';
- s = fgets(mybuf, sizeof mybuf, myfp);
+ SV *tmpsv = sv_newmortal();
+ /* Need to save/restore 'rs' ?? */
+ s = sv_gets(tmpsv, myfp, 0);
(void)my_pclose(myfp);
if (s != Nullch) {
- for (errno = 1; errno < sys_nerr; errno++) {
+ int e;
+ for (e = 1;
#ifdef HAS_SYS_ERRLIST
- if (instr(mybuf, sys_errlist[errno])) /* you don't see this */
- return 0;
+ e <= sys_nerr
+#endif
+ ; e++)
+ {
+ /* you don't see this */
+ char *errmsg =
+#ifdef HAS_SYS_ERRLIST
+ sys_errlist[e]
#else
- char *errmsg; /* especially if it isn't there */
-
- if (instr(mybuf,
- (errmsg = strerror(errno)) ? errmsg : "NoErRoR"))
- return 0;
+ 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(mybuf, "cannot make"))
+ if (instr(s, "cannot make"))
SETERRNO(EEXIST,RMS$_FEX);
- else if (instr(mybuf, "existing file"))
+ else if (instr(s, "existing file"))
SETERRNO(EEXIST,RMS$_FEX);
- else if (instr(mybuf, "ile exists"))
+ else if (instr(s, "ile exists"))
SETERRNO(EEXIST,RMS$_FEX);
- else if (instr(mybuf, "non-exist"))
+ else if (instr(s, "non-exist"))
SETERRNO(ENOENT,RMS$_FNF);
- else if (instr(mybuf, "does not exist"))
+ else if (instr(s, "does not exist"))
SETERRNO(ENOENT,RMS$_FNF);
- else if (instr(mybuf, "not empty"))
+ else if (instr(s, "not empty"))
SETERRNO(EBUSY,SS$_DEVOFFLINE);
- else if (instr(mybuf, "cannot access"))
+ else if (instr(s, "cannot access"))
SETERRNO(EACCES,RMS$_PRV);
else
SETERRNO(EPERM,RMS$_PRV);
@@ -2494,7 +2825,7 @@ PP(pp_mkdir)
TAINT_PROPER("mkdir");
#ifdef HAS_MKDIR
- SETi( mkdir(tmps, mode) >= 0 );
+ SETi( Mkdir(tmps, mode) >= 0 );
#else
SETi( dooneliner("mkdir", tmps) );
oldumask = umask(0);
@@ -2557,6 +2888,7 @@ PP(pp_readdir)
register Direntry_t *dp;
GV *gv = (GV*)POPs;
register IO *io = GvIOn(gv);
+ SV *sv;
if (!io || !IoDIRP(io))
goto nope;
@@ -2565,20 +2897,28 @@ PP(pp_readdir)
/*SUPPRESS 560*/
while (dp = (Direntry_t *)readdir(IoDIRP(io))) {
#ifdef DIRNAMLEN
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
+ sv = newSVpv(dp->d_name, dp->d_namlen);
#else
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
+ sv = newSVpv(dp->d_name, 0);
#endif
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(sv);
+#endif
+ XPUSHs(sv_2mortal(sv));
}
}
else {
if (!(dp = (Direntry_t *)readdir(IoDIRP(io))))
goto nope;
#ifdef DIRNAMLEN
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, dp->d_namlen)));
+ sv = newSVpv(dp->d_name, dp->d_namlen);
#else
- XPUSHs(sv_2mortal(newSVpv(dp->d_name, 0)));
+ sv = newSVpv(dp->d_name, 0);
+#endif
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(sv);
#endif
+ XPUSHs(sv_2mortal(sv));
}
RETURN;
@@ -2696,19 +3036,19 @@ nope:
PP(pp_fork)
{
+#ifdef HAS_FORK
dSP; dTARGET;
int childpid;
GV *tmpgv;
EXTEND(SP, 1);
-#ifdef HAS_FORK
childpid = fork();
if (childpid < 0)
RETSETUNDEF;
if (!childpid) {
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$", TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv), (I32)getpid());
+ sv_setiv(GvSV(tmpgv), (IV)getpid());
hv_clear(pidstatus); /* no kids, so don't wait for 'em */
}
PUSHi(childpid);
@@ -2720,19 +3060,14 @@ PP(pp_fork)
PP(pp_wait)
{
+#if !defined(DOSISH) || defined(OS2)
dSP; dTARGET;
int childpid;
int argflags;
- I32 value;
- EXTEND(SP, 1);
-#ifdef HAS_WAIT
- childpid = wait(&argflags);
- if (childpid > 0)
- pidgone(childpid, argflags);
- value = (I32)childpid;
- statusvalue = FIXSTATUS(argflags);
- PUSHi(value);
+ childpid = wait4pid(-1, &argflags, 0);
+ STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+ XPUSHi(childpid);
RETURN;
#else
DIE(no_func, "Unsupported function wait");
@@ -2741,19 +3076,17 @@ PP(pp_wait)
PP(pp_waitpid)
{
+#if !defined(DOSISH) || defined(OS2)
dSP; dTARGET;
int childpid;
int optype;
int argflags;
- I32 value;
-#ifdef HAS_WAIT
optype = POPi;
childpid = TOPi;
childpid = wait4pid(childpid, &argflags, optype);
- value = (I32)childpid;
- statusvalue = FIXSTATUS(argflags);
- SETi(value);
+ STATUS_NATIVE_SET((childpid > 0) ? argflags : -1);
+ SETi(childpid);
RETURN;
#else
DIE(no_func, "Unsupported function wait");
@@ -2767,10 +3100,8 @@ PP(pp_system)
int childpid;
int result;
int status;
- Signal_t (*ihand)(); /* place to save signal during system() */
- Signal_t (*qhand)(); /* place to save signal during system() */
+ Sigsave_t ihand,qhand; /* place to save signals during system() */
-#if defined(HAS_FORK) && !defined(VMS) && !defined(OS2)
if (SP - MARK == 1) {
if (tainting) {
char *junk = SvPV(TOPs, na);
@@ -2778,6 +3109,7 @@ PP(pp_system)
TAINT_PROPER("system");
}
}
+#if (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
while ((childpid = vfork()) == -1) {
if (errno != EAGAIN) {
value = -1;
@@ -2788,22 +3120,17 @@ PP(pp_system)
sleep(5);
}
if (childpid > 0) {
- ihand = signal(SIGINT, SIG_IGN);
- qhand = signal(SIGQUIT, SIG_IGN);
+ rsignal_save(SIGINT, SIG_IGN, &ihand);
+ rsignal_save(SIGQUIT, SIG_IGN, &qhand);
do {
result = wait4pid(childpid, &status, 0);
} while (result == -1 && errno == EINTR);
- (void)signal(SIGINT, ihand);
- (void)signal(SIGQUIT, qhand);
- statusvalue = FIXSTATUS(status);
- if (result < 0)
- value = -1;
- else {
- value = (I32)((unsigned int)status & 0xffff);
- }
+ (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(value);
+ PUSHi(STATUS_CURRENT);
RETURN;
}
if (op->op_flags & OPf_STACKED) {
@@ -2826,10 +3153,10 @@ PP(pp_system)
else {
value = (I32)do_spawn(SvPVx(sv_mortalcopy(*SP), na));
}
- statusvalue = FIXSTATUS(value);
+ STATUS_NATIVE_SET(value);
do_execfree();
SP = ORIGMARK;
- PUSHi(value);
+ PUSHi(STATUS_CURRENT);
#endif /* !FORK or VMS */
RETURN;
}
@@ -2905,7 +3232,7 @@ PP(pp_getpgrp)
#ifdef BSD_GETPGRP
value = (I32)BSD_GETPGRP(pid);
#else
- if (pid != 0)
+ if (pid != 0 && pid != getpid())
DIE("POSIX getpgrp can't take an argument");
value = (I32)getpgrp();
#endif
@@ -2935,9 +3262,8 @@ PP(pp_setpgrp)
#ifdef BSD_SETPGRP
SETi( BSD_SETPGRP(pid, pgrp) >= 0 );
#else
- if ((pgrp != 0) || (pid != 0)) {
+ if ((pgrp != 0 && pgrp != getpid()) || (pid != 0 && pid != getpid()))
DIE("POSIX setpgrp can't take an argument");
- }
SETi( setpgrp() >= 0 );
#endif /* USE_BSDPGRP */
RETURN;
@@ -2984,19 +3310,35 @@ PP(pp_setpriority)
PP(pp_time)
{
dSP; 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
-#define HZ 60
+# ifdef CLK_TCK
+# define HZ CLK_TCK
+# else
+# define HZ 60
+# endif
#endif
PP(pp_tms)
{
dSP;
-#if defined(MSDOS) || !defined(HAS_TIMES)
+#ifndef HAS_TIMES
DIE("times not implemented");
#else
EXTEND(SP, 4);
@@ -3007,8 +3349,6 @@ PP(pp_tms)
(void)times((tbuffer_t *)&timesbuf); /* time.h uses different name for */
/* struct tms, though same data */
/* is returned. */
-#undef HZ
-#define HZ CLK_TCK
#endif
PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_utime)/HZ)));
@@ -3018,7 +3358,7 @@ PP(pp_tms)
PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
}
RETURN;
-#endif /* MSDOS */
+#endif /* HAS_TIMES */
}
PP(pp_localtime)
@@ -3038,7 +3378,11 @@ PP(pp_gmtime)
if (MAXARG < 1)
(void)time(&when);
else
+#ifdef BIG_TIME
+ when = (Time_t)SvNVx(POPs);
+#else
when = (Time_t)SvIVx(POPs);
+#endif
if (op->op_type == OP_LOCALTIME)
tmbuf = localtime(&when);
@@ -3046,20 +3390,21 @@ PP(pp_gmtime)
tmbuf = gmtime(&when);
EXTEND(SP, 9);
+ EXTEND_MORTAL(9);
if (GIMME != G_ARRAY) {
dTARGET;
- char mybuf[30];
+ SV *tsv;
if (!tmbuf)
RETPUSHUNDEF;
- sprintf(mybuf, "%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);
- PUSHp(mybuf, strlen(mybuf));
+ 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)));
@@ -3101,7 +3446,7 @@ PP(pp_sleep)
(void)time(&lasttime);
if (MAXARG < 1)
- pause();
+ Pause();
else {
duration = POPi;
sleep((unsigned int)duration);
@@ -3208,7 +3553,7 @@ PP(pp_semctl)
PUSHi(anum);
}
else {
- PUSHp("0 but true",10);
+ PUSHp(zero_but_true, ZBTLEN);
}
RETURN;
#else
@@ -3285,7 +3630,7 @@ PP(pp_ghostent)
#ifdef HOST_NOT_FOUND
if (!hent)
- statusvalue = FIXSTATUS(h_errno);
+ STATUS_NATIVE_SET(h_errno);
#endif
if (GIMME != G_ARRAY) {
@@ -3311,10 +3656,10 @@ PP(pp_ghostent)
sv_catpvn(sv, " ", 1);
}
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)hent->h_addrtype);
+ sv_setiv(sv, (IV)hent->h_addrtype);
PUSHs(sv = sv_mortalcopy(&sv_no));
len = hent->h_length;
- sv_setiv(sv, (I32)len);
+ sv_setiv(sv, (IV)len);
#ifdef h_addr
for (elem = hent->h_addr_list; elem && *elem; elem++) {
XPUSHs(sv = sv_mortalcopy(&sv_no));
@@ -3377,7 +3722,7 @@ PP(pp_gnetent)
PUSHs(sv = sv_newmortal());
if (nent) {
if (which == OP_GNBYNAME)
- sv_setiv(sv, (I32)nent->n_net);
+ sv_setiv(sv, (IV)nent->n_net);
else
sv_setpv(sv, nent->n_name);
}
@@ -3388,15 +3733,15 @@ PP(pp_gnetent)
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, nent->n_name);
PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = nent->n_aliases; *elem; elem++) {
+ for (elem = nent->n_aliases; elem && *elem; elem++) {
sv_catpv(sv, *elem);
if (elem[1])
sv_catpvn(sv, " ", 1);
}
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)nent->n_addrtype);
+ sv_setiv(sv, (IV)nent->n_addrtype);
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)nent->n_net);
+ sv_setiv(sv, (IV)nent->n_net);
}
RETURN;
@@ -3447,7 +3792,7 @@ PP(pp_gprotoent)
PUSHs(sv = sv_newmortal());
if (pent) {
if (which == OP_GPBYNAME)
- sv_setiv(sv, (I32)pent->p_proto);
+ sv_setiv(sv, (IV)pent->p_proto);
else
sv_setpv(sv, pent->p_name);
}
@@ -3458,13 +3803,13 @@ PP(pp_gprotoent)
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, pent->p_name);
PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = pent->p_aliases; *elem; elem++) {
+ for (elem = pent->p_aliases; elem && *elem; elem++) {
sv_catpv(sv, *elem);
if (elem[1])
sv_catpvn(sv, " ", 1);
}
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pent->p_proto);
+ sv_setiv(sv, (IV)pent->p_proto);
}
RETURN;
@@ -3514,8 +3859,11 @@ PP(pp_gservent)
}
else if (which == OP_GSBYPORT) {
char *proto = POPp;
- int port = POPi;
+ unsigned short port = POPu;
+#ifdef HAS_HTONS
+ port = htons(port);
+#endif
sent = getservbyport(port, proto);
}
else
@@ -3527,9 +3875,9 @@ PP(pp_gservent)
if (sent) {
if (which == OP_GSBYNAME) {
#ifdef HAS_NTOHS
- sv_setiv(sv, (I32)ntohs(sent->s_port));
+ sv_setiv(sv, (IV)ntohs(sent->s_port));
#else
- sv_setiv(sv, (I32)(sent->s_port));
+ sv_setiv(sv, (IV)(sent->s_port));
#endif
}
else
@@ -3542,16 +3890,16 @@ PP(pp_gservent)
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, sent->s_name);
PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = sent->s_aliases; *elem; elem++) {
+ for (elem = sent->s_aliases; elem && *elem; elem++) {
sv_catpv(sv, *elem);
if (elem[1])
sv_catpvn(sv, " ", 1);
}
PUSHs(sv = sv_mortalcopy(&sv_no));
#ifdef HAS_NTOHS
- sv_setiv(sv, (I32)ntohs(sent->s_port));
+ sv_setiv(sv, (IV)ntohs(sent->s_port));
#else
- sv_setiv(sv, (I32)(sent->s_port));
+ sv_setiv(sv, (IV)(sent->s_port));
#endif
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, sent->s_proto);
@@ -3693,7 +4041,7 @@ PP(pp_gpwent)
PUSHs(sv = sv_newmortal());
if (pwent) {
if (which == OP_GPWNAM)
- sv_setiv(sv, (I32)pwent->pw_uid);
+ sv_setiv(sv, (IV)pwent->pw_uid);
else
sv_setpv(sv, pwent->pw_name);
}
@@ -3706,15 +4054,15 @@ PP(pp_gpwent)
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, pwent->pw_passwd);
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_uid);
+ sv_setiv(sv, (IV)pwent->pw_uid);
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_gid);
+ sv_setiv(sv, (IV)pwent->pw_gid);
PUSHs(sv = sv_mortalcopy(&sv_no));
#ifdef PWCHANGE
- sv_setiv(sv, (I32)pwent->pw_change);
+ sv_setiv(sv, (IV)pwent->pw_change);
#else
#ifdef PWQUOTA
- sv_setiv(sv, (I32)pwent->pw_quota);
+ sv_setiv(sv, (IV)pwent->pw_quota);
#else
#ifdef PWAGE
sv_setpv(sv, pwent->pw_age);
@@ -3731,13 +4079,16 @@ PP(pp_gpwent)
#endif
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, pwent->pw_gecos);
+#ifndef INCOMPLETE_TAINTS
+ SvTAINTED_on(sv);
+#endif
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, pwent->pw_dir);
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, pwent->pw_shell);
#ifdef PWEXPIRE
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)pwent->pw_expire);
+ sv_setiv(sv, (IV)pwent->pw_expire);
#endif
}
RETURN;
@@ -3749,7 +4100,7 @@ PP(pp_gpwent)
PP(pp_spwent)
{
dSP;
-#ifdef HAS_PASSWD
+#if defined(HAS_PASSWD) && !defined(CYGWIN32)
setpwent();
RETPUSHYES;
#else
@@ -3807,7 +4158,7 @@ PP(pp_ggrent)
PUSHs(sv = sv_newmortal());
if (grent) {
if (which == OP_GGRNAM)
- sv_setiv(sv, (I32)grent->gr_gid);
+ sv_setiv(sv, (IV)grent->gr_gid);
else
sv_setpv(sv, grent->gr_name);
}
@@ -3820,9 +4171,9 @@ PP(pp_ggrent)
PUSHs(sv = sv_mortalcopy(&sv_no));
sv_setpv(sv, grent->gr_passwd);
PUSHs(sv = sv_mortalcopy(&sv_no));
- sv_setiv(sv, (I32)grent->gr_gid);
+ sv_setiv(sv, (IV)grent->gr_gid);
PUSHs(sv = sv_mortalcopy(&sv_no));
- for (elem = grent->gr_mem; *elem; elem++) {
+ for (elem = grent->gr_mem; elem && *elem; elem++) {
sv_catpv(sv, *elem);
if (elem[1])
sv_catpvn(sv, " ", 1);
@@ -3886,9 +4237,10 @@ PP(pp_syscall)
if (tainting) {
while (++MARK <= SP) {
- if (SvGMAGICAL(*MARK) && SvSMAGICAL(*MARK) &&
- (mg = mg_find(*MARK, 't')) && mg->mg_len & 1)
- tainted = TRUE;
+ if (SvTAINTED(*MARK)) {
+ TAINT;
+ break;
+ }
}
MARK = ORIGMARK;
TAINT_PROPER("syscall");
@@ -3970,7 +4322,42 @@ PP(pp_syscall)
#endif
}
-#if !defined(HAS_FLOCK) && defined(HAS_LOCKF)
+#ifdef FCNTL_EMULATE_FLOCK
+
+/* XXX Emulate flock() with fcntl().
+ What's really needed is a good file locking module.
+*/
+
+static int
+fcntl_emulate_flock(fd, operation)
+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
@@ -3978,12 +4365,9 @@ PP(pp_syscall)
locking module.
*/
-/* We might need <unistd.h> because it sometimes defines the lockf()
- constants. Unfortunately, <unistd.h> causes troubles on some mixed
- (BSD/POSIX) systems, such as SunOS 4.1.3. We could just try including
- <unistd.h> here in this part of the file, but that might
- conflict with various other #defines and includes above, such as
- #define vfork fork above.
+/* 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
@@ -4003,28 +4387,23 @@ PP(pp_syscall)
# define F_TEST 3 /* Test a region for other processes locks */
# endif
-/* 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
-
-int
+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 = lseek(fd, (Off_t)0, SEEK_CUR); /* get pos to restore later */
+ if (pos > 0) /* is seekable and needs to be repositioned */
+ if (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 */
@@ -4044,8 +4423,9 @@ int operation;
errno = EWOULDBLOCK;
break;
- /* LOCK_UN - unlock */
+ /* LOCK_UN - unlock (non-blocking is a no-op) */
case LOCK_UN:
+ case LOCK_UN|LOCK_NB:
i = lockf (fd, F_ULOCK, 0);
break;
@@ -4055,6 +4435,11 @@ int operation;
errno = EINVAL;
break;
}
+
+ if (pos > 0) /* need to restore position of the handle */
+ lseek(fd, pos, SEEK_SET); /* ignore error here */
+
return (i);
}
-#endif
+
+#endif /* LOCKF_EMULATE_FLOCK */
diff --git a/gnu/usr.bin/perl/proto.h b/gnu/usr.bin/perl/proto.h
index 542d5663fdc..463b4989227 100644
--- a/gnu/usr.bin/perl/proto.h
+++ b/gnu/usr.bin/perl/proto.h
@@ -8,7 +8,7 @@
#endif
#ifdef OVERLOAD
SV* amagic_call _((SV* left,SV* right,int method,int dir));
-bool Gv_AMupdate _((HV* stash));
+bool Gv_AMupdate _((HV* stash));
#endif /* OVERLOAD */
OP* append_elem _((I32 optype, OP* head, OP* tail));
OP* append_list _((I32 optype, LISTOP* first, LISTOP* last));
@@ -23,36 +23,40 @@ I32 av_len _((AV* ar));
AV* av_make _((I32 size, SV** svp));
SV* av_pop _((AV* ar));
void av_push _((AV* ar, SV* val));
+void av_reify _((AV* ar));
SV* av_shift _((AV* ar));
SV** av_store _((AV* ar, I32 key, SV* val));
void av_undef _((AV* ar));
void av_unshift _((AV* ar, I32 num));
OP* bind_match _((I32 type, OP* left, OP* pat));
-OP* block_end _((int line, int floor, OP* seq));
-int block_start _((void));
-void calllist _((AV* list));
+OP* block_end _((I32 floor, OP* seq));
+I32 block_gimme _((void));
+int block_start _((int full));
+void boot_core_UNIVERSAL _((void));
+void call_list _((I32 oldscope, AV* list));
I32 cando _((I32 bit, I32 effective, struct stat* statbufp));
#ifndef CASTNEGFLOAT
U32 cast_ulong _((double f));
#endif
#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
-I32 chsize _((int fd, Off_t length));
+I32 my_chsize _((int fd, Off_t length));
#endif
-OP * ck_gvconst _((OP * o));
-OP * ck_retarget _((OP *op));
+OP* ck_gvconst _((OP* o));
+OP* ck_retarget _((OP* op));
OP* convert _((I32 optype, I32 flags, OP* op));
-char* cpytill _((char* to, char* from, char* fromend, int delim, I32* retlen));
-void croak _((char* pat,...)) __attribute__((format(printf,1,2),noreturn));
+void croak _((const char* pat,...)) __attribute__((noreturn));
+void cv_ckproto _((CV* cv, GV* gv, char* p));
CV* cv_clone _((CV* proto));
+SV* cv_const_sv _((CV* cv));
void cv_undef _((CV* cv));
#ifdef DEBUGGING
void cx_dump _((CONTEXT* cs));
#endif
-SV * filter_add _((filter_t funcp, SV *datasv));
+SV* filter_add _((filter_t funcp, SV* datasv));
void filter_del _((filter_t funcp));
-I32 filter_read _((int idx, SV *buffer, int maxlen));
+I32 filter_read _((int idx, SV* buffer, int maxlen));
I32 cxinc _((void));
-void deb _((char* pat,...)) __attribute__((format(printf,1,2)));
+void deb _((const char* pat,...)) __attribute__((format(printf,1,2)));
void deb_growlevel _((void));
I32 debop _((OP* op));
I32 debstackptrs _((void));
@@ -60,13 +64,15 @@ I32 debstackptrs _((void));
void debprofdump _((void));
#endif
I32 debstack _((void));
+char* delimcpy _((char* to, char* toend, char* from, char* fromend,
+ int delim, I32* retlen));
void deprecate _((char* s));
-OP* die _((char* pat,...)) __attribute__((format(printf,1,2)));
+OP* die _((const char* pat,...));
OP* die_where _((char* message));
void dounwind _((I32 cxix));
bool do_aexec _((SV* really, SV** mark, SV** sp));
void do_chop _((SV* asv, SV* sv));
-bool do_close _((GV* gv, bool explicit));
+bool do_close _((GV* gv, bool not_implicit));
bool do_eof _((GV* gv));
bool do_exec _((char* cmd));
void do_execfree _((void));
@@ -81,10 +87,10 @@ I32 do_msgrcv _((SV** mark, SV** sp));
I32 do_msgsnd _((SV** mark, SV** sp));
#endif
bool do_open _((GV* gv, char* name, I32 len,
- int as_raw, int rawmode, int rawperm, FILE* supplied_fp));
+ int as_raw, int rawmode, int rawperm, PerlIO* supplied_fp));
void do_pipe _((SV* sv, GV* rgv, GV* wgv));
-bool do_print _((SV* sv, FILE* fp));
-OP * do_readline _((void));
+bool do_print _((SV* sv, PerlIO* fp));
+OP* do_readline _((void));
I32 do_chomp _((SV* sv));
bool do_seek _((GV* gv, long pos, int whence));
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
@@ -92,6 +98,7 @@ I32 do_semop _((SV** mark, SV** sp));
I32 do_shmio _((I32 optype, SV** mark, SV** sp));
#endif
void do_sprintf _((SV* sv, I32 len, SV** sarg));
+long do_sysseek _((GV* gv, long pos, int whence));
long do_tell _((GV* gv));
I32 do_trans _((SV* sv, OP* arg));
void do_vecset _((SV* sv));
@@ -111,10 +118,11 @@ void dump_op _((OP* arg));
void dump_pm _((PMOP* pm));
void dump_packsubs _((HV* stash));
void dump_sub _((GV* gv));
-void fbm_compile _((SV* sv, I32 iflag));
+void fbm_compile _((SV* sv));
char* fbm_instr _((unsigned char* big, unsigned char* bigend, SV* littlesv));
OP* force_list _((OP* arg));
-OP* fold_constants _((OP * arg));
+OP* fold_constants _((OP* arg));
+char* form _((const char* pat, ...));
void free_tmps _((void));
OP* gen_constant_list _((OP* op));
void gp_free _((GV* gv));
@@ -122,33 +130,46 @@ GP* gp_ref _((GP* gp));
GV* gv_AVadd _((GV* gv));
GV* gv_HVadd _((GV* gv));
GV* gv_IOadd _((GV* gv));
+GV* gv_autoload4 _((HV* stash, char* name, STRLEN len, I32 method));
void gv_check _((HV* stash));
void gv_efullname _((SV* sv, GV* gv));
+void gv_efullname3 _((SV* sv, GV* gv, char* prefix));
GV* gv_fetchfile _((char* name));
GV* gv_fetchmeth _((HV* stash, char* name, STRLEN len, I32 level));
GV* gv_fetchmethod _((HV* stash, char* name));
+GV* gv_fetchmethod_autoload _((HV* stash, char* name, I32 autoload));
GV* gv_fetchpv _((char* name, I32 add, I32 sv_type));
void gv_fullname _((SV* sv, GV* gv));
-void gv_init _((GV *gv, HV *stash, char *name, STRLEN len, int multi));
+void gv_fullname3 _((SV* sv, GV* gv, char* prefix));
+void gv_init _((GV* gv, HV* stash, char* name, STRLEN len, int multi));
HV* gv_stashpv _((char* name, I32 create));
+HV* gv_stashpvn _((char* name, U32 namelen, I32 create));
HV* gv_stashsv _((SV* sv, I32 create));
-void he_delayfree _((HE* hent));
-void he_free _((HE* hent));
void hoistmust _((PMOP* pm));
void hv_clear _((HV* tb));
+void hv_delayfree_ent _((HV* hv, HE* entry));
SV* hv_delete _((HV* tb, char* key, U32 klen, I32 flags));
+SV* hv_delete_ent _((HV* tb, SV* key, I32 flags, U32 hash));
bool hv_exists _((HV* tb, char* key, U32 klen));
+bool hv_exists_ent _((HV* tb, SV* key, U32 hash));
SV** hv_fetch _((HV* tb, char* key, U32 klen, I32 lval));
+HE* hv_fetch_ent _((HV* tb, SV* key, I32 lval, U32 hash));
+void hv_free_ent _((HV* hv, HE* entry));
I32 hv_iterinit _((HV* tb));
char* hv_iterkey _((HE* entry, I32* retlen));
+SV* hv_iterkeysv _((HE* entry));
HE* hv_iternext _((HV* tb));
-SV * hv_iternextsv _((HV* hv, char** key, I32* retlen));
+SV* hv_iternextsv _((HV* hv, char** key, I32* retlen));
SV* hv_iterval _((HV* tb, HE* entry));
+void hv_ksplit _((HV* hv, IV newmax));
void hv_magic _((HV* hv, GV* gv, int how));
SV** hv_store _((HV* tb, char* key, U32 klen, SV* val, U32 hash));
+HE* hv_store_ent _((HV* tb, SV* key, SV* val, U32 hash));
void hv_undef _((HV* tb));
-I32 ibcmp _((U8* a, U8* b, I32 len));
+I32 ibcmp _((char* a, char* b, I32 len));
+I32 ibcmp_locale _((char* a, char* b, I32 len));
I32 ingroup _((I32 testgid, I32 effective));
+U32 intro_my _((void));
char* instr _((char* big, char* little));
bool io_close _((IO* io));
OP* invert _((OP* cmd));
@@ -156,20 +177,25 @@ OP* jmaybe _((OP* arg));
I32 keyword _((char* d, I32 len));
void leave_scope _((I32 base));
void lex_end _((void));
-void lex_start _((SV *line));
+void lex_start _((SV* line));
OP* linklist _((OP* op));
OP* list _((OP* o));
OP* listkids _((OP* o));
OP* localize _((OP* arg, I32 lexical));
I32 looks_like_number _((SV* sv));
int magic_clearenv _((SV* sv, MAGIC* mg));
+int magic_clear_all_env _((SV* sv, MAGIC* mg));
int magic_clearpack _((SV* sv, MAGIC* mg));
-int magic_existspack _((SV* sv, MAGIC* mg));
+int magic_clearsig _((SV* sv, MAGIC* mg));
+int magic_existspack _((SV* sv, MAGIC* mg));
+int magic_freedefelem _((SV* sv, MAGIC* mg));
int magic_get _((SV* sv, MAGIC* mg));
int magic_getarylen _((SV* sv, MAGIC* mg));
-int magic_getpack _((SV* sv, MAGIC* mg));
+int magic_getdefelem _((SV* sv, MAGIC* mg));
int magic_getglob _((SV* sv, MAGIC* mg));
+int magic_getpack _((SV* sv, MAGIC* mg));
int magic_getpos _((SV* sv, MAGIC* mg));
+int magic_getsig _((SV* sv, MAGIC* mg));
int magic_gettaint _((SV* sv, MAGIC* mg));
int magic_getuvar _((SV* sv, MAGIC* mg));
U32 magic_len _((SV* sv, MAGIC* mg));
@@ -181,10 +207,16 @@ int magic_setamagic _((SV* sv, MAGIC* mg));
int magic_setarylen _((SV* sv, MAGIC* mg));
int magic_setbm _((SV* sv, MAGIC* mg));
int magic_setdbline _((SV* sv, MAGIC* mg));
+#ifdef USE_LOCALE_COLLATE
+int magic_setcollxfrm _((SV* sv, MAGIC* mg));
+#endif
+int magic_setdefelem _((SV* sv, MAGIC* mg));
int magic_setenv _((SV* sv, MAGIC* mg));
+int magic_setfm _((SV* sv, MAGIC* mg));
int magic_setisa _((SV* sv, MAGIC* mg));
int magic_setglob _((SV* sv, MAGIC* mg));
int magic_setmglob _((SV* sv, MAGIC* mg));
+int magic_setnkeys _((SV* sv, MAGIC* mg));
int magic_setpack _((SV* sv, MAGIC* mg));
int magic_setpos _((SV* sv, MAGIC* mg));
int magic_setsig _((SV* sv, MAGIC* mg));
@@ -192,21 +224,17 @@ int magic_setsubstr _((SV* sv, MAGIC* mg));
int magic_settaint _((SV* sv, MAGIC* mg));
int magic_setuvar _((SV* sv, MAGIC* mg));
int magic_setvec _((SV* sv, MAGIC* mg));
+int magic_set_all_env _((SV* sv, MAGIC* mg));
int magic_wipepack _((SV* sv, MAGIC* mg));
void magicname _((char* sym, char* name, I32 namlen));
int main _((int argc, char** argv, char** env));
-#if !defined(STANDARD_C)
-Malloc_t malloc _((MEM_SIZE nbytes));
-#endif
-#if defined(MYMALLOC) && defined(HIDEMYMALLOC)
-extern Malloc_t malloc _((MEM_SIZE nbytes));
-extern Malloc_t realloc _((Malloc_t, MEM_SIZE));
-extern Free_t free _((Malloc_t));
-#endif
void markstack_grow _((void));
-char* mess _((char* pat, va_list* args));
+#ifdef USE_LOCALE_COLLATE
+char* mem_collxfrm _((const char* s, STRLEN len, STRLEN* xlen));
+#endif
+char* mess _((const char* pat, va_list* args));
int mg_clear _((SV* sv));
-int mg_copy _((SV *, SV *, char *, STRLEN));
+int mg_copy _((SV* , SV* , char* , I32));
MAGIC* mg_find _((SV* sv, int type));
int mg_free _((SV* sv));
int mg_get _((SV* sv));
@@ -215,18 +243,24 @@ void mg_magical _((SV* sv));
int mg_set _((SV* sv));
OP* mod _((OP* op, I32 type));
char* moreswitches _((char* s));
-OP * my _(( OP *));
+OP* my _((OP* op));
+#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
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
void my_exit _((U32 status)) __attribute__((noreturn));
+void my_failure_exit _((void)) __attribute__((noreturn));
I32 my_lstat _((void));
-#ifndef HAS_MEMCMP
-I32 my_memcmp _((unsigned char* s1, unsigned char* s2, I32 len));
+#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
+I32 my_memcmp _((char* s1, char* s2, I32 len));
#endif
-I32 my_pclose _((FILE* ptr));
-FILE* my_popen _((char* cmd, char* mode));
+#if !defined(HAS_MEMSET)
+void* my_memset _((char* loc, I32 ch, I32 len));
+#endif
+I32 my_pclose _((PerlIO* ptr));
+PerlIO* my_popen _((char* cmd, char* mode));
void my_setenv _((char* nam, char* val));
I32 my_stat _((void));
#ifdef MYSWAP
@@ -252,16 +286,16 @@ OP* newRANGE _((I32 flags, OP* left, OP* right));
OP* newSLICEOP _((I32 flags, OP* subscript, OP* list));
OP* newSTATEOP _((I32 flags, char* label, OP* o));
CV* newSUB _((I32 floor, OP* op, OP* proto, OP* block));
-CV* newXS _((char *name, void (*subaddr)(CV* cv), char *filename));
+CV* newXS _((char* name, void (*subaddr)(CV* cv), char* filename));
#ifdef DEPRECATED
-CV* newXSUB _((char *name, I32 ix, I32 (*subaddr)(int,int,int), char *filename));
+CV* newXSUB _((char* name, I32 ix, I32 (*subaddr)(int,int,int), char* filename));
#endif
AV* newAV _((void));
OP* newAVREF _((OP* o));
OP* newBINOP _((I32 type, I32 flags, OP* first, OP* last));
OP* newCVREF _((I32 flags, OP* o));
OP* newGVOP _((I32 type, I32 flags, GV* gv));
-GV* newGVgen _((char *pack));
+GV* newGVgen _((char* pack));
OP* newGVREF _((I32 type, OP* o));
OP* newHVREF _((OP* o));
HV* newHV _((void));
@@ -280,13 +314,15 @@ OP* newSVOP _((I32 type, I32 flags, SV* sv));
SV* newSViv _((IV i));
SV* newSVnv _((double n));
SV* newSVpv _((char* s, STRLEN len));
+SV* newSVpvf _((const char* pat, ...));
SV* newSVrv _((SV* rv, char* classname));
SV* newSVsv _((SV* old));
OP* newUNOP _((I32 type, I32 flags, OP* first));
-OP * newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop, OP* expr, OP* block, OP* cont));
-FILE* nextargv _((GV* gv));
+OP* newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop,
+ I32 whileline, OP* expr, OP* block, OP* cont));
+PerlIO* nextargv _((GV* gv));
char* ninstr _((char* big, char* bigend, char* little, char* lend));
-OP * oopsCV _((OP* o));
+OP* oopsCV _((OP* o));
void op_free _((OP* arg));
void package _((OP* op));
PADOFFSET pad_alloc _((I32 optype, U32 tmptype));
@@ -307,13 +343,20 @@ I32 perl_call_pv _((char* subname, I32 flags));
I32 perl_call_sv _((SV* sv, I32 flags));
void perl_construct _((PerlInterpreter* sv_interp));
void perl_destruct _((PerlInterpreter* sv_interp));
+SV* perl_eval_pv _((char* p, I32 croak_on_error));
I32 perl_eval_sv _((SV* sv, I32 flags));
void perl_free _((PerlInterpreter* sv_interp));
SV* perl_get_sv _((char* name, I32 create));
AV* perl_get_av _((char* name, I32 create));
HV* perl_get_hv _((char* name, I32 create));
CV* perl_get_cv _((char* name, I32 create));
+int perl_init_i18nl10n _((int printwarn));
int perl_init_i18nl14n _((int printwarn));
+void perl_new_collate _((char* newcoll));
+void perl_new_ctype _((char* newctype));
+void perl_new_numeric _((char* newcoll));
+void perl_set_numeric_local _((void));
+void perl_set_numeric_standard _((void));
int perl_parse _((PerlInterpreter* sv_interp, void(*xsinit)(void), int argc, char** argv, char** env));
void perl_require_pv _((char* pv));
#define perl_requirepv perl_require_pv
@@ -325,7 +368,6 @@ OP* pmtrans _((OP* op, OP* expr, OP* repl));
OP* pop_return _((void));
void pop_scope _((void));
OP* prepend_elem _((I32 optype, OP* head, OP* tail));
-void provide_ref _((OP* op, SV* sv));
void push_return _((OP* op));
void push_scope _((void));
regexp* pregcomp _((char* exp, char* xend, PMOP* pm));
@@ -335,24 +377,17 @@ void regdump _((regexp* r));
I32 pregexec _((regexp* prog, char* stringarg, char* strend, char* strbeg, I32 minend, SV* screamer, I32 safebase));
void pregfree _((struct regexp* r));
char* regnext _((char* p));
-char* regprop _((char* op));
+void regprop _((SV* sv, char* op));
void repeatcpy _((char* to, char* from, I32 len, I32 count));
char* rninstr _((char* big, char* bigend, char* little, char* lend));
+Sighandler_t rsignal _((int, Sighandler_t));
+int rsignal_restore _((int, Sigsave_t*));
+int rsignal_save _((int, Sighandler_t, Sigsave_t*));
+Sighandler_t rsignal_state _((int));
int runops _((void));
-#ifndef safemalloc
-void safefree _((char* where));
-char* safemalloc _((MEM_SIZE size));
-#ifndef MSDOS
-char* saferealloc _((char* where, MEM_SIZE size));
-#else
-char* saferealloc _((char* where, unsigned long size));
-#endif
-#endif
-#ifdef LEAKTEST
-void safexfree _((char* where));
-char* safexmalloc _((I32 x, MEM_SIZE size));
-char* safexrealloc _((char* where, MEM_SIZE size));
-#endif
+void rxres_free _((void** rsp));
+void rxres_restore _((void** rsp, REGEXP* rx));
+void rxres_save _((void** rsp, REGEXP* rx));
#ifndef HAS_RENAME
I32 same_dirent _((char* a, char* b));
#endif
@@ -369,16 +404,19 @@ void save_destructor _((void (*f)(void*), void* p));
void save_freesv _((SV* sv));
void save_freeop _((OP* op));
void save_freepv _((char* pv));
+void save_gp _((GV* gv, I32 empty));
HV* save_hash _((GV* gv));
void save_hptr _((HV** hptr));
+void save_I16 _((I16* intp));
void save_I32 _((I32* intp));
void save_int _((int* intp));
void save_item _((SV* item));
+void save_iv _((IV* iv));
void save_list _((SV** sarg, I32 maxsarg));
-void save_long _((long *longp));
+void save_long _((long* longp));
void save_nogv _((GV* gv));
SV* save_scalar _((GV* gv));
-void save_pptr _((char **pptr));
+void save_pptr _((char** pptr));
void save_sptr _((SV** sptr));
SV* save_svref _((SV** sptr));
OP* sawparens _((OP* o));
@@ -386,18 +424,21 @@ OP* scalar _((OP* o));
OP* scalarkids _((OP* op));
OP* scalarseq _((OP* o));
OP* scalarvoid _((OP* op));
-unsigned long scan_hex _((char* start, I32 len, I32* retlen));
+UV scan_hex _((char* start, I32 len, I32* retlen));
char* scan_num _((char* s));
-unsigned long scan_oct _((char* start, I32 len, I32* retlen));
+UV scan_oct _((char* start, I32 len, I32* retlen));
OP* scope _((OP* o));
char* screaminstr _((SV* bigsv, SV* littlesv));
#ifndef VMS
I32 setenv_getix _((char* nam));
#endif
-void setdefout _((GV *gv));
+void setdefout _((GV* gv));
+char* sharepvn _((char* sv, I32 len, U32 hash));
+HEK* share_hek _((char* sv, I32 len, U32 hash));
Signal_t sighandler _((int sig));
SV** stack_grow _((SV** sp, SV**p, int n));
-int start_subparse _((void));
+I32 start_subparse _((I32 is_format, U32 flags));
+void sub_crush_depth _((CV* cv));
bool sv_2bool _((SV* sv));
CV* sv_2cv _((SV* sv, HV** st, GV** gvp, I32 lref));
IO* sv_2io _((SV* sv));
@@ -405,9 +446,11 @@ IV sv_2iv _((SV* sv));
SV* sv_2mortal _((SV* sv));
double sv_2nv _((SV* sv));
char* sv_2pv _((SV* sv, STRLEN* lp));
+UV sv_2uv _((SV* sv));
void sv_add_arena _((char* ptr, U32 size, U32 flags));
int sv_backoff _((SV* sv));
SV* sv_bless _((SV* sv, HV* stash));
+void sv_catpvf _((SV* sv, const char* pat, ...));
void sv_catpv _((SV* sv, char* ptr));
void sv_catpvn _((SV* sv, char* ptr, STRLEN len));
void sv_catsv _((SV* dsv, SV* ssv));
@@ -416,12 +459,17 @@ void sv_clean_all _((void));
void sv_clean_objs _((void));
void sv_clear _((SV* sv));
I32 sv_cmp _((SV* sv1, SV* sv2));
+I32 sv_cmp_locale _((SV* sv1, SV* sv2));
+#ifdef USE_LOCALE_COLLATE
+char* sv_collxfrm _((SV* sv, STRLEN* nxp));
+#endif
void sv_dec _((SV* sv));
void sv_dump _((SV* sv));
+bool sv_derived_from _((SV* sv, char* name));
I32 sv_eq _((SV* sv1, SV* sv2));
void sv_free _((SV* sv));
void sv_free_arenas _((void));
-char* sv_gets _((SV* sv, FILE* fp, I32 append));
+char* sv_gets _((SV* sv, PerlIO* fp, I32 append));
#ifndef DOSISH
char* sv_grow _((SV* sv, I32 newlen));
#else
@@ -436,37 +484,73 @@ void sv_magic _((SV* sv, SV* obj, int how, char* name, I32 namlen));
SV* sv_mortalcopy _((SV* oldsv));
SV* sv_newmortal _((void));
SV* sv_newref _((SV* sv));
-char * sv_peek _((SV* sv));
-char * sv_pvn_force _((SV* sv, STRLEN* lp));
+char* sv_peek _((SV* sv));
+char* sv_pvn_force _((SV* sv, STRLEN* lp));
char* sv_reftype _((SV* sv, int ob));
void sv_replace _((SV* sv, SV* nsv));
void sv_report_used _((void));
void sv_reset _((char* s, HV* stash));
+void sv_setpvf _((SV* sv, const char* pat, ...));
void sv_setiv _((SV* sv, IV num));
+void sv_setpviv _((SV* sv, IV num));
+void sv_setuv _((SV* sv, UV num));
void sv_setnv _((SV* sv, double num));
-SV* sv_setref_iv _((SV *rv, char *classname, IV iv));
-SV* sv_setref_nv _((SV *rv, char *classname, double nv));
-SV* sv_setref_pv _((SV *rv, char *classname, void* pv));
-SV* sv_setref_pvn _((SV *rv, char *classname, char* pv, I32 n));
-void sv_setpv _((SV* sv, char* ptr));
-void sv_setpvn _((SV* sv, char* ptr, STRLEN len));
+SV* sv_setref_iv _((SV* rv, char* classname, IV iv));
+SV* sv_setref_nv _((SV* rv, char* classname, double nv));
+SV* sv_setref_pv _((SV* rv, char* classname, void* pv));
+SV* sv_setref_pvn _((SV* rv, char* classname, char* pv, I32 n));
+void sv_setpv _((SV* sv, const char* ptr));
+void sv_setpvn _((SV* sv, const char* ptr, STRLEN len));
void sv_setsv _((SV* dsv, SV* ssv));
+void sv_taint _((SV* sv));
+bool sv_tainted _((SV* sv));
int sv_unmagic _((SV* sv, int type));
void sv_unref _((SV* sv));
+void sv_untaint _((SV* sv));
bool sv_upgrade _((SV* sv, U32 mt));
void sv_usepvn _((SV* sv, char* ptr, STRLEN len));
+void sv_vcatpvfn _((SV* sv, const char* pat, STRLEN patlen,
+ va_list* args, SV** svargs, I32 svmax,
+ bool *used_locale));
+void sv_vsetpvfn _((SV* sv, const char* pat, STRLEN patlen,
+ va_list* args, SV** svargs, I32 svmax,
+ bool *used_locale));
void taint_env _((void));
-void taint_not _((char *s));
-void taint_proper _((char* f, char* s));
+void taint_proper _((const char* f, char* s));
#ifdef UNLINK_ALL_VERSIONS
I32 unlnk _((char* f));
#endif
-void utilize _((int aver, I32 floor, OP* id, OP* arg));
+void unsharepvn _((char* sv, I32 len, U32 hash));
+void unshare_hek _((HEK* hek));
+void utilize _((int aver, I32 floor, OP* version, OP* id, OP* arg));
+void vivify_defelem _((SV* sv));
+void vivify_ref _((SV* sv, U32 to_what));
I32 wait4pid _((int pid, int* statusp, int flags));
-void warn _((char* pat,...)) __attribute__((format(printf,1,2)));
-void watch _((char **addr));
+void warn _((const char* pat,...));
+void watch _((char** addr));
I32 whichsig _((char* sig));
int yyerror _((char* s));
int yylex _((void));
int yyparse _((void));
int yywarn _((char* s));
+
+#if defined(MYMALLOC) || !defined(STANDARD_C)
+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
+
+#ifndef MYMALLOC
+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));
+#endif
+
+#ifdef LEAKTEST
+Malloc_t safexmalloc _((I32 x, MEM_SIZE size));
+Malloc_t safexcalloc _((I32 x, MEM_SIZE elements, MEM_SIZE size));
+Malloc_t safexrealloc _((Malloc_t where, MEM_SIZE size));
+void safexfree _((Malloc_t where));
+#endif
diff --git a/gnu/usr.bin/perl/qnx/ar b/gnu/usr.bin/perl/qnx/ar
new file mode 100644
index 00000000000..b46549abd1a
--- /dev/null
+++ b/gnu/usr.bin/perl/qnx/ar
@@ -0,0 +1,33 @@
+#! /bin/sh
+#__USAGE
+#%C key library name ...
+# Crude cover for wlib to be compatible with ar
+# Supports the following key letters:
+# qcru
+# ru replace existing modules. u indicates only replace
+# those which are newer
+# c create the library (kinda moot)
+# q quickly append to the end.
+#
+#This is a crude cover, but it has proved sufficient for many
+#ports. Rather than attempt to implement subtleties of the
+#ar syntax, I simply create a new library under all
+#circumstances. A much more thorough cover is available from
+#http://www.fdma.com/pub/qnx/porting/ar
+#
+#Note that Watcom 10.6 supports ar directly, so this
+#cover is not necessary.
+#
+#Increased the record size to 32 to accomodate a large library
+#in the perl 5.003 distribution
+#
+#Submitted by Norton T. Allen (allen@huarp.harvard.edu)
+
+if [ $# -lt 3 ]; then
+ use $0
+ exit 1
+fi
+shift
+library=$1
+shift
+wlib -p=32 -n $library `for i in $*; do echo "+$i \\c"; done`
diff --git a/gnu/usr.bin/perl/qnx/cpp b/gnu/usr.bin/perl/qnx/cpp
new file mode 100644
index 00000000000..6459af249f5
--- /dev/null
+++ b/gnu/usr.bin/perl/qnx/cpp
@@ -0,0 +1,24 @@
+#! /bin/sh
+#__USAGE
+#%C [-P] [-C] other options
+# cpp is a wrapper for wcc to make it work like other cpp's
+# -P omit #line directives from the output
+# -C pass comments through to the output
+#
+#Submitted by Norton T. Allen (allen@huarp.harvard.edu)
+
+typeset lines=l comments="" redir=""
+while :; do
+ case $1 in
+ -P) lines=""; shift; continue;;
+ -C) comments=c; shift; continue;;
+ esac
+ break
+done
+if [ ! -t 0 ]; then
+ cat >.$$.c
+ redir=.$$.c
+fi
+cc -c -Wc,-p$lines$comments -Wc,-pw=0 $* $redir |
+ awk 'NR>1||NF>0 {sub("^ ","");print}'
+[ -n "$redir" ] && rm -f $redir
diff --git a/gnu/usr.bin/perl/regcomp.c b/gnu/usr.bin/perl/regcomp.c
index d120eb7bdfc..d99d6c7d062 100644
--- a/gnu/usr.bin/perl/regcomp.c
+++ b/gnu/usr.bin/perl/regcomp.c
@@ -43,7 +43,7 @@
*
**** Alterations to Henry's code are...
****
- **** Copyright (c) 1991-1994, Larry Wall
+ **** 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.
@@ -107,8 +107,9 @@ static char *regnode _((char));
static char *regpiece _((I32 *));
static void reginsert _((char, char *));
static void regoptail _((char *, char *));
-static void regset _((char *, I32, I32));
+static void regset _((char *, I32));
static void regtail _((char *, char *));
+static char* regwhite _((char *, char *));
static char* nextchar _((void));
/*
@@ -132,7 +133,6 @@ char* exp;
char* xend;
PMOP* pm;
{
- I32 fold = pm->op_pmflags & PMf_FOLD;
register regexp *r;
register char *scan;
register SV *longish;
@@ -146,17 +146,25 @@ PMOP* pm;
I32 minlen = 0;
I32 sawplus = 0;
I32 sawopen = 0;
+#define MAX_REPEAT_DEPTH 12
+ struct {
+ char *opcode;
+ I32 count;
+ } repeat_stack[MAX_REPEAT_DEPTH];
+ I32 repeat_depth = 0;
+ I32 repeat_count = 1; /* We start unmultiplied. */
if (exp == NULL)
croak("NULL regexp argument");
- /* First pass: determine size, legality. */
+ regprecomp = savepvn(exp, xend - exp);
regflags = pm->op_pmflags;
+ regsawback = 0;
+
+ /* First pass: determine size, legality. */
regparse = exp;
regxend = xend;
- regprecomp = savepvn(exp,xend-exp);
regnaughty = 0;
- regsawback = 0;
regnpar = 1;
regsize = 0L;
regcode = &regdummy;
@@ -171,17 +179,18 @@ PMOP* pm;
if (regsize >= 32767L) /* Probably could be 65535L. */
FAIL("regexp too big");
- /* Allocate space. */
+ /* Allocate space and initialize. */
Newc(1001, r, sizeof(regexp) + (unsigned)regsize, char, regexp);
if (r == NULL)
FAIL("regexp out of space");
-
- /* Second pass: emit code. */
- r->prelen = xend-exp;
+ r->prelen = xend - exp;
r->precomp = regprecomp;
r->subbeg = r->subbase = NULL;
- regnaughty = 0;
+
+ /* Second pass: emit code. */
regparse = exp;
+ regxend = xend;
+ regnaughty = 0;
regnpar = 1;
regcode = r->program;
regc((char)MAGIC);
@@ -190,7 +199,6 @@ PMOP* pm;
/* Dig out information for optimizations. */
pm->op_pmflags = regflags;
- fold = pm->op_pmflags & PMf_FOLD;
r->regstart = Nullsv; /* Worst-case defaults. */
r->reganch = 0;
r->regmust = Nullsv;
@@ -216,36 +224,41 @@ PMOP* pm;
/* Starting-point info. */
again:
- if (OP(first) == EXACTLY) {
+ if (OP(first) == EXACT) {
r->regstart = newSVpv(OPERAND(first)+1,*OPERAND(first));
- if (SvCUR(r->regstart) > !(sawstudy|fold))
- fbm_compile(r->regstart,fold);
- else
- sv_upgrade(r->regstart, SVt_PVBM);
+ if (SvCUR(r->regstart) > !sawstudy)
+ fbm_compile(r->regstart);
+ (void)SvUPGRADE(r->regstart, SVt_PVBM);
}
else if (strchr(simple+2,OP(first)))
r->regstclass = first;
- else if (OP(first) == BOUND || OP(first) == NBOUND)
+ else if (regkind[(U8)OP(first)] == BOUND ||
+ regkind[(U8)OP(first)] == NBOUND)
r->regstclass = first;
else if (regkind[(U8)OP(first)] == BOL) {
- r->reganch = ROPT_ANCH;
+ r->reganch |= ROPT_ANCH_BOL;
+ first = NEXTOPER(first);
+ goto again;
+ }
+ else if (OP(first) == GPOS) {
+ r->reganch |= ROPT_ANCH_GPOS;
first = NEXTOPER(first);
- goto again;
+ 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 | ROPT_IMPLICIT;
+ r->reganch |= ROPT_ANCH_BOL | ROPT_IMPLICIT;
first = NEXTOPER(first);
- goto again;
+ goto again;
}
if (sawplus && (!sawopen || !regsawback))
r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */
- DEBUG_r(fprintf(stderr,"first %d next %d offset %d\n",
- OP(first), OP(NEXTOPER(first)), first - scan));
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "first %d next %d offset %ld\n",
+ OP(first), OP(NEXTOPER(first)), (long)(first - scan)));
/*
* If there's something expensive in the r.e., find the
* longest literal string that must appear and make it the
@@ -280,13 +293,13 @@ PMOP* pm;
scan = regnext(scan);
continue;
}
- if (OP(scan) == EXACTLY) {
+ if (OP(scan) == EXACT) {
char *t;
first = scan;
- while (OP(t = regnext(scan)) == CLOSE)
+ while ((t = regnext(scan)) && OP(t) == CLOSE)
scan = t;
- minlen += *OPERAND(first);
+ minlen += *OPERAND(first) * repeat_count;
if (curback - backish == len) {
sv_catpvn(longish, OPERAND(first)+1,
*OPERAND(first));
@@ -305,22 +318,57 @@ PMOP* pm;
curback += *OPERAND(first);
}
else if (strchr(varies,OP(scan))) {
- curback = -30000;
+ int tcount;
+ char *next;
+
+ if (repeat_depth < MAX_REPEAT_DEPTH
+ && ((OP(scan) == PLUS
+ && (tcount = 1)
+ && (next = NEXTOPER(scan)))
+ || (regkind[(U8)OP(scan)] == CURLY
+ && (tcount = ARG1(scan))
+ && (next = NEXTOPER(scan)+4))))
+ {
+ /* We treat (abc)+ as (abc)(abc)*. */
+
+ /* Mark the place to return back. */
+ repeat_stack[repeat_depth].opcode = regnext(scan);
+ repeat_stack[repeat_depth].count = repeat_count;
+ repeat_depth++;
+ repeat_count *= tcount;
+
+ /* Go deeper: */
+ scan = next;
+ continue;
+ }
+ else {
+ curback = -30000;
+ len = 0;
+ if (SvCUR(longish) > SvCUR(longest)) {
+ sv_setsv(longest,longish);
+ backest = backish;
+ }
+ sv_setpvn(longish,"",0);
+ }
+ }
+ else if (strchr(simple,OP(scan))) {
+ curback++;
+ minlen += repeat_count;
len = 0;
if (SvCUR(longish) > SvCUR(longest)) {
sv_setsv(longest,longish);
backest = backish;
}
sv_setpvn(longish,"",0);
- if (OP(scan) == PLUS && strchr(simple,OP(NEXTOPER(scan))))
- minlen++;
- else if (regkind[(U8)OP(scan)] == CURLY &&
- strchr(simple,OP(NEXTOPER(scan)+4)))
- minlen += ARG1(scan);
}
- else if (strchr(simple,OP(scan))) {
- curback++;
- minlen++;
+ scan = regnext(scan);
+ if (!scan) { /* Go up PLUS or CURLY. */
+ if (!repeat_depth--)
+ croak("panic: re scan");
+ scan = repeat_stack[repeat_depth].opcode;
+ repeat_count = repeat_stack[repeat_depth].count;
+ /* Need to submit the longest string found: */
+ curback = -30000;
len = 0;
if (SvCUR(longish) > SvCUR(longest)) {
sv_setsv(longest,longish);
@@ -328,13 +376,12 @@ PMOP* pm;
}
sv_setpvn(longish,"",0);
}
- scan = regnext(scan);
}
/* Prefer earlier on tie, unless we can tail match latter */
- if (SvCUR(longish) + (regkind[(U8)OP(first)] == EOL) >
- SvCUR(longest))
+ if (SvCUR(longish) + (first && regkind[(U8)OP(first)] == EOL)
+ > SvCUR(longest))
{
sv_setsv(longest,longish);
backest = backish;
@@ -342,26 +389,22 @@ PMOP* pm;
else
sv_setpvn(longish,"",0);
if (SvCUR(longest)
- &&
- (!r->regstart
- ||
- !fbm_instr((unsigned char*) SvPVX(r->regstart),
- (unsigned char *) SvPVX(r->regstart)
- + SvCUR(r->regstart),
- longest)
- )
- )
+ && (!r->regstart
+ || !fbm_instr((unsigned char*) SvPVX(r->regstart),
+ (unsigned char *) (SvPVX(r->regstart)
+ + SvCUR(r->regstart)),
+ longest)))
{
r->regmust = longest;
if (backest < 0)
backest = -1;
r->regback = backest;
- if (SvCUR(longest) > !(sawstudy || fold ||
- regkind[(U8)OP(first)]==EOL))
- fbm_compile(r->regmust,fold);
+ if (SvCUR(longest) > !(sawstudy ||
+ (first && regkind[(U8)OP(first)] == EOL)))
+ fbm_compile(r->regmust);
(void)SvUPGRADE(r->regmust, SVt_PVBM);
BmUSEFUL(r->regmust) = 100;
- if (regkind[(U8)OP(first)] == EOL && SvCUR(longish))
+ if (first && regkind[(U8)OP(first)] == EOL && SvCUR(longish))
SvTAIL_on(r->regmust);
}
else {
@@ -371,7 +414,6 @@ PMOP* pm;
SvREFCNT_dec(longish);
}
- r->do_folding = fold;
r->nparens = regnpar - 1;
r->minlen = minlen;
Newz(1002, r->startp, regnpar, char*);
@@ -415,7 +457,7 @@ I32 *flagp;
break;
case '$':
case '@':
- croak("Sequence (?%c...) not implemented", paren);
+ croak("Sequence (?%c...) not implemented", (int)paren);
break;
case '#':
while (*regparse && *regparse != ')')
@@ -425,9 +467,12 @@ I32 *flagp;
nextchar();
*flagp = TRYAGAIN;
return NULL;
+ case 0:
+ croak("Sequence (? incomplete");
+ break;
default:
--regparse;
- while (*regparse && strchr("iogmsx", *regparse))
+ while (*regparse && strchr("iogcmsx", *regparse))
pmflag(&regflags, *regparse++);
if (*regparse != ')')
croak("Sequence (?%c...) not recognized", *regparse);
@@ -655,6 +700,10 @@ I32 *flagp;
*flagp = flags;
return(ret);
}
+
+ if (!(flags&HASWIDTH) && op != '?')
+ FAIL("regexp *+ operand could be empty"); /* else may core dump */
+
nextchar();
*flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH);
@@ -770,10 +819,16 @@ tryagain:
croak("internal urp in regexp at /%s/", regparse);
/* Supposed to be caught earlier. */
break;
+ case '{':
+ if (!regcurly(regparse)) {
+ regparse++;
+ goto defchar;
+ }
+ /* FALL THROUGH */
case '?':
case '+':
case '*':
- FAIL("?+* follows nothing in regexp");
+ FAIL("?+*{} follows nothing in regexp");
break;
case '\\':
switch (*++regparse) {
@@ -783,7 +838,7 @@ tryagain:
nextchar();
break;
case 'G':
- ret = regnode(GBOL);
+ ret = regnode(GPOS);
*flagp |= SIMPLE;
nextchar();
break;
@@ -793,32 +848,32 @@ tryagain:
nextchar();
break;
case 'w':
- ret = regnode(ALNUM);
+ ret = regnode((regflags & PMf_LOCALE) ? ALNUML : ALNUM);
*flagp |= HASWIDTH|SIMPLE;
nextchar();
break;
case 'W':
- ret = regnode(NALNUM);
+ ret = regnode((regflags & PMf_LOCALE) ? NALNUML : NALNUM);
*flagp |= HASWIDTH|SIMPLE;
nextchar();
break;
case 'b':
- ret = regnode(BOUND);
+ ret = regnode((regflags & PMf_LOCALE) ? BOUNDL : BOUND);
*flagp |= SIMPLE;
nextchar();
break;
case 'B':
- ret = regnode(NBOUND);
+ ret = regnode((regflags & PMf_LOCALE) ? NBOUNDL : NBOUND);
*flagp |= SIMPLE;
nextchar();
break;
case 's':
- ret = regnode(SPACE);
+ ret = regnode((regflags & PMf_LOCALE) ? SPACEL : SPACE);
*flagp |= HASWIDTH|SIMPLE;
nextchar();
break;
case 'S':
- ret = regnode(NSPACE);
+ ret = regnode((regflags & PMf_LOCALE) ? NSPACEL : NSPACE);
*flagp |= HASWIDTH|SIMPLE;
nextchar();
break;
@@ -851,7 +906,9 @@ tryagain:
goto defchar;
else {
regsawback = 1;
- ret = reganode(REF, num);
+ ret = reganode((regflags & PMf_FOLD)
+ ? ((regflags & PMf_LOCALE) ? REFFL : REFF)
+ : REF, num);
*flagp |= HASWIDTH;
while (isDIGIT(*regparse))
regparse++;
@@ -887,13 +944,18 @@ tryagain:
regparse++;
defchar:
- ret = regnode(EXACTLY);
+ ret = regnode((regflags & PMf_FOLD)
+ ? ((regflags & PMf_LOCALE) ? EXACTFL : EXACTF)
+ : EXACT);
regc(0); /* save spot for len */
for (len = 0, p = regparse - 1;
len < 127 && p < regxend;
len++)
{
oldp = p;
+
+ if (regflags & PMf_EXTENDED)
+ p = regwhite(p, regxend);
switch (*p) {
case '^':
case '$':
@@ -948,10 +1010,8 @@ tryagain:
break;
case 'c':
p++;
- ender = *p++;
- if (isLOWER(ender))
- ender = toUPPER(ender);
- ender ^= 64;
+ 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':
@@ -974,24 +1034,12 @@ tryagain:
break;
}
break;
- case '#':
- if (regflags & PMf_EXTENDED) {
- while (p < regxend && *p != '\n') p++;
- }
- /* FALL THROUGH */
- case ' ': case '\t': case '\n': case '\r': case '\f': case '\v':
- if (regflags & PMf_EXTENDED) {
- p++;
- len--;
- continue;
- }
- /* FALL THROUGH */
default:
ender = *p++;
break;
}
- if (regflags & PMf_FOLD && isUPPER(ender))
- ender = toLOWER(ender);
+ if (regflags & PMf_EXTENDED)
+ p = regwhite(p, regxend);
if (ISMULT2(p)) { /* Back off on ?+*. */
if (len)
p = oldp;
@@ -1022,25 +1070,40 @@ tryagain:
return(ret);
}
+static char *
+regwhite(p, e)
+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 void
-regset(bits,def,c)
-char *bits;
-I32 def;
+regset(opnd, c)
+char *opnd;
register I32 c;
{
- if (regcode == &regdummy)
- return;
- c &= 255;
- if (def)
- bits[c >> 3] &= ~(1 << (c & 7));
- else
- bits[c >> 3] |= (1 << (c & 7));
+ if (opnd == &regdummy)
+ return;
+ c &= 0xFF;
+ opnd[1 + (c >> 3)] |= (1 << (c & 7));
}
static char *
regclass()
{
- register char *bits;
+ register char *opnd;
register I32 class;
register I32 lastclass = 1234;
register I32 range = 0;
@@ -1049,16 +1112,21 @@ regclass()
I32 numlen;
ret = regnode(ANYOF);
+ opnd = regcode;
+ for (class = 0; class < 33; class++)
+ regc(0);
if (*regparse == '^') { /* Complement of range. */
regnaughty++;
regparse++;
- def = 0;
- } else {
- def = 255;
+ if (opnd != &regdummy)
+ *opnd |= ANYOF_INVERT;
+ }
+ if (opnd != &regdummy) {
+ if (regflags & PMf_FOLD)
+ *opnd |= ANYOF_FOLD;
+ if (regflags & PMf_LOCALE)
+ *opnd |= ANYOF_LOCALE;
}
- bits = regcode;
- for (class = 0; class < 32; class++)
- regc(def);
if (*regparse == ']' || *regparse == '-')
goto skipcond; /* allow 1st char to be ] or - */
while (regparse < regxend && *regparse != ']') {
@@ -1068,39 +1136,63 @@ regclass()
class = UCHARAT(regparse++);
switch (class) {
case 'w':
- for (class = 0; class < 256; class++)
- if (isALNUM(class))
- regset(bits,def,class);
+ if (regflags & PMf_LOCALE) {
+ if (opnd != &regdummy)
+ *opnd |= ANYOF_ALNUML;
+ }
+ else {
+ for (class = 0; class < 256; class++)
+ if (isALNUM(class))
+ regset(opnd, class);
+ }
lastclass = 1234;
continue;
case 'W':
- for (class = 0; class < 256; class++)
- if (!isALNUM(class))
- regset(bits,def,class);
+ if (regflags & PMf_LOCALE) {
+ if (opnd != &regdummy)
+ *opnd |= ANYOF_NALNUML;
+ }
+ else {
+ for (class = 0; class < 256; class++)
+ if (!isALNUM(class))
+ regset(opnd, class);
+ }
lastclass = 1234;
continue;
case 's':
- for (class = 0; class < 256; class++)
- if (isSPACE(class))
- regset(bits,def,class);
+ if (regflags & PMf_LOCALE) {
+ if (opnd != &regdummy)
+ *opnd |= ANYOF_SPACEL;
+ }
+ else {
+ for (class = 0; class < 256; class++)
+ if (isSPACE(class))
+ regset(opnd, class);
+ }
lastclass = 1234;
continue;
case 'S':
- for (class = 0; class < 256; class++)
- if (!isSPACE(class))
- regset(bits,def,class);
+ if (regflags & PMf_LOCALE) {
+ if (opnd != &regdummy)
+ *opnd |= ANYOF_NSPACEL;
+ }
+ else {
+ for (class = 0; class < 256; class++)
+ if (!isSPACE(class))
+ regset(opnd, class);
+ }
lastclass = 1234;
continue;
case 'd':
for (class = '0'; class <= '9'; class++)
- regset(bits,def,class);
+ regset(opnd, class);
lastclass = 1234;
continue;
case 'D':
for (class = 0; class < '0'; class++)
- regset(bits,def,class);
+ regset(opnd, class);
for (class = '9' + 1; class < 256; class++)
- regset(bits,def,class);
+ regset(opnd, class);
lastclass = 1234;
continue;
case 'n':
@@ -1129,10 +1221,8 @@ regclass()
regparse += numlen;
break;
case 'c':
- class = *regparse++;
- if (isLOWER(class))
- class = toUPPER(class);
- class ^= 64;
+ class = UCHARAT(regparse++);
+ class = toCTRL(class);
break;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
@@ -1155,11 +1245,8 @@ regclass()
continue; /* do it next time */
}
}
- for ( ; lastclass <= class; lastclass++) {
- regset(bits,def,lastclass);
- if (regflags & PMf_FOLD && isUPPER(lastclass))
- regset(bits,def,toLOWER(lastclass));
- }
+ for ( ; lastclass <= class; lastclass++)
+ regset(opnd, lastclass);
lastclass = class;
}
if (*regparse != ']')
@@ -1432,16 +1519,16 @@ register char *s;
#ifdef DEBUGGING
/*
- - regdump - dump a regexp onto stderr in vaguely comprehensible form
+ - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
*/
void
regdump(r)
regexp *r;
{
register char *s;
- register char op = EXACTLY; /* Arbitrary non-END op. */
+ register char op = EXACT; /* Arbitrary non-END op. */
register char *next;
-
+ SV *sv = sv_newmortal();
s = r->program + 1;
while (op != END) { /* While that wasn't END last time... */
@@ -1450,61 +1537,71 @@ regexp *r;
s++;
#endif
op = OP(s);
- fprintf(stderr,"%2d%s", s-r->program, regprop(s)); /* Where, what. */
+ /* where, what */
+ regprop(sv, s);
+ PerlIO_printf(Perl_debug_log, "%2ld%s", (long)(s - r->program), SvPVX(sv));
next = regnext(s);
s += regarglen[(U8)op];
if (next == NULL) /* Next ptr. */
- fprintf(stderr,"(0)");
+ PerlIO_printf(Perl_debug_log, "(0)");
else
- fprintf(stderr,"(%d)", (s-r->program)+(next-s));
+ PerlIO_printf(Perl_debug_log, "(%ld)", (long)(s-r->program)+(next-s));
s += 3;
if (op == ANYOF) {
- s += 32;
+ s += 33;
}
- if (op == EXACTLY) {
+ if (regkind[(U8)op] == EXACT) {
/* Literal string, where present. */
s++;
- (void)putc(' ', stderr);
- (void)putc('<', stderr);
+ (void)PerlIO_putc(Perl_debug_log, ' ');
+ (void)PerlIO_putc(Perl_debug_log, '<');
while (*s != '\0') {
- (void)putc(*s, stderr);
+ (void)PerlIO_putc(Perl_debug_log,*s);
s++;
}
- (void)putc('>', stderr);
+ (void)PerlIO_putc(Perl_debug_log, '>');
s++;
}
- (void)putc('\n', stderr);
+ (void)PerlIO_putc(Perl_debug_log, '\n');
}
/* Header fields of interest. */
if (r->regstart)
- fprintf(stderr,"start `%s' ", SvPVX(r->regstart));
- if (r->regstclass)
- fprintf(stderr,"stclass `%s' ", regprop(r->regstclass));
- if (r->reganch & ROPT_ANCH)
- fprintf(stderr,"anchored ");
+ PerlIO_printf(Perl_debug_log, "start `%s' ", SvPVX(r->regstart));
+ 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_GPOS)
+ PerlIO_printf(Perl_debug_log, "(GPOS)");
+ PerlIO_putc(Perl_debug_log, ' ');
+ }
if (r->reganch & ROPT_SKIP)
- fprintf(stderr,"plus ");
+ PerlIO_printf(Perl_debug_log, "plus ");
if (r->reganch & ROPT_IMPLICIT)
- fprintf(stderr,"implicit ");
+ PerlIO_printf(Perl_debug_log, "implicit ");
if (r->regmust != NULL)
- fprintf(stderr,"must have \"%s\" back %ld ", SvPVX(r->regmust),
+ PerlIO_printf(Perl_debug_log, "must have \"%s\" back %ld ", SvPVX(r->regmust),
(long) r->regback);
- fprintf(stderr, "minlen %ld ", (long) r->minlen);
- fprintf(stderr,"\n");
+ PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
+ PerlIO_printf(Perl_debug_log, "\n");
}
/*
- regprop - printable representation of opcode
*/
-char *
-regprop(op)
+void
+regprop(sv, op)
+SV *sv;
char *op;
{
register char *p = 0;
- (void) strcpy(buf, ":");
-
+ sv_setpv(sv, ":");
switch (OP(op)) {
case BOL:
p = "BOL";
@@ -1536,8 +1633,14 @@ char *op;
case BRANCH:
p = "BRANCH";
break;
- case EXACTLY:
- p = "EXACTLY";
+ case EXACT:
+ p = "EXACT";
+ break;
+ case EXACTF:
+ p = "EXACTF";
+ break;
+ case EXACTFL:
+ p = "EXACTFL";
break;
case NOTHING:
p = "NOTHING";
@@ -1548,48 +1651,38 @@ char *op;
case END:
p = "END";
break;
- case ALNUM:
- p = "ALNUM";
- break;
- case NALNUM:
- p = "NALNUM";
- break;
case BOUND:
p = "BOUND";
break;
+ case BOUNDL:
+ p = "BOUNDL";
+ break;
case NBOUND:
p = "NBOUND";
break;
- case SPACE:
- p = "SPACE";
- break;
- case NSPACE:
- p = "NSPACE";
- break;
- case DIGIT:
- p = "DIGIT";
- break;
- case NDIGIT:
- p = "NDIGIT";
+ case NBOUNDL:
+ p = "NBOUNDL";
break;
case CURLY:
- (void)sprintf(buf+strlen(buf), "CURLY {%d,%d}", ARG1(op),ARG2(op));
- p = NULL;
+ sv_catpvf(sv, "CURLY {%d,%d}", ARG1(op), ARG2(op));
break;
case CURLYX:
- (void)sprintf(buf+strlen(buf), "CURLYX {%d,%d}", ARG1(op),ARG2(op));
- p = NULL;
+ sv_catpvf(sv, "CURLYX {%d,%d}", ARG1(op), ARG2(op));
break;
case REF:
- (void)sprintf(buf+strlen(buf), "REF%d", ARG1(op));
- p = NULL;
+ sv_catpvf(sv, "REF%d", ARG1(op));
+ break;
+ case REFF:
+ sv_catpvf(sv, "REFF%d", ARG1(op));
+ break;
+ case REFFL:
+ sv_catpvf(sv, "REFFL%d", ARG1(op));
break;
case OPEN:
- (void)sprintf(buf+strlen(buf), "OPEN%d", ARG1(op));
- p = NULL;
+ sv_catpvf(sv, "OPEN%d", ARG1(op));
break;
case CLOSE:
- (void)sprintf(buf+strlen(buf), "CLOSE%d", ARG1(op));
+ sv_catpvf(sv, "CLOSE%d", ARG1(op));
p = NULL;
break;
case STAR:
@@ -1601,8 +1694,8 @@ char *op;
case MINMOD:
p = "MINMOD";
break;
- case GBOL:
- p = "GBOL";
+ case GPOS:
+ p = "GPOS";
break;
case UNLESSM:
p = "UNLESSM";
@@ -1616,12 +1709,41 @@ char *op;
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;
default:
FAIL("corrupted regexp opcode");
}
- if (p != NULL)
- (void) strcat(buf, p);
- return(buf);
+ if (p)
+ sv_catpv(sv, p);
}
#endif /* DEBUGGING */
diff --git a/gnu/usr.bin/perl/regcomp.h b/gnu/usr.bin/perl/regcomp.h
index b2d9b846f7b..5915086390d 100644
--- a/gnu/usr.bin/perl/regcomp.h
+++ b/gnu/usr.bin/perl/regcomp.h
@@ -48,41 +48,51 @@
*/
/* definition number opnd? meaning */
-#define END 0 /* no End of program. */
-#define BOL 1 /* no Match "" at beginning of line. */
-#define MBOL 2 /* no Same, assuming multiline. */
-#define SBOL 3 /* no Same, assuming singleline. */
-#define EOL 4 /* no Match "" at end of line. */
-#define MEOL 5 /* no Same, assuming multiline. */
-#define SEOL 6 /* no Same, assuming singleline. */
-#define ANY 7 /* no Match any one character (except newline). */
-#define SANY 8 /* no Match any one character. */
-#define ANYOF 9 /* sv Match character in (or not in) this class. */
+#define END 0 /* no End of program. */
+#define BOL 1 /* no Match "" at beginning of line. */
+#define MBOL 2 /* no Same, assuming multiline. */
+#define SBOL 3 /* no Same, assuming singleline. */
+#define EOL 4 /* no Match "" at end of line. */
+#define MEOL 5 /* no Same, assuming multiline. */
+#define SEOL 6 /* no Same, assuming singleline. */
+#define ANY 7 /* no Match any one character (except newline). */
+#define SANY 8 /* no Match any one character. */
+#define ANYOF 9 /* sv Match character in (or not in) this class. */
#define CURLY 10 /* sv Match this simple thing {n,m} times. */
#define CURLYX 11 /* sv Match this complex thing {n,m} times. */
#define BRANCH 12 /* node Match this alternative, or the next... */
#define BACK 13 /* no Match "", "next" ptr points backward. */
-#define EXACTLY 14 /* sv Match this string (preceded by length). */
-#define NOTHING 15 /* no Match empty string. */
-#define STAR 16 /* node Match this (simple) thing 0 or more times. */
-#define PLUS 17 /* node Match this (simple) thing 1 or more times. */
-#define ALNUM 18 /* no Match any alphanumeric character */
-#define NALNUM 19 /* no Match any non-alphanumeric character */
+#define EXACT 14 /* sv Match this string (preceded by length). */
+#define EXACTF 15 /* sv Match this string, folded (prec. by length). */
+#define EXACTFL 16 /* sv Match this string, folded in locale (w/len). */
+#define NOTHING 17 /* no Match empty string. */
+#define STAR 18 /* node Match this (simple) thing 0 or more times. */
+#define PLUS 19 /* node Match this (simple) thing 1 or more times. */
#define BOUND 20 /* no Match "" at any word boundary */
-#define NBOUND 21 /* no Match "" at any word non-boundary */
-#define SPACE 22 /* no Match any whitespace character */
-#define NSPACE 23 /* no Match any non-whitespace character */
-#define DIGIT 24 /* no Match any numeric character */
-#define NDIGIT 25 /* no Match any non-numeric character */
-#define REF 26 /* num Match some already matched string */
+#define BOUNDL 21 /* no Match "" at any word boundary */
+#define NBOUND 22 /* no Match "" at any word non-boundary */
+#define NBOUNDL 23 /* no Match "" at any word non-boundary */
+#define REF 24 /* num Match already matched string */
+#define REFF 25 /* num Match already matched string, folded */
+#define REFFL 26 /* num Match already matched string, folded in loc. */
#define OPEN 27 /* num Mark this point in input as start of #n. */
#define CLOSE 28 /* num Analogous to OPEN. */
#define MINMOD 29 /* no Next operator is not greedy. */
-#define GBOL 30 /* no Matches where last m//g left off. */
+#define GPOS 30 /* no Matches where last m//g left off. */
#define IFMATCH 31 /* no Succeeds if the following matches. */
#define UNLESSM 32 /* no Fails if the following matches. */
#define SUCCEED 33 /* no Return from a subroutine, basically. */
#define WHILEM 34 /* no Do curly processing and see if rest matches. */
+#define ALNUM 35 /* no Match any alphanumeric character */
+#define ALNUML 36 /* no Match any alphanumeric char in locale */
+#define NALNUM 37 /* no Match any non-alphanumeric character */
+#define NALNUML 38 /* no Match any non-alphanumeric char in locale */
+#define SPACE 39 /* no Match any whitespace character */
+#define SPACEL 40 /* no Match any whitespace char in locale */
+#define NSPACE 41 /* no Match any non-whitespace character */
+#define NSPACEL 42 /* no Match any non-whitespace char in locale */
+#define DIGIT 43 /* no Match any numeric character */
+#define NDIGIT 44 /* no Match any non-numeric character */
/*
* Opcode notes:
@@ -109,7 +119,13 @@
#ifndef DOINIT
EXT char regarglen[];
#else
-EXT char regarglen[] = {0,0,0,0,0,0,0,0,0,0,4,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2,2,2,0,0,0,0,0};
+EXT char regarglen[] = {
+ 0,0,0,0,0,0,0,0,0,0,
+ /*CURLY*/ 4, /*CURLYX*/ 4,
+ 0,0,0,0,0,0,0,0,0,0,0,0,
+ /*REF*/ 2, 2, 2, /*OPEN*/ 2, /*CLOSE*/ 2,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
+};
#endif
#ifndef DOINIT
@@ -130,27 +146,37 @@ EXT char regkind[] = {
CURLY,
BRANCH,
BACK,
- EXACTLY,
+ EXACT,
+ EXACT,
+ EXACT,
NOTHING,
STAR,
PLUS,
- ALNUM,
- NALNUM,
+ BOUND,
BOUND,
NBOUND,
- SPACE,
- NSPACE,
- DIGIT,
- NDIGIT,
+ NBOUND,
+ REF,
+ REF,
REF,
OPEN,
CLOSE,
MINMOD,
- BOL,
+ GPOS,
BRANCH,
BRANCH,
END,
- WHILEM
+ WHILEM,
+ ALNUM,
+ ALNUM,
+ NALNUM,
+ NALNUM,
+ SPACE,
+ SPACE,
+ NSPACE,
+ NSPACE,
+ DIGIT,
+ NDIGIT,
};
#endif
@@ -158,14 +184,21 @@ EXT char regkind[] = {
#ifndef DOINIT
EXT char varies[];
#else
-EXT char varies[] = {BRANCH,BACK,STAR,PLUS,CURLY,CURLYX,REF,WHILEM,0};
+EXT char varies[] = {
+ BRANCH, BACK, STAR, PLUS, CURLY, CURLYX, REF, REFF, REFFL, WHILEM, 0
+};
#endif
/* The following always have a length of 1. */
#ifndef DOINIT
EXT char simple[];
#else
-EXT char simple[] = {ANY,SANY,ANYOF,ALNUM,NALNUM,SPACE,NSPACE,DIGIT,NDIGIT,0};
+EXT char simple[] = {
+ ANY, SANY, ANYOF,
+ ALNUM, ALNUML, NALNUM, NALNUML,
+ SPACE, SPACEL, NSPACE, NSPACEL,
+ DIGIT, NDIGIT, 0
+};
#endif
EXT char regdummy;
@@ -222,6 +255,16 @@ EXT char regdummy;
#define MAGIC 0234
+/* 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 definitions.
*/
diff --git a/gnu/usr.bin/perl/regexec.c b/gnu/usr.bin/perl/regexec.c
index 6a29d7f0320..c640d6758d5 100644
--- a/gnu/usr.bin/perl/regexec.c
+++ b/gnu/usr.bin/perl/regexec.c
@@ -42,7 +42,7 @@
*
**** Alterations to Henry's code are...
****
- **** Copyright (c) 1991-1994, Larry Wall
+ **** 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.
@@ -82,10 +82,10 @@ static CURCUR* regcc;
typedef I32 CHECKPOINT;
-CHECKPOINT regcppush _((I32 parenfloor));
-char * regcppop _((void));
+static CHECKPOINT regcppush _((I32 parenfloor));
+static char * regcppop _((void));
-CHECKPOINT
+static CHECKPOINT
regcppush(parenfloor)
I32 parenfloor;
{
@@ -107,7 +107,7 @@ I32 parenfloor;
return retval;
}
-char*
+static char *
regcppop()
{
I32 i = SSPOPINT;
@@ -134,6 +134,36 @@ regcppop()
return input;
}
+/* After a successful match in WHILEM, we want to restore paren matches
+ * that have been overwritten by a failed match attempt in the process
+ * of reaching this success. We do this by restoring regstartp[i]
+ * wherever regendp[i] has not changed; if OPEN is changed to modify
+ * regendp[], the '== endp' test below should be changed to match.
+ * This corrects the error of:
+ * 0 > length [ "foobar" =~ / ( (foo) | (bar) )* /x ]->[1]
+ */
+static void
+regcppartblow(base)
+I32 base;
+{
+ I32 i = SSPOPINT;
+ U32 paren;
+ char *startp;
+ char *endp;
+ assert(i == SAVEt_REGCONTEXT);
+ i = SSPOPINT;
+ /* input, lastparen, size */
+ SSPOPPTR; SSPOPINT; SSPOPINT;
+ for (i -= 3; i > 0; i -= 3) {
+ paren = (U32)SSPOPINT;
+ startp = (char *) SSPOPPTR;
+ endp = (char *) SSPOPPTR;
+ if (paren <= *reglastparen && regendp[paren] == endp)
+ regstartp[paren] = startp;
+ }
+ assert(savestack_ix == base);
+}
+
#define regcpblow(cp) leave_scope(cp)
/*
@@ -147,6 +177,9 @@ regcppop()
static I32 regmatch _((char *prog));
static I32 regrepeat _((char *p, I32 max));
static I32 regtry _((regexp *prog, char *startpos));
+static bool reginclass _((char *p, I32 c));
+
+static bool regtainted; /* tainted information used? */
/*
- pregexec - match a regexp against a string
@@ -162,7 +195,6 @@ SV *screamer;
I32 safebase; /* no need to remember string in subbase */
{
register char *s;
- register I32 i;
register char *c;
register char *startpos = stringarg;
register I32 tmp;
@@ -192,28 +224,21 @@ I32 safebase; /* no need to remember string in subbase */
if (!multiline && regprev == '\n')
regprev = '\0'; /* force ^ to NOT match */
}
+
regprecomp = prog->precomp;
- regnpar = prog->nparens;
/* Check validity of program. */
if (UCHARAT(prog->program) != MAGIC) {
FAIL("corrupted regexp program");
}
- if (prog->do_folding) {
- i = strend - startpos;
- New(1101,c,i+1,char);
- Copy(startpos, c, i+1, char);
- startpos = c;
- strend = startpos + i;
- for (s = startpos; s < strend; s++)
- if (isUPPER(*s))
- *s = toLOWER(*s);
- }
+ regnpar = prog->nparens;
+ regtainted = FALSE;
/* If there is a "must appear" string, look for it. */
s = startpos;
if (prog->regmust != Nullsv &&
- (!(prog->reganch & ROPT_ANCH)
+ !(prog->reganch & ROPT_ANCH_GPOS) &&
+ (!(prog->reganch & ROPT_ANCH_BOL)
|| (multiline && prog->regback >= 0)) )
{
if (stringarg == strbeg && screamer) {
@@ -256,11 +281,13 @@ I32 safebase; /* no need to remember string in subbase */
regtill = startpos+minend;
/* Simplest case: anchored match need be tried only once. */
- /* [unless multiline is set] */
+ /* [unless only anchor is BOL and multiline is set] */
if (prog->reganch & ROPT_ANCH) {
if (regtry(prog, startpos))
goto got_it;
- else if (multiline || (prog->reganch & ROPT_IMPLICIT)) {
+ else if (!(prog->reganch & ROPT_ANCH_GPOS) &&
+ (multiline || (prog->reganch & ROPT_IMPLICIT)))
+ {
if (minlen)
dontbother = minlen - 1;
strend -= dontbother;
@@ -281,19 +308,19 @@ I32 safebase; /* no need to remember string in subbase */
if (prog->regstart) {
if (prog->reganch & ROPT_SKIP) { /* we have /x+whatever/ */
/* it must be a one character string */
- i = SvPVX(prog->regstart)[0];
+ char ch = SvPVX(prog->regstart)[0];
while (s < strend) {
- if (*s == i) {
+ if (*s == ch) {
if (regtry(prog, s))
goto got_it;
s++;
- while (s < strend && *s == i)
+ while (s < strend && *s == ch)
s++;
}
s++;
}
}
- else if (SvPOK(prog->regstart) == 3) {
+ else if (SvTYPE(prog->regstart) == SVt_PVBM) {
/* We know what string it must start with. */
while ((s = fbm_instr((unsigned char*)s,
(unsigned char*)strend, prog->regstart)) != NULL)
@@ -303,7 +330,7 @@ I32 safebase; /* no need to remember string in subbase */
s++;
}
}
- else {
+ else { /* Optimized fbm_instr: */
c = SvPVX(prog->regstart);
while ((s = ninstr(s, strend, c, c + SvCUR(prog->regstart))) != NULL)
{
@@ -327,8 +354,7 @@ I32 safebase; /* no need to remember string in subbase */
case ANYOF:
c = OPERAND(c);
while (s < strend) {
- i = UCHARAT(s);
- if (!(c[i >> 3] & (1 << (i&7)))) {
+ if (reginclass(c, *s)) {
if (tmp && regtry(prog, s))
goto got_it;
else
@@ -339,18 +365,16 @@ I32 safebase; /* no need to remember string in subbase */
s++;
}
break;
+ case BOUNDL:
+ regtainted = TRUE;
+ /* FALL THROUGH */
case BOUND:
if (minlen)
dontbother++,strend--;
- if (s != startpos) {
- i = s[-1];
- tmp = isALNUM(i);
- }
- else
- tmp = isALNUM(regprev); /* assume not alphanumeric */
+ tmp = (s != startpos) ? UCHARAT(s - 1) : regprev;
+ tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
while (s < strend) {
- i = *s;
- if (tmp != isALNUM(i)) {
+ if (tmp == !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
tmp = !tmp;
if (regtry(prog, s))
goto got_it;
@@ -360,18 +384,16 @@ I32 safebase; /* no need to remember string in subbase */
if ((minlen || tmp) && regtry(prog,s))
goto got_it;
break;
+ case NBOUNDL:
+ regtainted = TRUE;
+ /* FALL THROUGH */
case NBOUND:
if (minlen)
dontbother++,strend--;
- if (s != startpos) {
- i = s[-1];
- tmp = isALNUM(i);
- }
- else
- tmp = isALNUM(regprev); /* assume not alphanumeric */
+ tmp = (s != startpos) ? UCHARAT(s - 1) : regprev;
+ tmp = ((OP(c) == NBOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
while (s < strend) {
- i = *s;
- if (tmp != isALNUM(i))
+ if (tmp == !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
tmp = !tmp;
else if (regtry(prog, s))
goto got_it;
@@ -382,8 +404,21 @@ I32 safebase; /* no need to remember string in subbase */
break;
case ALNUM:
while (s < strend) {
- i = *s;
- if (isALNUM(i)) {
+ if (isALNUM(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case ALNUML:
+ regtainted = TRUE;
+ while (s < strend) {
+ if (isALNUM_LC(*s)) {
if (tmp && regtry(prog, s))
goto got_it;
else
@@ -396,8 +431,21 @@ I32 safebase; /* no need to remember string in subbase */
break;
case NALNUM:
while (s < strend) {
- i = *s;
- if (!isALNUM(i)) {
+ if (!isALNUM(*s)) {
+ if (tmp && regtry(prog, s))
+ goto got_it;
+ else
+ tmp = doevery;
+ }
+ else
+ tmp = 1;
+ s++;
+ }
+ break;
+ case NALNUML:
+ regtainted = TRUE;
+ while (s < strend) {
+ if (!isALNUM_LC(*s)) {
if (tmp && regtry(prog, s))
goto got_it;
else
@@ -421,6 +469,20 @@ I32 safebase; /* no need to remember string in subbase */
s++;
}
break;
+ case SPACEL:
+ regtainted = TRUE;
+ 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)) {
@@ -434,6 +496,20 @@ I32 safebase; /* no need to remember string in subbase */
s++;
}
break;
+ case NSPACEL:
+ regtainted = TRUE;
+ 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)) {
@@ -480,38 +556,35 @@ got_it:
strend += dontbother; /* uncheat */
prog->subbeg = strbeg;
prog->subend = strend;
- if ((!safebase && (prog->nparens || sawampersand)) || prog->do_folding) {
- i = strend - startpos + (stringarg - strbeg);
- if (safebase) { /* no need for $digit later */
- s = strbeg;
- prog->subend = s+i;
- }
- else if (strbeg != prog->subbase) {
- s = savepvn(strbeg,i); /* so $digit will work later */
- if (prog->subbase)
+ prog->exec_tainted = regtainted;
+
+ /* make sure $`, $&, $', and $digit will work later */
+ if (strbeg != prog->subbase) {
+ if (safebase) {
+ if (prog->subbase) {
Safefree(prog->subbase);
- prog->subbeg = prog->subbase = s;
- prog->subend = s+i;
+ prog->subbase = Nullch;
+ }
}
else {
- prog->subbeg = s = prog->subbase;
- prog->subend = s+i;
- }
- s += (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);
+ I32 i = strend - 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);
+ }
}
}
- if (prog->do_folding)
- Safefree(startpos);
}
return 1;
phooey:
- if (prog->do_folding)
- Safefree(startpos);
return 0;
}
@@ -576,13 +649,14 @@ char *prog;
register I32 ln; /* len or last */
register char *s; /* operand or save */
register char *locinput = reginput;
+ register I32 c1, c2; /* case fold search */
int minmod = 0;
#ifdef DEBUGGING
static int regindent = 0;
regindent++;
#endif
- nextchar = *locinput;
+ nextchar = UCHARAT(locinput);
scan = prog;
while (scan != NULL) {
#ifdef DEBUGGING
@@ -590,8 +664,11 @@ char *prog;
#define sayNO goto no
#define saySAME(x) if (x) goto yes; else goto no
if (regnarrate) {
- fprintf(stderr, "%*s%2d%-8.8s\t<%.10s>\n", regindent*2, "",
- scan - regprogram, regprop(scan), locinput);
+ SV *prop = sv_newmortal();
+ regprop(prop, scan);
+ PerlIO_printf(Perl_debug_log, "%*s%2ld%-8.8s\t<%.10s>\n",
+ regindent*2, "", (long)(scan - regprogram),
+ SvPVX(prop), locinput);
}
#else
#define sayYES return 1
@@ -629,7 +706,7 @@ char *prog;
if (locinput == regbol && regprev == '\n')
break;
sayNO;
- case GBOL:
+ case GPOS:
if (locinput == regbol)
break;
sayNO;
@@ -653,87 +730,136 @@ char *prog;
case SANY:
if (!nextchar && locinput >= regeol)
sayNO;
- nextchar = *++locinput;
+ nextchar = UCHARAT(++locinput);
break;
case ANY:
if (!nextchar && locinput >= regeol || nextchar == '\n')
sayNO;
- nextchar = *++locinput;
+ nextchar = UCHARAT(++locinput);
break;
- case EXACTLY:
+ case EXACT:
s = OPERAND(scan);
ln = *s++;
/* Inline the first character, for speed. */
- if (*s != nextchar)
+ if (UCHARAT(s) != nextchar)
sayNO;
if (regeol - locinput < ln)
sayNO;
- if (ln > 1 && bcmp(s, locinput, ln) != 0)
+ if (ln > 1 && memNE(s, locinput, ln))
sayNO;
locinput += ln;
- nextchar = *locinput;
+ nextchar = UCHARAT(locinput);
+ break;
+ case EXACTFL:
+ regtainted = TRUE;
+ /* FALL THROUGH */
+ case EXACTF:
+ s = OPERAND(scan);
+ ln = *s++;
+ /* Inline the first character, for speed. */
+ if (UCHARAT(s) != nextchar &&
+ UCHARAT(s) != ((OP(scan) == EXACTF)
+ ? fold : fold_locale)[nextchar])
+ sayNO;
+ if (regeol - locinput < ln)
+ sayNO;
+ if (ln > 1 && (OP(scan) == EXACTF
+ ? ibcmp(s, locinput, ln)
+ : ibcmp_locale(s, locinput, ln)))
+ sayNO;
+ locinput += ln;
+ nextchar = UCHARAT(locinput);
break;
case ANYOF:
s = OPERAND(scan);
if (nextchar < 0)
nextchar = UCHARAT(locinput);
- if (s[nextchar >> 3] & (1 << (nextchar&7)))
+ if (!reginclass(s, nextchar))
sayNO;
if (!nextchar && locinput >= regeol)
sayNO;
- nextchar = *++locinput;
+ nextchar = UCHARAT(++locinput);
break;
+ case ALNUML:
+ regtainted = TRUE;
+ /* FALL THROUGH */
case ALNUM:
if (!nextchar)
sayNO;
- if (!isALNUM(nextchar))
+ if (!(OP(scan) == ALNUM
+ ? isALNUM(nextchar) : isALNUM_LC(nextchar)))
sayNO;
- nextchar = *++locinput;
+ nextchar = UCHARAT(++locinput);
break;
+ case NALNUML:
+ regtainted = TRUE;
+ /* FALL THROUGH */
case NALNUM:
if (!nextchar && locinput >= regeol)
sayNO;
- if (isALNUM(nextchar))
+ if (OP(scan) == NALNUM
+ ? isALNUM(nextchar) : isALNUM_LC(nextchar))
sayNO;
- nextchar = *++locinput;
+ nextchar = UCHARAT(++locinput);
break;
- case NBOUND:
+ case BOUNDL:
+ case NBOUNDL:
+ regtainted = TRUE;
+ /* FALL THROUGH */
case BOUND:
- if (locinput == regbol) /* was last char in word? */
- ln = isALNUM(regprev);
- else
- ln = isALNUM(locinput[-1]);
- n = isALNUM(nextchar); /* is next char in word? */
- if ((ln == n) == (OP(scan) == BOUND))
+ case NBOUND:
+ /* was last char in word? */
+ ln = (locinput != regbol) ? UCHARAT(locinput - 1) : regprev;
+ if (OP(scan) == BOUND || OP(scan) == NBOUND) {
+ ln = isALNUM(ln);
+ n = isALNUM(nextchar);
+ }
+ else {
+ ln = isALNUM_LC(ln);
+ n = isALNUM_LC(nextchar);
+ }
+ if (((!ln) == (!n)) == (OP(scan) == BOUND || OP(scan) == BOUNDL))
sayNO;
break;
+ case SPACEL:
+ regtainted = TRUE;
+ /* FALL THROUGH */
case SPACE:
if (!nextchar && locinput >= regeol)
sayNO;
- if (!isSPACE(nextchar))
+ if (!(OP(scan) == SPACE
+ ? isSPACE(nextchar) : isSPACE_LC(nextchar)))
sayNO;
- nextchar = *++locinput;
+ nextchar = UCHARAT(++locinput);
break;
+ case NSPACEL:
+ regtainted = TRUE;
+ /* FALL THROUGH */
case NSPACE:
if (!nextchar)
sayNO;
- if (isSPACE(nextchar))
+ if (OP(scan) == SPACE
+ ? isSPACE(nextchar) : isSPACE_LC(nextchar))
sayNO;
- nextchar = *++locinput;
+ nextchar = UCHARAT(++locinput);
break;
case DIGIT:
if (!isDIGIT(nextchar))
sayNO;
- nextchar = *++locinput;
+ nextchar = UCHARAT(++locinput);
break;
case NDIGIT:
if (!nextchar && locinput >= regeol)
sayNO;
if (isDIGIT(nextchar))
sayNO;
- nextchar = *++locinput;
+ nextchar = UCHARAT(++locinput);
break;
+ case REFFL:
+ regtainted = TRUE;
+ /* FALL THROUGH */
case REF:
+ case REFF:
n = ARG1(scan); /* which paren pair */
s = regstartp[n];
if (!s)
@@ -743,15 +869,22 @@ char *prog;
if (s == regendp[n])
break;
/* Inline the first character, for speed. */
- if (*s != nextchar)
+ if (UCHARAT(s) != nextchar &&
+ (OP(scan) == REF ||
+ (UCHARAT(s) != ((OP(scan) == REFF
+ ? fold : fold_locale)[nextchar]))))
sayNO;
ln = regendp[n] - s;
if (locinput + ln > regeol)
sayNO;
- if (ln > 1 && bcmp(s, locinput, ln) != 0)
+ 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;
- nextchar = *locinput;
+ nextchar = UCHARAT(locinput);
break;
case NOTHING:
@@ -800,19 +933,20 @@ char *prog;
* that we can try again after backing off.
*/
+ CHECKPOINT cp;
CURCUR* cc = regcc;
n = cc->cur + 1; /* how many we know we matched */
reginput = locinput;
#ifdef DEBUGGING
if (regnarrate)
- fprintf(stderr, "%*s %d %lx\n", regindent*2, "",
- n, (long)cc);
+ PerlIO_printf(Perl_debug_log, "%*s %ld %lx\n", regindent*2, "",
+ (long)n, (long)cc);
#endif
/* If degenerate scan matches "", assume scan done. */
- if (locinput == cc->lastloc) {
+ if (locinput == cc->lastloc && n >= cc->min) {
regcc = cc->oldcc;
ln = regcc->cur;
if (regmatch(cc->next))
@@ -838,8 +972,12 @@ char *prog;
if (cc->minmod) {
regcc = cc->oldcc;
ln = regcc->cur;
- if (regmatch(cc->next))
+ cp = regcppush(cc->parenfloor);
+ if (regmatch(cc->next)) {
+ regcppartblow(cp);
sayYES; /* All done. */
+ }
+ regcppop();
regcc->cur = ln;
regcc = cc;
@@ -850,8 +988,12 @@ char *prog;
reginput = locinput;
cc->cur = n;
cc->lastloc = locinput;
- if (regmatch(cc->scan))
+ cp = regcppush(cc->parenfloor);
+ if (regmatch(cc->scan)) {
+ regcppartblow(cp);
sayYES;
+ }
+ regcppop();
cc->cur = n - 1;
sayNO;
}
@@ -859,11 +1001,13 @@ char *prog;
/* Prefer scan over next for maximal matching. */
if (n < cc->max) { /* More greed allowed? */
- regcppush(cc->parenfloor);
+ cp = regcppush(cc->parenfloor);
cc->cur = n;
cc->lastloc = locinput;
- if (regmatch(cc->scan))
+ if (regmatch(cc->scan)) {
+ regcppartblow(cp);
sayYES;
+ }
regcppop(); /* Restore some previous $<digit>s? */
reginput = locinput;
}
@@ -929,10 +1073,17 @@ char *prog;
n = 32767;
scan = NEXTOPER(scan);
repeat:
- if (OP(next) == EXACTLY)
- nextchar = *(OPERAND(next)+1);
+ 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
- nextchar = -1000;
+ c1 = c2 = -1000;
reginput = locinput;
if (minmod) {
minmod = 0;
@@ -940,9 +1091,13 @@ char *prog;
sayNO;
while (n >= ln || (n == 32767 && ln > 0)) { /* ln overflow ? */
/* If it could work, try it. */
- if (nextchar == -1000 || *reginput == nextchar)
+ if (c1 == -1000 ||
+ UCHARAT(reginput) == c1 ||
+ UCHARAT(reginput) == c2)
+ {
if (regmatch(next))
sayYES;
+ }
/* Couldn't or didn't -- back up. */
reginput = locinput + ln;
if (regrepeat(scan, 1)) {
@@ -960,9 +1115,13 @@ char *prog;
ln = n; /* why back off? */
while (n >= ln) {
/* If it could work, try it. */
- if (nextchar == -1000 || *reginput == nextchar)
+ if (c1 == -1000 ||
+ UCHARAT(reginput) == c1 ||
+ UCHARAT(reginput) == c2)
+ {
if (regmatch(next))
sayYES;
+ }
/* Couldn't or didn't -- back up. */
n--;
reginput = locinput + n;
@@ -986,7 +1145,8 @@ char *prog;
sayNO;
break;
default:
- fprintf(stderr, "%x %d\n",(unsigned)scan,scan[1]);
+ PerlIO_printf(PerlIO_stderr(), "%lx %d\n",
+ (unsigned long)scan, scan[1]);
FAIL("regexp memory corruption");
}
scan = next;
@@ -1043,34 +1203,64 @@ I32 max;
case SANY:
scan = loceol;
break;
- case EXACTLY: /* length of string is 1 */
- opnd++;
- while (scan < loceol && *opnd == *scan)
+ 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 */
+ regtainted = TRUE;
+ c = UCHARAT(++opnd);
+ while (scan < loceol &&
+ (UCHARAT(scan) == c || UCHARAT(scan) == fold_locale[c]))
scan++;
break;
case ANYOF:
- c = UCHARAT(scan);
- while (scan < loceol && !(opnd[c >> 3] & (1 << (c & 7)))) {
+ while (scan < loceol && reginclass(opnd, *scan))
scan++;
- c = UCHARAT(scan);
- }
break;
case ALNUM:
while (scan < loceol && isALNUM(*scan))
scan++;
break;
+ case ALNUML:
+ regtainted = TRUE;
+ while (scan < loceol && isALNUM_LC(*scan))
+ scan++;
+ break;
case NALNUM:
while (scan < loceol && !isALNUM(*scan))
scan++;
break;
+ case NALNUML:
+ regtainted = TRUE;
+ while (scan < loceol && !isALNUM_LC(*scan))
+ scan++;
+ break;
case SPACE:
while (scan < loceol && isSPACE(*scan))
scan++;
break;
+ case SPACEL:
+ regtainted = TRUE;
+ while (scan < loceol && isSPACE_LC(*scan))
+ scan++;
+ break;
case NSPACE:
while (scan < loceol && !isSPACE(*scan))
scan++;
break;
+ case NSPACEL:
+ regtainted = TRUE;
+ while (scan < loceol && !isSPACE_LC(*scan))
+ scan++;
+ break;
case DIGIT:
while (scan < loceol && isDIGIT(*scan))
scan++;
@@ -1090,6 +1280,48 @@ I32 max;
}
/*
+ - regclass - determine if a character falls into a character class
+ */
+
+static bool
+reginclass(p, c)
+register char *p;
+register I32 c;
+{
+ char flags = *p;
+ bool match = FALSE;
+
+ c &= 0xFF;
+ if (p[1 + (c >> 3)] & (1 << (c & 7)))
+ match = TRUE;
+ else if (flags & ANYOF_FOLD) {
+ I32 cf;
+ if (flags & ANYOF_LOCALE) {
+ regtainted = TRUE;
+ cf = fold_locale[c];
+ }
+ else
+ cf = fold[c];
+ if (p[1 + (cf >> 3)] & (1 << (cf & 7)))
+ match = TRUE;
+ }
+
+ if (!match && (flags & ANYOF_ISA)) {
+ regtainted = TRUE;
+
+ 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 match ^ ((flags & ANYOF_INVERT) != 0);
+}
+
+/*
- regnext - dig the "next" pointer out of a node
*
* [Note, when REGALIGN is defined there are two places in regmatch()
diff --git a/gnu/usr.bin/perl/regexp.h b/gnu/usr.bin/perl/regexp.h
index 018312ec243..684851c548d 100644
--- a/gnu/usr.bin/perl/regexp.h
+++ b/gnu/usr.bin/perl/regexp.h
@@ -26,10 +26,12 @@ typedef struct regexp {
char *subend; /* end of subbase */
U16 naughty; /* how exponential is this pattern? */
char reganch; /* Internal use only. */
- char do_folding; /* do case-insensitive match? */
+ char exec_tainted; /* Tainted information used by regexec? */
char program[1]; /* Unwarranted chumminess with compiler. */
} regexp;
-#define ROPT_ANCH 1
-#define ROPT_SKIP 2
-#define ROPT_IMPLICIT 4
+#define ROPT_ANCH 3
+#define ROPT_ANCH_BOL 1
+#define ROPT_ANCH_GPOS 2
+#define ROPT_SKIP 4
+#define ROPT_IMPLICIT 8
diff --git a/gnu/usr.bin/perl/run.c b/gnu/usr.bin/perl/run.c
index 7c09f8f58bd..0ce2b9ffed0 100644
--- a/gnu/usr.bin/perl/run.c
+++ b/gnu/usr.bin/perl/run.c
@@ -1,6 +1,6 @@
/* run.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -27,6 +27,8 @@ runops() {
runlevel++;
while ( op = (*op->op_ppaddr)() ) ;
+
+ TAINT_NOT;
return 0;
}
@@ -47,13 +49,15 @@ runops() {
do {
if (debug) {
if (watchaddr != 0 && *watchaddr != watchok)
- fprintf(stderr, "WARNING: %lx changed from %lx to %lx\n",
+ 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(op));
DEBUG_P(debprof(op));
}
} while ( op = (*op->op_ppaddr)() );
+
+ TAINT_NOT;
return 0;
}
@@ -65,23 +69,23 @@ OP *op;
deb("%s", op_name[op->op_type]);
switch (op->op_type) {
case OP_CONST:
- fprintf(stderr, "(%s)", SvPEEK(cSVOP->op_sv));
+ PerlIO_printf(Perl_debug_log, "(%s)", SvPEEK(cSVOP->op_sv));
break;
case OP_GVSV:
case OP_GV:
if (cGVOP->op_gv) {
sv = NEWSV(0,0);
- gv_fullname(sv, cGVOP->op_gv);
- fprintf(stderr, "(%s)", SvPV(sv, na));
+ gv_fullname3(sv, cGVOP->op_gv, Nullch);
+ PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, na));
SvREFCNT_dec(sv);
}
else
- fprintf(stderr, "(NULL)");
+ PerlIO_printf(Perl_debug_log, "(NULL)");
break;
default:
break;
}
- fprintf(stderr, "\n");
+ PerlIO_printf(Perl_debug_log, "\n");
return 0;
}
@@ -91,7 +95,7 @@ char **addr;
{
watchaddr = addr;
watchok = *addr;
- fprintf(stderr, "WATCHING, %lx is currently %lx\n",
+ PerlIO_printf(Perl_debug_log, "WATCHING, %lx is currently %lx\n",
(long)watchaddr, (long)watchok);
}
@@ -107,12 +111,13 @@ OP* op;
void
debprofdump()
{
- U32 i;
+ unsigned i;
if (!profiledata)
return;
for (i = 0; i < MAXO; i++) {
if (profiledata[i])
- fprintf(stderr, "%d\t%lu\n", i, profiledata[i]);
+ PerlIO_printf(Perl_debug_log,
+ "%u\t%lu\n", i, (unsigned long)profiledata[i]);
}
}
diff --git a/gnu/usr.bin/perl/scope.c b/gnu/usr.bin/perl/scope.c
index 3f4860990d7..3006f1adc35 100644
--- a/gnu/usr.bin/perl/scope.c
+++ b/gnu/usr.bin/perl/scope.c
@@ -1,6 +1,6 @@
/* scope.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -22,7 +22,7 @@ SV** p;
int n;
{
stack_sp = sp;
- av_extend(stack, (p - stack_base) + (n) + 128);
+ av_extend(curstack, (p - stack_base) + (n) + 128);
return stack_sp;
}
@@ -107,19 +107,14 @@ free_tmps()
}
}
-SV *
-save_scalar(gv)
-GV *gv;
+static SV *
+save_scalar_at(sptr)
+SV **sptr;
{
register SV *sv;
- SV *osv = GvSV(gv);
-
- SSCHECK(3);
- SSPUSHPTR(gv);
- SSPUSHPTR(osv);
- SSPUSHINT(SAVEt_SV);
+ SV *osv = *sptr;
- sv = GvSV(gv) = NEWSV(0,0);
+ sv = *sptr = NEWSV(0,0);
if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
sv_upgrade(sv, SvTYPE(osv));
if (SvGMAGICAL(osv)) {
@@ -143,88 +138,105 @@ GV *gv;
return sv;
}
-#ifdef INLINED_ELSEWHERE
-void
-save_gp(gv)
+SV *
+save_scalar(gv)
GV *gv;
{
- register GP *gp;
- GP *ogp = GvGP(gv);
-
SSCHECK(3);
- SSPUSHPTR(SvREFCNT_inc(gv));
- SSPUSHPTR(ogp);
- SSPUSHINT(SAVEt_GP);
-
- Newz(602,gp, 1, GP);
- GvGP(gv) = gp;
- GvREFCNT(gv) = 1;
- GvSV(gv) = NEWSV(72,0);
- GvLINE(gv) = curcop->cop_line;
- GvEGV(gv) = gv;
+ SSPUSHPTR(gv);
+ SSPUSHPTR(GvSV(gv));
+ SSPUSHINT(SAVEt_SV);
+ return save_scalar_at(&GvSV(gv));
}
-#endif
SV*
save_svref(sptr)
SV **sptr;
{
- register SV *sv;
- SV *osv = *sptr;
-
SSCHECK(3);
- SSPUSHPTR(*sptr);
SSPUSHPTR(sptr);
+ SSPUSHPTR(*sptr);
SSPUSHINT(SAVEt_SVREF);
+ return save_scalar_at(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 = tainted;
- mg_get(osv);
- if (tainting && 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;
- tainted = oldtainted;
- }
- SvMAGIC(sv) = SvMAGIC(osv);
- SvFLAGS(sv) |= SvMAGICAL(osv);
- localizing = 1;
- SvSETMAGIC(sv);
- localizing = 0;
+void
+save_gp(gv, empty)
+GV *gv;
+I32 empty;
+{
+ 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;
+ Newz(602, gp, 1, GP);
+ GvGP(gv) = gp_ref(gp);
+ GvSV(gv) = NEWSV(72,0);
+ GvLINE(gv) = curcop->cop_line;
+ GvEGV(gv) = gv;
+ }
+ else {
+ gp_ref(GvGP(gv));
+ GvINTRO_on(gv);
}
- return sv;
}
AV *
save_ary(gv)
GV *gv;
{
+ AV *oav, *av;
+
SSCHECK(3);
SSPUSHPTR(gv);
- SSPUSHPTR(GvAVn(gv));
+ SSPUSHPTR(oav = GvAVn(gv));
SSPUSHINT(SAVEt_AV);
GvAV(gv) = Null(AV*);
- return GvAVn(gv);
+ av = GvAVn(gv);
+ if (SvMAGIC(oav)) {
+ SvMAGIC(av) = SvMAGIC(oav);
+ SvFLAGS(av) |= SvMAGICAL(oav);
+ SvMAGICAL_off(oav);
+ SvMAGIC(oav) = 0;
+ localizing = 1;
+ SvSETMAGIC((SV*)av);
+ localizing = 0;
+ }
+ return av;
}
HV *
save_hash(gv)
GV *gv;
{
+ HV *ohv, *hv;
+
SSCHECK(3);
SSPUSHPTR(gv);
- SSPUSHPTR(GvHVn(gv));
+ SSPUSHPTR(ohv = GvHVn(gv));
SSPUSHINT(SAVEt_HV);
GvHV(gv) = Null(HV*);
- return GvHVn(gv);
+ hv = GvHVn(gv);
+ if (SvMAGIC(ohv)) {
+ SvMAGIC(hv) = SvMAGIC(ohv);
+ SvFLAGS(hv) |= SvMAGICAL(ohv);
+ SvMAGICAL_off(ohv);
+ SvMAGIC(ohv) = 0;
+ localizing = 1;
+ SvSETMAGIC((SV*)hv);
+ localizing = 0;
+ }
+ return hv;
}
void
@@ -272,6 +284,16 @@ I32 *intp;
}
void
+save_I16(intp)
+I16 *intp;
+{
+ SSCHECK(3);
+ SSPUSHINT(*intp);
+ SSPUSHPTR(intp);
+ SSPUSHINT(SAVEt_I16);
+}
+
+void
save_iv(ivp)
IV *ivp;
{
@@ -437,26 +459,13 @@ I32 base;
case SAVEt_SV: /* scalar reference */
value = (SV*)SSPOPPTR;
gv = (GV*)SSPOPPTR;
- sv = GvSV(gv);
- 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;
- }
- SvREFCNT_dec(sv);
- GvSV(gv) = value;
- localizing = 2;
- SvSETMAGIC(value);
- localizing = 0;
- break;
+ ptr = &GvSV(gv);
+ goto restore_sv;
case SAVEt_SVREF: /* scalar reference */
+ value = (SV*)SSPOPPTR;
ptr = SSPOPPTR;
+ restore_sv:
sv = *(SV**)ptr;
- value = (SV*)SSPOPPTR;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
SvTYPE(sv) != SVt_PVGV)
{
@@ -466,6 +475,14 @@ I32 base;
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;
localizing = 2;
@@ -475,14 +492,38 @@ I32 base;
case SAVEt_AV: /* array reference */
av = (AV*)SSPOPPTR;
gv = (GV*)SSPOPPTR;
- SvREFCNT_dec(GvAV(gv));
+ 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)) {
+ localizing = 2;
+ SvSETMAGIC((SV*)av);
+ localizing = 0;
+ }
break;
case SAVEt_HV: /* hash reference */
hv = (HV*)SSPOPPTR;
gv = (GV*)SSPOPPTR;
- SvREFCNT_dec(GvHV(gv));
+ 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)) {
+ localizing = 2;
+ SvSETMAGIC((SV*)hv);
+ localizing = 0;
+ }
break;
case SAVEt_INT: /* int reference */
ptr = SSPOPPTR;
@@ -496,6 +537,10 @@ I32 base;
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;
@@ -518,13 +563,19 @@ I32 base;
break;
case SAVEt_NSTAB:
gv = (GV*)SSPOPPTR;
- (void)sv_clear(gv);
+ (void)sv_clear((SV*)gv);
break;
- case SAVEt_GP: /* scalar reference */
+ case SAVEt_GP: /* scalar reference */
ptr = SSPOPPTR;
gv = (GV*)SSPOPPTR;
gp_free(gv);
GvGP(gv) = (GP*)ptr;
+ if (SvPOK(gv) && SvLEN(gv) > 0) {
+ Safefree(SvPVX(gv));
+ }
+ SvPVX(gv) = (char *)SSPOPPTR;
+ SvCUR(gv) = (STRLEN)SSPOPIV;
+ SvLEN(gv) = (STRLEN)SSPOPIV;
SvREFCNT_dec(gv);
break;
case SAVEt_FREESV:
@@ -533,7 +584,8 @@ I32 base;
break;
case SAVEt_FREEOP:
ptr = SSPOPPTR;
- curpad = AvARRAY(comppad);
+ if (comppad)
+ curpad = AvARRAY(comppad);
op_free((OP*)ptr);
break;
case SAVEt_FREEPV:
@@ -543,7 +595,8 @@ I32 base;
case SAVEt_CLEARSV:
ptr = (void*)&curpad[SSPOPLONG];
sv = *(SV**)ptr;
- if (SvREFCNT(sv) <= 1) { /* Can clear pad variable in place. */
+ /* Can clear pad variable in place? */
+ if (SvREFCNT(sv) <= 1 && !SvOBJECT(sv)) {
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv))
croak("panic: leave_scope clearsv");
@@ -563,13 +616,15 @@ I32 base;
hv_clear((HV*)sv);
break;
case SVt_PVCV:
- sub_generation++;
- cv_undef((CV*)sv);
+ croak("panic: leave_scope pad code");
+ case SVt_RV:
+ case SVt_IV:
+ case SVt_NV:
+ (void)SvOK_off(sv);
break;
default:
- if (SvPOK(sv) && SvLEN(sv))
- (void)SvOOK_off(sv);
(void)SvOK_off(sv);
+ (void)SvOOK_off(sv);
break;
}
}
@@ -601,6 +656,12 @@ I32 base;
savestack_ix -= delta; /* regexp must have croaked */
}
break;
+ case SAVEt_STACK_POS: /* Position on Perl stack */
+ {
+ I32 delta = SSPOPINT;
+ stack_sp = stack_base + delta;
+ }
+ break;
default:
croak("panic: leave_scope inconsistency");
}
@@ -608,93 +669,96 @@ I32 base;
}
#ifdef DEBUGGING
+
void
cx_dump(cx)
CONTEXT* cx;
{
- fprintf(stderr, "CX %d = %s\n", cx - cxstack, block_type[cx->cx_type]);
+ PerlIO_printf(Perl_debug_log, "CX %ld = %s\n", (long)(cx - cxstack), block_type[cx->cx_type]);
if (cx->cx_type != CXt_SUBST) {
- fprintf(stderr, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
- fprintf(stderr, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop);
- fprintf(stderr, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
- fprintf(stderr, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
- fprintf(stderr, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp);
- fprintf(stderr, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm);
- fprintf(stderr, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
+ 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:
- fprintf(stderr, "BLK_SUB.CV = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n",
(long)cx->blk_sub.cv);
- fprintf(stderr, "BLK_SUB.GV = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n",
(long)cx->blk_sub.gv);
- fprintf(stderr, "BLK_SUB.DFOUTGV = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n",
(long)cx->blk_sub.dfoutgv);
- fprintf(stderr, "BLK_SUB.OLDDEPTH = %ld\n",
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
(long)cx->blk_sub.olddepth);
- fprintf(stderr, "BLK_SUB.HASARGS = %d\n",
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.HASARGS = %d\n",
(int)cx->blk_sub.hasargs);
break;
case CXt_EVAL:
- fprintf(stderr, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
+ PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
(long)cx->blk_eval.old_in_eval);
- fprintf(stderr, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
+ 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]);
- fprintf(stderr, "BLK_EVAL.OLD_NAME = %s\n",
+ PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
cx->blk_eval.old_name);
- fprintf(stderr, "BLK_EVAL.OLD_EVAL_ROOT = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_EVAL_ROOT = 0x%lx\n",
(long)cx->blk_eval.old_eval_root);
break;
case CXt_LOOP:
- fprintf(stderr, "BLK_LOOP.LABEL = %s\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n",
cx->blk_loop.label);
- fprintf(stderr, "BLK_LOOP.RESETSP = %ld\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
(long)cx->blk_loop.resetsp);
- fprintf(stderr, "BLK_LOOP.REDO_OP = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.REDO_OP = 0x%lx\n",
(long)cx->blk_loop.redo_op);
- fprintf(stderr, "BLK_LOOP.NEXT_OP = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.NEXT_OP = 0x%lx\n",
(long)cx->blk_loop.next_op);
- fprintf(stderr, "BLK_LOOP.LAST_OP = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.LAST_OP = 0x%lx\n",
(long)cx->blk_loop.last_op);
- fprintf(stderr, "BLK_LOOP.ITERIX = %ld\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
(long)cx->blk_loop.iterix);
- fprintf(stderr, "BLK_LOOP.ITERARY = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n",
(long)cx->blk_loop.iterary);
- fprintf(stderr, "BLK_LOOP.ITERVAR = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERVAR = 0x%lx\n",
(long)cx->blk_loop.itervar);
if (cx->blk_loop.itervar)
- fprintf(stderr, "BLK_LOOP.ITERSAVE = 0x%lx\n",
+ 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:
- fprintf(stderr, "SB_ITERS = %ld\n",
+ PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
(long)cx->sb_iters);
- fprintf(stderr, "SB_MAXITERS = %ld\n",
+ PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
(long)cx->sb_maxiters);
- fprintf(stderr, "SB_SAFEBASE = %ld\n",
+ PerlIO_printf(Perl_debug_log, "SB_SAFEBASE = %ld\n",
(long)cx->sb_safebase);
- fprintf(stderr, "SB_ONCE = %ld\n",
+ PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
(long)cx->sb_once);
- fprintf(stderr, "SB_ORIG = %s\n",
+ PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
cx->sb_orig);
- fprintf(stderr, "SB_DSTR = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%lx\n",
(long)cx->sb_dstr);
- fprintf(stderr, "SB_TARG = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%lx\n",
(long)cx->sb_targ);
- fprintf(stderr, "SB_S = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "SB_S = 0x%lx\n",
(long)cx->sb_s);
- fprintf(stderr, "SB_M = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "SB_M = 0x%lx\n",
(long)cx->sb_m);
- fprintf(stderr, "SB_STREND = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%lx\n",
(long)cx->sb_strend);
- fprintf(stderr, "SB_SUBBASE = 0x%lx\n",
- (long)cx->sb_subbase);
+ PerlIO_printf(Perl_debug_log, "SB_RXRES = 0x%lx\n",
+ (long)cx->sb_rxres);
break;
}
}
diff --git a/gnu/usr.bin/perl/scope.h b/gnu/usr.bin/perl/scope.h
index 8845e7cfec0..debe1f88a7f 100644
--- a/gnu/usr.bin/perl/scope.h
+++ b/gnu/usr.bin/perl/scope.h
@@ -20,6 +20,8 @@
#define SAVEt_DELETE 19
#define SAVEt_DESTRUCTOR 20
#define SAVEt_REGCONTEXT 21
+#define SAVEt_STACK_POS 22
+#define SAVEt_I16 23
#define SSCHECK(need) if (savestack_ix + need > savestack_max) savestack_grow()
#define SSPUSHINT(i) (savestack[savestack_ix++].any_i32 = (I32)(i))
@@ -43,16 +45,77 @@
#define LEAVE pop_scope()
#define LEAVE_SCOPE(old) if (savestack_ix > old) leave_scope(old)
-#define SAVEINT(i) save_int((int*)(&i));
-#define SAVEIV(i) save_iv((IV*)(&i));
-#define SAVEI32(i) save_I32((I32*)(&i));
-#define SAVELONG(l) save_long((long*)(&l));
-#define SAVESPTR(s) save_sptr((SV**)(&s))
-#define SAVEPPTR(s) save_pptr((char**)(&s))
-#define SAVEFREESV(s) save_freesv((SV*)(s))
-#define SAVEFREEOP(o) save_freeop((OP*)(o))
-#define SAVEFREEPV(p) save_freepv((char*)(p))
-#define SAVECLEARSV(sv) save_clearsv((SV**)(&sv))
-#define SAVEDELETE(h,k,l) save_delete((HV*)(h), (char*)(k), (I32)l)
-#define SAVEDESTRUCTOR(f,p) save_destructor(f,(void*)p)
+/*
+ * 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))
+#define SAVEDESTRUCTOR(f,p) \
+ save_destructor(SOFT_CAST(void(*)_((void*)))(f),SOFT_CAST(void*)(p))
+#define SAVESTACK_POS() STMT_START { \
+ SSCHECK(2); \
+ SSPUSHINT(stack_sp - stack_base); \
+ SSPUSHINT(SAVEt_STACK_POS); \
+ } 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;
+
+#define dJMPENV JMPENV cur_env
+#define JMPENV_PUSH(v) \
+ STMT_START { \
+ cur_env.je_prev = top_env; \
+ cur_env.je_ret = Sigsetjmp(cur_env.je_buf, 1); \
+ top_env = &cur_env; \
+ cur_env.je_mustcatch = FALSE; \
+ (v) = cur_env.je_ret; \
+ } STMT_END
+#define JMPENV_POP \
+ STMT_START { top_env = cur_env.je_prev; } STMT_END
+#define JMPENV_JUMP(v) \
+ STMT_START { \
+ if (top_env->je_prev) \
+ Siglongjmp(top_env->je_buf, (v)); \
+ if ((v) == 2) \
+ exit(STATUS_NATIVE_EXPORT); \
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
+ exit(1); \
+ } STMT_END
+
+#define CATCH_GET (top_env->je_mustcatch)
+#define CATCH_SET(v) (top_env->je_mustcatch = (v))
+
diff --git a/gnu/usr.bin/perl/sv.c b/gnu/usr.bin/perl/sv.c
index a1f1d607157..d9596cb90f6 100644
--- a/gnu/usr.bin/perl/sv.c
+++ b/gnu/usr.bin/perl/sv.c
@@ -1,6 +1,6 @@
/* sv.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -36,16 +36,17 @@
#endif
#endif
-#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
+#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__)
# define FAST_SV_GETS
#endif
+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 SV *new_sv _((void));
static XPVIV *new_xiv _((void));
static XPVNV *new_xnv _((void));
static XPV *new_xpv _((void));
@@ -55,13 +56,95 @@ 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));
+typedef void (*SVFUNC) _((SV*));
+
#ifdef PURIFY
-#define new_SV() sv = (SV*)safemalloc(sizeof(SV))
-#define del_SV(p) free((char*)p)
+#define new_SV(p) \
+ do { \
+ (p) = (SV*)safemalloc(sizeof(SV)); \
+ reg_add(p); \
+ } while (0)
+
+#define del_SV(p) \
+ do { \
+ reg_remove(p); \
+ free((char*)(p)); \
+ } while (0)
+
+static SV **registry;
+static I32 regsize;
+
+#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
+
+#define REG_REPLACE(sv,a,b) \
+ do { \
+ void* p = sv->sv_any; \
+ I32 h = REGHASH(sv, regsize); \
+ I32 i = h; \
+ while (registry[i] != (a)) { \
+ if (++i >= regsize) \
+ 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 (sv_count >= (regsize >> 1))
+ {
+ SV **oldreg = registry;
+ I32 oldsize = regsize;
+
+ regsize = regsize ? ((regsize << 2) + 1) : 2037;
+ registry = (SV**)safemalloc(regsize * sizeof(SV*));
+ memzero(registry, regsize * sizeof(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);
+ ++sv_count;
+}
+
+static void
+reg_remove(sv)
+SV* sv;
+{
+ REG_REMOVE(sv);
+ --sv_count;
+}
+
+static void
+visit(f)
+SVFUNC f;
+{
+ I32 i;
+
+ for (i = 0; i < regsize; ++i) {
+ SV* sv = registry[i];
+ if (sv)
+ (*f)(sv);
+ }
+}
void
sv_add_arena(ptr, size, flags)
@@ -73,39 +156,40 @@ U32 flags;
free(ptr);
}
-#else
+#else /* ! PURIFY */
+
+/*
+ * "A time to plant, and a time to uproot what was planted..."
+ */
+
+#define plant_SV(p) \
+ do { \
+ SvANY(p) = (void *)sv_root; \
+ SvFLAGS(p) = SVTYPEMASK; \
+ sv_root = (p); \
+ --sv_count; \
+ } while (0)
-#define new_SV() \
- if (sv_root) { \
- sv = sv_root; \
- sv_root = (SV*)SvANY(sv); \
+#define uproot_SV(p) \
+ do { \
+ (p) = sv_root; \
+ sv_root = (SV*)SvANY(p); \
++sv_count; \
- } \
- else \
- sv = more_sv();
+ } while (0)
-static SV*
-new_sv()
-{
- SV* sv;
- if (sv_root) {
- sv = sv_root;
- sv_root = (SV*)SvANY(sv);
- ++sv_count;
- return sv;
- }
- return more_sv();
-}
+#define new_SV(p) \
+ if (sv_root) \
+ uproot_SV(p); \
+ else \
+ (p) = more_sv()
#ifdef DEBUGGING
+
#define del_SV(p) \
if (debug & 32768) \
del_sv(p); \
- else { \
- SvANY(p) = (void *)sv_root; \
- sv_root = p; \
- --sv_count; \
- }
+ else \
+ plant_SV(p)
static void
del_sv(p)
@@ -127,17 +211,14 @@ SV* p;
return;
}
}
- SvANY(p) = (void *) sv_root;
- sv_root = p;
- --sv_count;
+ plant_SV(p);
}
-#else
-#define del_SV(p) \
- SvANY(p) = (void *)sv_root; \
- sv_root = p; \
- --sv_count;
-#endif
+#else /* ! DEBUGGING */
+
+#define del_SV(p) plant_SV(p)
+
+#endif /* DEBUGGING */
void
sv_add_arena(ptr, size, flags)
@@ -172,101 +253,113 @@ U32 flags;
static SV*
more_sv()
{
+ register SV* sv;
+
if (nice_chunk) {
sv_add_arena(nice_chunk, nice_chunk_size, 0);
nice_chunk = Nullch;
}
- else
- sv_add_arena(safemalloc(1008), 1008, 0);
- return new_sv();
+ 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;
}
-#endif
-void
-sv_report_used()
+static void
+visit(f)
+SVFUNC f;
{
SV* sva;
SV* sv;
register SV* svend;
- for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
- sv = sva + 1;
+ for (sva = sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
svend = &sva[SvREFCNT(sva)];
- while (sv < svend) {
- if (SvTYPE(sv) != SVTYPEMASK) {
- fprintf(stderr, "****\n");
- sv_dump(sv);
- }
- ++sv;
+ for (sv = sva + 1; sv < svend; ++sv) {
+ if (SvTYPE(sv) != SVTYPEMASK)
+ (*f)(sv);
}
}
}
+#endif /* PURIFY */
+
+static void
+do_report_used(sv)
+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_clean_objs()
+sv_report_used()
+{
+ visit(do_report_used);
+}
+
+static void
+do_clean_objs(sv)
+SV* sv;
{
- SV* sva;
- register SV* sv;
- register SV* svend;
SV* rv;
-#ifndef DISABLE_DESTRUCTOR_KLUDGE
- register GV* gv;
- for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
- gv = sva + 1;
- svend = &sva[SvREFCNT(sva)];
- while (gv < svend) {
- if (SvTYPE(gv) == SVt_PVGV && (sv = GvSV(gv)) &&
- SvROK(sv) && SvOBJECT(rv = SvRV(sv)))
- {
- DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "),
- sv_dump(sv));)
- SvROK_off(sv);
- SvRV(sv) = 0;
- SvREFCNT_dec(rv);
- }
- ++gv;
- }
+ 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);
}
- if (!sv_objcount)
- return;
+
+ /* XXX Might want to check arrays, etc. */
+}
+
+#ifndef DISABLE_DESTRUCTOR_KLUDGE
+static void
+do_clean_named_objs(sv)
+SV* sv;
+{
+ if (SvTYPE(sv) == SVt_PVGV && GvSV(sv))
+ do_clean_objs(GvSV(sv));
+}
#endif
- for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
- sv = sva + 1;
- svend = &sva[SvREFCNT(sva)];
- while (sv < svend) {
- if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
- DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "),
- sv_dump(sv));)
- SvROK_off(sv);
- SvRV(sv) = 0;
- SvREFCNT_dec(rv);
- }
- /* XXX Might want to check arrays, etc. */
- ++sv;
- }
- }
+
+static bool in_clean_objs = FALSE;
+
+void
+sv_clean_objs()
+{
+ in_clean_objs = TRUE;
+#ifndef DISABLE_DESTRUCTOR_KLUDGE
+ visit(do_clean_named_objs);
+#endif
+ visit(do_clean_objs);
+ in_clean_objs = FALSE;
+}
+
+static void
+do_clean_all(sv)
+SV* sv;
+{
+ DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));)
+ SvFLAGS(sv) |= SVf_BREAK;
+ SvREFCNT_dec(sv);
}
+static bool in_clean_all = FALSE;
+
void
sv_clean_all()
{
- SV* sva;
- register SV* sv;
- register SV* svend;
-
- for (sva = sv_arenaroot; sva; sva = (SV*) SvANY(sva)) {
- sv = sva + 1;
- svend = &sva[SvREFCNT(sva)];
- while (sv < svend) {
- if (SvTYPE(sv) != SVTYPEMASK) {
- DEBUG_D((fprintf(stderr, "Cleaning loops:\n "), sv_dump(sv));)
- SvFLAGS(sv) |= SVf_BREAK;
- SvREFCNT_dec(sv);
- }
- ++sv;
- }
- }
+ in_clean_all = TRUE;
+ visit(do_clean_all);
+ in_clean_all = FALSE;
}
void
@@ -284,8 +377,11 @@ sv_free_arenas()
svanext = (SV*) SvANY(svanext);
if (!SvFAKE(sva))
- Safefree(sva);
+ Safefree((void *)sva);
}
+
+ sv_arenaroot = 0;
+ sv_root = 0;
}
static XPVIV*
@@ -575,7 +671,6 @@ U32 mt;
stash = 0;
break;
case SVt_PV:
- nv = 0.0;
pv = SvPVX(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
@@ -590,7 +685,6 @@ U32 mt;
mt = SVt_PVNV;
break;
case SVt_PVIV:
- nv = 0.0;
pv = SvPVX(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
@@ -601,7 +695,6 @@ U32 mt;
del_XPVIV(SvANY(sv));
break;
case SVt_PVNV:
- nv = SvNVX(sv);
pv = SvPVX(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
@@ -693,8 +786,8 @@ U32 mt;
if (pv)
Safefree(pv);
SvPVX(sv) = 0;
- AvMAX(sv) = 0;
- AvFILL(sv) = 0;
+ AvMAX(sv) = -1;
+ AvFILL(sv) = -1;
SvIVX(sv) = 0;
SvNVX(sv) = 0.0;
SvMAGIC(sv) = magic;
@@ -792,28 +885,30 @@ char *
sv_peek(sv)
register SV *sv;
{
- char *t = tokenbuf;
+ SV *t = sv_newmortal();
+ STRLEN prevlen;
int unref = 0;
+ sv_setpvn(t, "", 0);
retry:
if (!sv) {
- strcpy(t, "VOID");
+ sv_catpv(t, "VOID");
goto finish;
}
else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
- strcpy(t, "WILD");
+ sv_catpv(t, "WILD");
goto finish;
}
else if (sv == &sv_undef || sv == &sv_no || sv == &sv_yes) {
if (sv == &sv_undef) {
- strcpy(t, "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 == &sv_no) {
- strcpy(t, "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|
@@ -823,7 +918,7 @@ register SV *sv;
goto finish;
}
else {
- strcpy(t, "SV_YES");
+ 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|
@@ -833,17 +928,18 @@ register SV *sv;
SvNVX(sv) == 1.0)
goto finish;
}
- t += strlen(t);
- *t++ = ':';
+ sv_catpv(t, ":");
}
else if (SvREFCNT(sv) == 0) {
- *t++ = '(';
+ sv_catpv(t, "(");
unref++;
}
if (SvROK(sv)) {
- *t++ = '\\';
- if (t - tokenbuf + unref > 10) {
- strcpy(tokenbuf + unref + 3,"...");
+ sv_catpv(t, "\\");
+ if (SvCUR(t) + unref > 10) {
+ SvCUR(t) = unref + 3;
+ *SvEND(t) = '\0';
+ sv_catpv(t, "...");
goto finish;
}
sv = (SV*)SvRV(sv);
@@ -851,86 +947,85 @@ register SV *sv;
}
switch (SvTYPE(sv)) {
default:
- strcpy(t,"FREED");
+ sv_catpv(t, "FREED");
goto finish;
case SVt_NULL:
- strcpy(t,"UNDEF");
- return tokenbuf;
+ sv_catpv(t, "UNDEF");
+ goto finish;
case SVt_IV:
- strcpy(t,"IV");
+ sv_catpv(t, "IV");
break;
case SVt_NV:
- strcpy(t,"NV");
+ sv_catpv(t, "NV");
break;
case SVt_RV:
- strcpy(t,"RV");
+ sv_catpv(t, "RV");
break;
case SVt_PV:
- strcpy(t,"PV");
+ sv_catpv(t, "PV");
break;
case SVt_PVIV:
- strcpy(t,"PVIV");
+ sv_catpv(t, "PVIV");
break;
case SVt_PVNV:
- strcpy(t,"PVNV");
+ sv_catpv(t, "PVNV");
break;
case SVt_PVMG:
- strcpy(t,"PVMG");
+ sv_catpv(t, "PVMG");
break;
case SVt_PVLV:
- strcpy(t,"PVLV");
+ sv_catpv(t, "PVLV");
break;
case SVt_PVAV:
- strcpy(t,"AV");
+ sv_catpv(t, "AV");
break;
case SVt_PVHV:
- strcpy(t,"HV");
+ sv_catpv(t, "HV");
break;
case SVt_PVCV:
if (CvGV(sv))
- sprintf(t, "CV(%s)", GvNAME(CvGV(sv)));
+ sv_catpvf(t, "CV(%s)", GvNAME(CvGV(sv)));
else
- strcpy(t, "CV()");
+ sv_catpv(t, "CV()");
goto finish;
case SVt_PVGV:
- strcpy(t,"GV");
+ sv_catpv(t, "GV");
break;
case SVt_PVBM:
- strcpy(t,"BM");
+ sv_catpv(t, "BM");
break;
case SVt_PVFM:
- strcpy(t,"FM");
+ sv_catpv(t, "FM");
break;
case SVt_PVIO:
- strcpy(t,"IO");
+ sv_catpv(t, "IO");
break;
}
- t += strlen(t);
if (SvPOKp(sv)) {
if (!SvPVX(sv))
- strcpy(t, "(null)");
+ sv_catpv(t, "(null)");
if (SvOOK(sv))
- sprintf(t,"(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv));
+ sv_catpvf(t, "(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv));
else
- sprintf(t,"(\"%.127s\")",SvPVX(sv));
+ sv_catpvf(t, "(\"%.127s\")",SvPVX(sv));
+ }
+ else if (SvNOKp(sv)) {
+ SET_NUMERIC_STANDARD();
+ sv_catpvf(t, "(%g)",SvNVX(sv));
}
- else if (SvNOKp(sv))
- sprintf(t,"(%g)",SvNVX(sv));
else if (SvIOKp(sv))
- sprintf(t,"(%ld)",(long)SvIVX(sv));
+ sv_catpvf(t, "(%ld)",(long)SvIVX(sv));
else
- strcpy(t,"()");
+ sv_catpv(t, "()");
finish:
if (unref) {
- t += strlen(t);
while (unref--)
- *t++ = ')';
- *t = '\0';
+ sv_catpv(t, ")");
}
- return tokenbuf;
+ return SvPV(t, na);
}
#endif
@@ -961,12 +1056,12 @@ unsigned long newlen;
{
register char *s;
-#ifdef MSDOS
+#ifdef HAS_64K_LIMIT
if (newlen >= 0x10000) {
- fprintf(stderr, "Allocation too large: %lx\n", newlen);
+ PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
my_exit(1);
}
-#endif /* MSDOS */
+#endif /* HAS_64K_LIMIT */
if (SvROK(sv))
sv_unref(sv);
if (SvTYPE(sv) < SVt_PV) {
@@ -1027,7 +1122,7 @@ IV i;
case SVt_PVFM:
case SVt_PVIO:
croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
- op_name[op->op_type]);
+ op_desc[op->op_type]);
}
(void)SvIOK_only(sv); /* validate number */
SvIVX(sv) = i;
@@ -1035,6 +1130,17 @@ IV i;
}
void
+sv_setuv(sv,u)
+register SV *sv;
+UV u;
+{
+ if (u <= IV_MAX)
+ sv_setiv(sv, u);
+ else
+ sv_setnv(sv, (double)u);
+}
+
+void
sv_setnv(sv,num)
register SV *sv;
double num;
@@ -1089,20 +1195,38 @@ SV *sv;
char tmpbuf[64];
char *d = tmpbuf;
char *s;
- int i;
+ 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), i = 50; *s && i; s++,i--) {
- int ch = *s;
- if (ch & 128 && !isprint(ch)) {
+ for (s = SvPVX(sv); *s && d < limit; s++) {
+ int ch = *s & 0xFF;
+ if (ch & 128 && !isPRINT_LC(ch)) {
*d++ = 'M';
*d++ = '-';
ch &= 127;
}
- if (isprint(ch))
+ 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++ = ch ^ 64;
+ *d++ = toCTRL(ch);
}
}
if (*s) {
@@ -1135,14 +1259,13 @@ register SV *sv;
else
return (IV) U_V(SvNVX(sv));
}
- if (SvPOKp(sv) && SvLEN(sv)) {
- if (dowarn && !looks_like_number(sv))
- not_a_number(sv);
- return (IV)atol(SvPVX(sv));
+ if (SvPOKp(sv) && SvLEN(sv))
+ return asIV(sv);
+ if (!SvROK(sv)) {
+ if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warn(warn_uninit);
+ return 0;
}
- if (!SvROK(sv)) {
- return 0;
- }
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
@@ -1160,11 +1283,8 @@ register SV *sv;
else
return (IV) U_V(SvNVX(sv));
}
- if (SvPOKp(sv) && SvLEN(sv)) {
- if (dowarn && !looks_like_number(sv))
- not_a_number(sv);
- return (IV)atol(SvPVX(sv));
- }
+ if (SvPOKp(sv) && SvLEN(sv))
+ return asIV(sv);
if (dowarn)
warn(warn_uninit);
return 0;
@@ -1173,7 +1293,7 @@ register SV *sv;
switch (SvTYPE(sv)) {
case SVt_NULL:
sv_upgrade(sv, SVt_IV);
- return SvIVX(sv);
+ break;
case SVt_PV:
sv_upgrade(sv, SVt_PVIV);
break;
@@ -1186,24 +1306,91 @@ register SV *sv;
if (SvNVX(sv) < 0.0)
SvIVX(sv) = I_V(SvNVX(sv));
else
- SvIVX(sv) = (IV) U_V(SvNVX(sv));
+ SvUVX(sv) = U_V(SvNVX(sv));
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- if (dowarn && !looks_like_number(sv))
- not_a_number(sv);
(void)SvIOK_on(sv);
- SvIVX(sv) = (IV)atol(SvPVX(sv));
+ SvIVX(sv) = asIV(sv);
}
else {
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warn(warn_uninit);
return 0;
}
- DEBUG_c(fprintf(stderr,"0x%lx 2iv(%ld)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
(unsigned long)sv,(long)SvIVX(sv)));
return SvIVX(sv);
}
+UV
+sv_2uv(sv)
+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 (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ 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 (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 (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ 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(sv)
register SV *sv;
@@ -1217,11 +1404,14 @@ register SV *sv;
if (SvPOKp(sv) && SvLEN(sv)) {
if (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 (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warn(warn_uninit);
return 0;
}
}
@@ -1238,6 +1428,7 @@ register SV *sv;
if (SvPOKp(sv) && SvLEN(sv)) {
if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
+ SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
}
if (SvIOKp(sv))
@@ -1252,7 +1443,9 @@ register SV *sv;
sv_upgrade(sv, SVt_PVNV);
else
sv_upgrade(sv, SVt_NV);
- DEBUG_c(fprintf(stderr,"0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
+ 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);
@@ -1264,6 +1457,7 @@ register SV *sv;
else if (SvPOKp(sv) && SvLEN(sv)) {
if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
+ SET_NUMERIC_STANDARD();
SvNVX(sv) = atof(SvPVX(sv));
}
else {
@@ -1272,10 +1466,127 @@ register SV *sv;
return 0.0;
}
SvNOK_on(sv);
- DEBUG_c(fprintf(stderr,"0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(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 *sv;
+{
+ I32 numtype = looks_like_number(sv);
+ double d;
+
+ if (numtype == 1)
+ return atol(SvPVX(sv));
+ if (!numtype && 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 *sv;
+{
+ I32 numtype = looks_like_number(sv);
+
+#ifdef HAS_STRTOUL
+ if (numtype == 1)
+ return strtoul(SvPVX(sv), Null(char**), 10);
+#endif
+ if (!numtype && dowarn)
+ not_a_number(sv);
+ SET_NUMERIC_STANDARD();
+ return U_V(atof(SvPVX(sv)));
+}
+
+I32
+looks_like_number(sv)
+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(sv, lp)
register SV *sv;
@@ -1283,6 +1594,7 @@ STRLEN *lp;
{
register char *s;
int olderrno;
+ SV *tsv;
if (!sv) {
*lp = 0;
@@ -1296,13 +1608,18 @@ STRLEN *lp;
}
if (SvIOKp(sv)) {
(void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
+ tsv = Nullsv;
goto tokensave;
}
if (SvNOKp(sv)) {
+ SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
+ tsv = Nullsv;
goto tokensave;
}
if (!SvROK(sv)) {
+ if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warn(warn_uninit);
*lp = 0;
return "";
}
@@ -1334,14 +1651,15 @@ STRLEN *lp;
case SVt_PVCV: s = "CODE"; break;
case SVt_PVGV: s = "GLOB"; break;
case SVt_PVFM: s = "FORMATLINE"; break;
- case SVt_PVIO: s = "FILEHANDLE"; break;
+ case SVt_PVIO: s = "IO"; break;
default: s = "UNKNOWN"; break;
}
+ tsv = NEWSV(0,0);
if (SvOBJECT(sv))
- sprintf(tokenbuf, "%s=%s(0x%lx)",
- HvNAME(SvSTASH(sv)), s, (unsigned long)sv);
+ sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
else
- sprintf(tokenbuf, "%s(0x%lx)", s, (unsigned long)sv);
+ sv_setpv(tsv, s);
+ sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
goto tokensaveref;
}
*lp = strlen(s);
@@ -1349,11 +1667,14 @@ STRLEN *lp;
}
if (SvREADONLY(sv)) {
if (SvNOKp(sv)) {
+ SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
+ tsv = Nullsv;
goto tokensave;
}
if (SvIOKp(sv)) {
(void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
+ tsv = Nullsv;
goto tokensave;
}
if (dowarn)
@@ -1375,7 +1696,10 @@ STRLEN *lp;
(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])
@@ -1384,18 +1708,21 @@ STRLEN *lp;
while (*s) s++;
#ifdef hcx
if (s[-1] == '.')
- s--;
+ *--s = '\0';
#endif
}
else if (SvIOKp(sv)) {
+ U32 oldIOK = SvIOK(sv);
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
- SvGROW(sv, 11);
- s = SvPVX(sv);
olderrno = errno; /* some Xenix systems wipe out errno here */
- (void)sprintf(s,"%ld",(long)SvIVX(sv));
+ sv_setpviv(sv, SvIVX(sv));
errno = olderrno;
- while (*s) s++;
+ s = SvEND(sv);
+ if (oldIOK)
+ SvIOK_on(sv);
+ else
+ SvIOKp_on(sv);
}
else {
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
@@ -1403,11 +1730,10 @@ STRLEN *lp;
*lp = 0;
return "";
}
- *s = '\0';
*lp = s - SvPVX(sv);
SvCUR_set(sv, *lp);
SvPOK_on(sv);
- DEBUG_c(fprintf(stderr,"0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
return SvPVX(sv);
tokensave:
@@ -1415,24 +1741,37 @@ STRLEN *lp;
/* Sneaky stuff here */
tokensaveref:
- sv = sv_newmortal();
- *lp = strlen(tokenbuf);
- sv_setpvn(sv, tokenbuf, *lp);
- return SvPVX(sv);
+ if (!tsv)
+ tsv = newSVpv(tokenbuf, 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 = tokenbuf;
+ len = strlen(tokenbuf);
+ }
#ifdef FIXNEGATIVEZERO
- if (*tokenbuf == '-' && tokenbuf[1] == '0' && !tokenbuf[2])
- strcpy(tokenbuf,"0");
+ if (len == 2 && t[0] == '-' && t[1] == '0') {
+ t = "0";
+ len = 1;
+ }
#endif
(void)SvUPGRADE(sv, SVt_PV);
- len = *lp = strlen(tokenbuf);
+ *lp = len;
s = SvGROW(sv, len + 1);
SvCUR_set(sv, len);
- (void)strcpy(s, tokenbuf);
- /* NO SvPOK_on(sv) here! */
+ (void)strcpy(s, t);
+ SvPOKp_on(sv);
return s;
}
}
@@ -1523,22 +1862,20 @@ register SV *sstr;
(void)SvOK_off(dstr);
return;
case SVt_IV:
- if (dtype <= SVt_PV) {
+ if (dtype != SVt_IV && dtype < SVt_PVIV) {
if (dtype < SVt_IV)
sv_upgrade(dstr, SVt_IV);
else if (dtype == SVt_NV)
sv_upgrade(dstr, SVt_PVNV);
- else if (dtype <= SVt_PV)
+ else
sv_upgrade(dstr, SVt_PVIV);
}
break;
case SVt_NV:
- if (dtype <= SVt_PVIV) {
+ if (dtype != SVt_NV && dtype < SVt_PVNV) {
if (dtype < SVt_NV)
sv_upgrade(dstr, SVt_NV);
- else if (dtype == SVt_PVIV)
- sv_upgrade(dstr, SVt_PVNV);
- else if (dtype <= SVt_PV)
+ else
sv_upgrade(dstr, SVt_PVNV);
}
break;
@@ -1558,6 +1895,7 @@ register SV *sstr;
}
break;
case SVt_PV:
+ case SVt_PVFM:
if (dtype < SVt_PV)
sv_upgrade(dstr, SVt_PV);
break;
@@ -1571,7 +1909,7 @@ register SV *sstr;
break;
case SVt_PVLV:
- sv_upgrade(dstr, SVt_PVNV);
+ sv_upgrade(dstr, SVt_PVLV);
break;
case SVt_PVAV:
@@ -1598,9 +1936,14 @@ register SV *sstr;
GvNAMELEN(dstr) = len;
SvFAKE_on(dstr); /* can coerce to non-glob */
}
+ /* ahem, death to those who redefine active sort subs */
+ else if (curstack == sortstack
+ && GvCV(dstr) && 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(dstr);
+ gp_free((GV*)dstr);
GvGP(dstr) = gp_ref(GvGP(sstr));
SvTAINT(dstr);
if (curcop->cop_stash != GvSTASH(dstr))
@@ -1611,10 +1954,16 @@ register SV *sstr;
/* 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 (dtype < stype)
sv_upgrade(dstr, stype);
- if (SvGMAGICAL(sstr))
- mg_get(sstr);
}
sflags = SvFLAGS(sstr);
@@ -1631,11 +1980,10 @@ register SV *sstr;
GvGP(dstr)->gp_refcnt--;
GvINTRO_off(dstr); /* one-shot flag */
Newz(602,gp, 1, GP);
- GvGP(dstr) = gp;
- GvREFCNT(dstr) = 1;
+ GvGP(dstr) = gp_ref(gp);
GvSV(dstr) = NEWSV(72,0);
GvLINE(dstr) = curcop->cop_line;
- GvEGV(dstr) = dstr;
+ GvEGV(dstr) = (GV*)dstr;
}
GvMULTI_on(dstr);
switch (SvTYPE(sref)) {
@@ -1658,23 +2006,44 @@ register SV *sstr;
GvIMPORTED_HV_on(dstr);
break;
case SVt_PVCV:
- if (intro)
+ if (intro) {
+ if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
+ SvREFCNT_dec(GvCV(dstr));
+ GvCV(dstr) = Nullcv;
+ GvCVGEN(dstr) = 0; /* Switch off cacheness. */
+ sub_generation++;
+ }
SAVESPTR(GvCV(dstr));
- else {
+ }
+ else
+ dref = (SV*)GvCV(dstr);
+ if (GvCV(dstr) != (CV*)sref) {
CV* cv = GvCV(dstr);
if (cv) {
- dref = (SV*)cv;
- if (dowarn && sref != dref &&
- !GvCVGEN((GV*)dstr) &&
- (CvROOT(cv) || CvXSUB(cv)) )
- warn("Subroutine %s redefined",
- GvENAME((GV*)dstr));
- SvFAKE_on(cv);
+ if (!GvCVGEN((GV*)dstr) &&
+ (CvROOT(cv) || CvXSUB(cv)))
+ {
+ /* ahem, death to those who redefine
+ * active sort subs */
+ if (curstack == sortstack &&
+ sortcop == CvSTART(cv))
+ croak(
+ "Can't redefine active sort subroutine %s",
+ GvENAME((GV*)dstr));
+ if (cv_const_sv(cv))
+ warn("Constant subroutine %s redefined",
+ GvENAME((GV*)dstr));
+ else if (dowarn)
+ warn("Subroutine %s redefined",
+ GvENAME((GV*)dstr));
+ }
+ cv_ckproto(cv, (GV*)dstr,
+ SvPOK(sref) ? SvPVX(sref) : Nullch);
}
- }
- if (GvCV(dstr) != (CV*)sref) {
GvCV(dstr) = (CV*)sref;
+ GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
+ sub_generation++;
}
if (curcop->cop_stash != GvSTASH(dstr))
GvIMPORTED_CV_on(dstr);
@@ -1704,6 +2073,7 @@ register SV *sstr;
return;
}
if (SvPVX(dstr)) {
+ (void)SvOOK_off(dstr); /* backoff */
Safefree(SvPVX(dstr));
SvLEN(dstr)=SvCUR(dstr)=0;
}
@@ -1796,10 +2166,11 @@ register SV *sstr;
void
sv_setpvn(sv,ptr,len)
register SV *sv;
-register char *ptr;
+register const char *ptr;
register STRLEN len;
{
- assert(len >= 0);
+ assert(len >= 0); /* STRLEN is probably unsigned, so this may
+ elicit a warning, but it won't hurt. */
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv) && curcop != &compiling)
croak(no_modify);
@@ -1827,7 +2198,7 @@ register STRLEN len;
void
sv_setpv(sv,ptr)
register SV *sv;
-register char *ptr;
+register const char *ptr;
{
register STRLEN len;
@@ -1980,7 +2351,7 @@ STRLEN len;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -1991,6 +2362,8 @@ STRLEN len;
return sv;
}
+/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
+
void
sv_magic(sv, obj, how, name, namlen)
register SV *sv;
@@ -2001,7 +2374,7 @@ I32 namlen;
{
MAGIC* mg;
- if (SvREADONLY(sv) && curcop != &compiling && !strchr("gB", how))
+ if (SvREADONLY(sv) && curcop != &compiling && !strchr("gBf", how))
croak(no_modify);
if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
@@ -2026,8 +2399,12 @@ I32 namlen;
}
mg->mg_type = how;
mg->mg_len = namlen;
- if (name && namlen >= 0)
- mg->mg_ptr = savepvn(name, 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;
@@ -2049,6 +2426,9 @@ I32 namlen;
case 'E':
mg->mg_virtual = &vtbl_env;
break;
+ case 'f':
+ mg->mg_virtual = &vtbl_fm;
+ break;
case 'e':
mg->mg_virtual = &vtbl_envelem;
break;
@@ -2061,6 +2441,9 @@ I32 namlen;
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;
@@ -2068,6 +2451,11 @@ I32 namlen;
case 'l':
mg->mg_virtual = &vtbl_dbline;
break;
+#ifdef USE_LOCALE_COLLATE
+ case 'o':
+ mg->mg_virtual = &vtbl_collxfrm;
+ break;
+#endif /* USE_LOCALE_COLLATE */
case 'P':
mg->mg_virtual = &vtbl_pack;
break;
@@ -2094,6 +2482,9 @@ I32 namlen;
case 'x':
mg->mg_virtual = &vtbl_substr;
break;
+ case 'y':
+ mg->mg_virtual = &vtbl_defelem;
+ break;
case '*':
mg->mg_virtual = &vtbl_glob;
break;
@@ -2134,7 +2525,10 @@ int type;
if (vtbl && vtbl->svt_free)
(*vtbl->svt_free)(sv, mg);
if (mg->mg_ptr && mg->mg_type != 'g')
- Safefree(mg->mg_ptr);
+ 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);
@@ -2259,8 +2653,10 @@ register SV *nsv;
}
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);
}
@@ -2272,30 +2668,35 @@ register SV *sv;
assert(SvREFCNT(sv) == 0);
if (SvOBJECT(sv)) {
- dSP;
- GV* destructor;
-
if (defstash) { /* Still have a symbol table? */
- destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
+ dSP;
+ GV* destructor;
ENTER;
SAVEFREESV(SvSTASH(sv));
- if (destructor && GvCV(destructor)) {
+
+ destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
+ if (destructor) {
SV ref;
Zero(&ref, 1, SV);
sv_upgrade(&ref, SVt_RV);
- SAVEI32(SvREFCNT(sv));
SvRV(&ref) = SvREFCNT_inc(sv);
SvROK_on(&ref);
+ SvREFCNT(&ref) = 1; /* Fake, but otherwise
+ creating+destructing a ref
+ leads to disaster. */
EXTEND(SP, 2);
PUSHMARK(SP);
PUSHs(&ref);
PUTBACK;
- perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
+ perl_call_sv((SV*)GvCV(destructor),
+ G_DISCARD|G_EVAL|G_KEEPERR);
del_XRV(SvANY(&ref));
+ SvREFCNT(sv)--;
}
+
LEAVE;
}
else
@@ -2305,12 +2706,21 @@ register SV *sv;
if (SvTYPE(sv) != SVt_PVIO)
--sv_objcount; /* XXX Might want something more general */
}
+ if (SvREFCNT(sv)) {
+ if (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);
switch (SvTYPE(sv)) {
case SVt_PVIO:
- io_close((IO*)sv);
+ if (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));
@@ -2328,7 +2738,7 @@ register SV *sv;
av_undef((AV*)sv);
break;
case SVt_PVGV:
- gp_free(sv);
+ gp_free((GV*)sv);
Safefree(GvNAME(sv));
/* FALL THROUGH */
case SVt_PVLV:
@@ -2342,7 +2752,7 @@ register SV *sv;
case SVt_RV:
if (SvROK(sv))
SvREFCNT_dec(SvRV(sv));
- else if (SvPVX(sv))
+ else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
break;
/*
@@ -2428,6 +2838,8 @@ SV *sv;
if (SvREFCNT(sv) == 0) {
if (SvFLAGS(sv) & SVf_BREAK)
return;
+ if (in_clean_all) /* All is fair */
+ return;
warn("Attempt to free unreferenced scalar");
return;
}
@@ -2440,7 +2852,8 @@ SV *sv;
}
#endif
sv_clear(sv);
- del_SV(sv);
+ if (! SvREFCNT(sv))
+ del_SV(sv);
}
STRLEN
@@ -2485,59 +2898,146 @@ register SV *str2;
if (cur1 != cur2)
return 0;
- return !bcmp(pv1, pv2, cur1);
+ return memEQ(pv1, pv2, cur1);
}
I32
-sv_cmp(str1,str2)
+sv_cmp(str1, str2)
register SV *str1;
register SV *str2;
{
+ STRLEN cur1 = 0;
+ char *pv1 = str1 ? SvPV(str1, cur1) : NULL;
+ STRLEN cur2 = 0;
+ char *pv2 = str2 ? SvPV(str2, cur2) : NULL;
I32 retval;
- char *pv1;
- STRLEN cur1;
- char *pv2;
- STRLEN cur2;
-
- if (!str1) {
- pv1 = "";
- cur1 = 0;
- }
- else
- pv1 = SvPV(str1, cur1);
-
- if (!str2) {
- pv2 = "";
- cur2 = 0;
- }
- else
- pv2 = SvPV(str2, cur2);
if (!cur1)
return cur2 ? -1 : 0;
+
if (!cur2)
return 1;
- if (cur1 < cur2) {
- /*SUPPRESS 560*/
- if (retval = memcmp((void*)pv1, (void*)pv2, cur1))
- return retval < 0 ? -1 : 1;
- else
- return -1;
- }
- /*SUPPRESS 560*/
- else if (retval = memcmp((void*)pv1, (void*)pv2, cur2))
+ retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
+
+ if (retval)
return retval < 0 ? -1 : 1;
- else if (cur1 == cur2)
+
+ if (cur1 == cur2)
return 0;
else
- return 1;
+ return cur1 < cur2 ? -1 : 1;
+}
+
+I32
+sv_cmp_locale(sv1, sv2)
+register SV *sv1;
+register SV *sv2;
+{
+#ifdef USE_LOCALE_COLLATE
+
+ char *pv1, *pv2;
+ STRLEN len1, len2;
+ I32 retval;
+
+ if (collation_standard)
+ goto raw_compare;
+
+ len1 = 0;
+ pv1 = sv1 ? sv_collxfrm(sv1, &len1) : NULL;
+ len2 = 0;
+ pv2 = sv2 ? sv_collxfrm(sv2, &len2) : 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, nxp)
+ SV *sv;
+ STRLEN *nxp;
+{
+ MAGIC *mg;
+
+ mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : NULL;
+ if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != 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(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(collation_ix);
+ }
+ else {
+ *nxp = 0;
+ return NULL;
+ }
}
+#endif /* USE_LOCALE_COLLATE */
+
char *
sv_gets(sv,fp,append)
register SV *sv;
-register FILE *fp;
+register PerlIO *fp;
I32 append;
{
char *rsptr;
@@ -2547,16 +3047,6 @@ I32 append;
register I32 cnt;
I32 i;
-#ifdef FAST_SV_GETS
- /*
- * 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;
-#endif
-
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv) && curcop != &compiling)
croak(no_modify);
@@ -2565,6 +3055,7 @@ I32 append;
}
if (!SvUPGRADE(sv, SVt_PV))
return 0;
+ SvSCREAM_off(sv);
if (RsSNARF(rs)) {
rsptr = NULL;
@@ -2580,23 +3071,49 @@ I32 append;
if (RsPARA(rs)) { /* have to do this both before and after */
do { /* to make sure file boundaries work right */
- if (feof(fp))
+ if (PerlIO_eof(fp))
return 0;
- i = getc(fp);
+ i = PerlIO_getc(fp);
if (i != '\n') {
if (i == -1)
return 0;
- ungetc(i,fp);
+ PerlIO_ungetc(fp,i);
break;
}
} while (i != EOF);
}
-#ifdef FAST_SV_GETS
+ /* 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 = FILE_cnt(fp); /* get count into register */
+ 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) {
@@ -2605,24 +3122,32 @@ I32 append;
}
else {
shortbuffered = 0;
- SvGROW(sv, append+cnt+2);/* (remembering cnt can be -1) */
+ /* 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 = FILE_ptr(fp);
+ 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 */
+ while (cnt > 0) { /* this | eat */
+ cnt--;
if ((*bp++ = *ptr++) == rslast) /* really | dust */
goto thats_all_folks; /* screams | sed :-) */
}
}
else {
- memcpy((char*)bp, (char*)ptr, cnt); /* this | eat */
+ Copy(ptr, bp, cnt, char); /* this | eat */
bp += cnt; /* screams | dust */
ptr += cnt; /* louder | sed :-) */
cnt = 0;
@@ -2639,11 +3164,25 @@ I32 append;
continue;
}
- FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */
- FILE_ptr(fp) = ptr;
- i = _filbuf(fp); /* get more characters */
- cnt = FILE_cnt(fp);
- ptr = FILE_ptr(fp); /* reregisterize cnt and ptr */
+ 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;
@@ -2653,7 +3192,7 @@ I32 append;
SvGROW(sv, bpx + cnt + 2);
bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
- *bp++ = i; /* store character from _filbuf */
+ *bp++ = i; /* store character from PerlIO_getc */
if (rslen && (STDCHAR)i == rslast) /* all done for now? */
goto thats_all_folks;
@@ -2661,58 +3200,77 @@ I32 append;
thats_all_folks:
if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
- bcmp((char*)bp - rslen, rsptr, rslen))
- goto screamer; /* go back to the fray */
+ memNE((char*)bp - rslen, rsptr, rslen))
+ goto screamer; /* go back to the fray */
thats_really_all_folks:
if (shortbuffered)
cnt += shortbuffered;
- FILE_cnt(fp) = cnt; /* put these back or we're in trouble */
- FILE_ptr(fp) = ptr;
+ 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 */
-
-#else /* SV_FAST_GETS */
-
- /*The big, slow, and stupid way */
-
+ 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];
-screamer:
+screamer2:
if (rslen) {
register STDCHAR *bpe = buf + sizeof(buf);
bp = buf;
- while ((i = getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
+ while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
; /* keep reading */
cnt = bp - buf;
}
else {
- cnt = fread((char*)buf, 1, sizeof(buf), fp);
- i = cnt ? (U8)buf[cnt - 1] : EOF;
+ 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, buf, cnt);
+ sv_catpvn(sv, (char *) buf, cnt);
else
- sv_setpvn(sv, buf, cnt);
+ sv_setpvn(sv, (char *) buf, cnt);
if (i != EOF && /* joy */
(!rslen ||
SvCUR(sv) < rslen ||
- bcmp(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
+ memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
{
append = -1;
- goto screamer;
+ /*
+ * 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;
}
}
-#endif /* SV_FAST_GETS */
-
if (RsPARA(rs)) { /* have to do this both before and after */
while (i != EOF) { /* to make sure file boundaries work right */
- i = getc(fp);
+ i = PerlIO_getc(fp);
if (i != '\n') {
- ungetc(i,fp);
+ PerlIO_ungetc(fp,i);
break;
}
}
@@ -2721,6 +3279,7 @@ screamer:
return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
}
+
void
sv_inc(sv)
register SV *sv;
@@ -2743,14 +3302,18 @@ register SV *sv;
if (SvGMAGICAL(sv))
mg_get(sv);
flags = SvFLAGS(sv);
- if (flags & SVp_IOK) {
- (void)SvIOK_only(sv);
- ++SvIVX(sv);
- return;
- }
if (flags & SVp_NOK) {
- SvNVX(sv) += 1.0;
(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)) {
@@ -2764,7 +3327,8 @@ register SV *sv;
while (isALPHA(*d)) d++;
while (isDIGIT(*d)) d++;
if (*d) {
- sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
+ SET_NUMERIC_STANDARD();
+ sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
return;
}
d--;
@@ -2813,16 +3377,20 @@ register SV *sv;
if (SvGMAGICAL(sv))
mg_get(sv);
flags = SvFLAGS(sv);
- if (flags & SVp_IOK) {
- (void)SvIOK_only(sv);
- --SvIVX(sv);
- return;
- }
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);
@@ -2830,7 +3398,8 @@ register SV *sv;
(void)SvNOK_only(sv);
return;
}
- sv_setnv(sv,atof(SvPVX(sv)) - 1.0);
+ SET_NUMERIC_STANDARD();
+ sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
}
/* Make a string that will exist for the duration of the expression
@@ -2841,7 +3410,7 @@ register SV *sv;
static void
sv_mortalgrow()
{
- tmps_max += 128;
+ tmps_max += (tmps_max < 512) ? 128 : 512;
Renew(tmps_stack, tmps_max, SV*);
}
@@ -2851,7 +3420,7 @@ SV *oldstr;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -2868,7 +3437,7 @@ sv_newmortal()
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = SVs_TEMP;
@@ -2902,7 +3471,7 @@ STRLEN len;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -2912,13 +3481,42 @@ STRLEN len;
return sv;
}
+#ifdef I_STDARG
+SV *
+newSVpvf(const char* pat, ...)
+#else
+/*VARARGS0*/
+SV *
+newSVpvf(pat, va_alist)
+const char *pat;
+va_dcl
+#endif
+{
+ register SV *sv;
+ va_list args;
+
+ new_SV(sv);
+ SvANY(sv) = 0;
+ SvREFCNT(sv) = 1;
+ SvFLAGS(sv) = 0;
+#ifdef I_STDARG
+ va_start(args, pat);
+#else
+ va_start(args);
+#endif
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ va_end(args);
+ return sv;
+}
+
+
SV *
newSVnv(n)
double n;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -2932,7 +3530,7 @@ IV i;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -2946,7 +3544,7 @@ SV *ref;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -2957,6 +3555,19 @@ SV *ref;
return sv;
}
+#ifdef CRIPPLED_CC
+SV *
+newRV_noinc(ref)
+SV *ref;
+{
+ register SV *sv;
+
+ sv = newRV(ref);
+ SvREFCNT_dec(ref);
+ return sv;
+}
+#endif /* CRIPPLED_CC */
+
/* make an exact duplicate of old */
SV *
@@ -2971,7 +3582,7 @@ register SV *old;
warn("semi-panic: attempt to dup freed string");
return Nullsv;
}
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -3023,24 +3634,22 @@ HV *stash;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
for (entry = HvARRAY(stash)[i];
entry;
- entry = entry->hent_next) {
- if (!todo[(U8)*entry->hent_key])
+ entry = HeNEXT(entry)) {
+ if (!todo[(U8)*HeKEY(entry)])
continue;
- gv = (GV*)entry->hent_val;
+ gv = (GV*)HeVAL(entry);
sv = GvSV(gv);
(void)SvOK_off(sv);
if (SvTYPE(sv) >= SVt_PV) {
SvCUR_set(sv, 0);
- SvTAINT(sv);
if (SvPVX(sv) != Nullch)
*SvPVX(sv) = '\0';
+ SvTAINT(sv);
}
if (GvAV(gv)) {
av_clear(GvAV(gv));
}
- if (GvHV(gv)) {
- if (HvNAME(GvHV(gv)))
- continue;
+ if (GvHV(gv) && !HvNAME(GvHV(gv))) {
hv_clear(GvHV(gv));
#ifndef VMS /* VMS has no environ array */
if (gv == envgv)
@@ -3052,6 +3661,40 @@ HV *stash;
}
}
+IO*
+sv_2io(sv)
+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,na), FALSE, SVt_PVIO);
+ if (gv)
+ io = GvIO(gv);
+ else
+ io = 0;
+ if (!io)
+ croak("Bad filehandle: %s", SvPV(sv,na));
+ break;
+ }
+ return io;
+}
+
CV *
sv_2cv(sv, st, gvp, lref)
SV *sv;
@@ -3099,20 +3742,20 @@ I32 lref;
return Nullcv;
*st = GvESTASH(gv);
fix_gv:
- if (lref && !GvCV(gv)) {
+ if (lref && !GvCVu(gv)) {
SV *tmpsv;
ENTER;
tmpsv = NEWSV(704,0);
- gv_efullname(tmpsv, gv);
- newSUB(start_subparse(),
+ gv_efullname3(tmpsv, gv, Nullch);
+ newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, tmpsv),
Nullop,
Nullop);
LEAVE;
- if (!GvCV(gv))
+ if (!GvCVu(gv))
croak("Unable to create sub named \"%s\"", SvPV(sv,na));
}
- return GvCV(gv);
+ return GvCVu(gv);
}
}
@@ -3146,30 +3789,40 @@ register SV *sv;
}
}
}
-#endif /* SvTRUE */
+#endif /* !SvTRUE */
#ifndef SvIV
-IV SvIV(Sv)
-register SV *Sv;
+IV
+SvIV(sv)
+register SV *sv;
{
- if (SvIOK(Sv))
- return SvIVX(Sv);
- return sv_2iv(Sv);
+ if (SvIOK(sv))
+ return SvIVX(sv);
+ return sv_2iv(sv);
}
-#endif /* SvIV */
+#endif /* !SvIV */
+#ifndef SvUV
+UV
+SvUV(sv)
+register SV *sv;
+{
+ if (SvIOK(sv))
+ return SvUVX(sv);
+ return sv_2uv(sv);
+}
+#endif /* !SvUV */
#ifndef SvNV
-double SvNV(Sv)
-register SV *Sv;
+double
+SvNV(sv)
+register SV *sv;
{
- if (SvNOK(Sv))
- return SvNVX(Sv);
- if (SvIOK(Sv))
- return (double)SvIVX(Sv);
- return sv_2nv(Sv);
+ if (SvNOK(sv))
+ return SvNVX(sv);
+ return sv_2nv(sv);
}
-#endif /* SvNV */
+#endif /* !SvNV */
#ifdef CRIPPLED_CC
char *
@@ -3225,7 +3878,7 @@ STRLEN *lp;
if (!SvPOK(sv)) {
SvPOK_on(sv); /* validate pointer */
SvTAINT(sv);
- DEBUG_c(fprintf(stderr,"0x%lx 2pv(%s)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
(unsigned long)sv,SvPVX(sv)));
}
}
@@ -3269,6 +3922,10 @@ int
sv_isobject(sv)
SV *sv;
{
+ if (!sv)
+ return 0;
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
if (!SvROK(sv))
return 0;
sv = (SV*)SvRV(sv);
@@ -3282,6 +3939,10 @@ sv_isa(sv, name)
SV *sv;
char *name;
{
+ if (!sv)
+ return 0;
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
if (!SvROK(sv))
return 0;
sv = (SV*)SvRV(sv);
@@ -3298,7 +3959,7 @@ char *classname;
{
SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 0;
SvFLAGS(sv) = 0;
@@ -3369,19 +4030,23 @@ HV* stash;
if (SvFLAGS(ref) & (SVs_OBJECT|SVf_READONLY)) {
if (SvREADONLY(ref))
croak(no_modify);
- if (SvOBJECT(ref) && SvTYPE(ref) != SVt_PVIO)
- --sv_objcount;
+ if (SvOBJECT(ref)) {
+ if (SvTYPE(ref) != SVt_PVIO)
+ --sv_objcount;
+ SvREFCNT_dec(SvSTASH(ref));
+ }
}
SvOBJECT_on(ref);
- ++sv_objcount;
+ if (SvTYPE(ref) != SVt_PVIO)
+ ++sv_objcount;
(void)SvUPGRADE(ref, SVt_PVMG);
SvSTASH(ref) = (HV*)SvREFCNT_inc(stash);
#ifdef OVERLOAD
- SvAMAGIC_off(sv);
- if (Gv_AMG(stash)) {
- SvAMAGIC_on(sv);
- }
+ if (Gv_AMG(stash))
+ SvAMAGIC_on(sv);
+ else
+ SvAMAGIC_off(sv);
#endif /* OVERLOAD */
return sv;
@@ -3394,7 +4059,7 @@ SV* sv;
assert(SvTYPE(sv) == SVt_PVGV);
SvFAKE_off(sv);
if (GvGP(sv))
- gp_free(sv);
+ gp_free((GV*)sv);
sv_unmagic(sv, '*');
Safefree(GvNAME(sv));
GvMULTI_off(sv);
@@ -3416,116 +4081,769 @@ SV* sv;
sv_2mortal(rv); /* Schedule for freeing later */
}
+void
+sv_taint(sv)
+SV *sv;
+{
+ sv_magic((sv), Nullsv, 't', Nullch, 0);
+}
+
+void
+sv_untaint(sv)
+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 *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, iv)
+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);
+}
+
+#ifdef I_STDARG
+void
+sv_setpvf(SV *sv, const char* pat, ...)
+#else
+/*VARARGS0*/
+void
+sv_setpvf(sv, pat, va_alist)
+ SV *sv;
+ const char *pat;
+ va_dcl
+#endif
+{
+ va_list args;
+#ifdef I_STDARG
+ va_start(args, pat);
+#else
+ va_start(args);
+#endif
+ sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ va_end(args);
+}
+
+#ifdef I_STDARG
+void
+sv_catpvf(SV *sv, const char* pat, ...)
+#else
+/*VARARGS0*/
+void
+sv_catpvf(sv, pat, va_alist)
+ SV *sv;
+ const char *pat;
+ va_dcl
+#endif
+{
+ va_list args;
+#ifdef I_STDARG
+ va_start(args, pat);
+#else
+ va_start(args);
+#endif
+ sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ va_end(args);
+}
+
+void
+sv_vsetpvfn(sv, pat, patlen, args, svargs, svmax, used_locale)
+ 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, pat, patlen, args, svargs, svmax, used_locale)
+ SV *sv;
+ const char *pat;
+ STRLEN patlen;
+ va_list *args;
+ SV **svargs;
+ I32 svmax;
+ bool *used_locale;
+{
+ 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:
+ 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 && precis > elen)
+ zeros = precis - elen;
+ 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 && dowarn &&
+ (op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) {
+ SV *msg = sv_newmortal();
+ sv_setpvf(msg, "Invalid conversion in %s: ",
+ (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);
+ }
+}
+
#ifdef DEBUGGING
void
sv_dump(sv)
SV* sv;
{
- char tmpbuf[1024];
- char *d = tmpbuf;
+ SV *d = sv_newmortal();
+ char *s;
U32 flags;
U32 type;
if (!sv) {
- fprintf(stderr, "SV = 0\n");
+ PerlIO_printf(Perl_debug_log, "SV = 0\n");
return;
}
flags = SvFLAGS(sv);
type = SvTYPE(sv);
- sprintf(d, "(0x%lx)\n REFCNT = %ld\n FLAGS = (",
- (unsigned long)SvANY(sv), (long)SvREFCNT(sv));
- d += strlen(d);
- if (flags & SVs_PADBUSY) strcat(d, "PADBUSY,");
- if (flags & SVs_PADTMP) strcat(d, "PADTMP,");
- if (flags & SVs_PADMY) strcat(d, "PADMY,");
- if (flags & SVs_TEMP) strcat(d, "TEMP,");
- if (flags & SVs_OBJECT) strcat(d, "OBJECT,");
- if (flags & SVs_GMG) strcat(d, "GMG,");
- if (flags & SVs_SMG) strcat(d, "SMG,");
- if (flags & SVs_RMG) strcat(d, "RMG,");
- d += strlen(d);
-
- if (flags & SVf_IOK) strcat(d, "IOK,");
- if (flags & SVf_NOK) strcat(d, "NOK,");
- if (flags & SVf_POK) strcat(d, "POK,");
- if (flags & SVf_ROK) strcat(d, "ROK,");
- if (flags & SVf_OOK) strcat(d, "OOK,");
- if (flags & SVf_FAKE) strcat(d, "FAKE,");
- if (flags & SVf_READONLY) strcat(d, "READONLY,");
- d += strlen(d);
-
- if (flags & SVp_IOK) strcat(d, "pIOK,");
- if (flags & SVp_NOK) strcat(d, "pNOK,");
- if (flags & SVp_POK) strcat(d, "pPOK,");
- if (flags & SVp_SCREAM) strcat(d, "SCREAM,");
- d += strlen(d);
- if (d[-1] == ',')
- d--;
- *d++ = ')';
- *d = '\0';
+ 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, " ),");
+ }
+ }
+ }
+
+ if (*(SvEND(d) - 1) == ',')
+ SvPVX(d)[--SvCUR(d)] = '\0';
+ sv_catpv(d, ")");
+ s = SvPVX(d);
- fprintf(stderr, "SV = ");
+ PerlIO_printf(Perl_debug_log, "SV = ");
switch (type) {
case SVt_NULL:
- fprintf(stderr,"NULL%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "NULL%s\n", s);
return;
case SVt_IV:
- fprintf(stderr,"IV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "IV%s\n", s);
break;
case SVt_NV:
- fprintf(stderr,"NV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "NV%s\n", s);
break;
case SVt_RV:
- fprintf(stderr,"RV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "RV%s\n", s);
break;
case SVt_PV:
- fprintf(stderr,"PV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PV%s\n", s);
break;
case SVt_PVIV:
- fprintf(stderr,"PVIV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVIV%s\n", s);
break;
case SVt_PVNV:
- fprintf(stderr,"PVNV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVNV%s\n", s);
break;
case SVt_PVBM:
- fprintf(stderr,"PVBM%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVBM%s\n", s);
break;
case SVt_PVMG:
- fprintf(stderr,"PVMG%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVMG%s\n", s);
break;
case SVt_PVLV:
- fprintf(stderr,"PVLV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVLV%s\n", s);
break;
case SVt_PVAV:
- fprintf(stderr,"PVAV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVAV%s\n", s);
break;
case SVt_PVHV:
- fprintf(stderr,"PVHV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVHV%s\n", s);
break;
case SVt_PVCV:
- fprintf(stderr,"PVCV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVCV%s\n", s);
break;
case SVt_PVGV:
- fprintf(stderr,"PVGV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVGV%s\n", s);
break;
case SVt_PVFM:
- fprintf(stderr,"PVFM%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVFM%s\n", s);
break;
case SVt_PVIO:
- fprintf(stderr,"PVIO%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVIO%s\n", s);
break;
default:
- fprintf(stderr,"UNKNOWN%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", s);
return;
}
if (type >= SVt_PVIV || type == SVt_IV)
- fprintf(stderr, " IV = %ld\n", (long)SvIVX(sv));
- if (type >= SVt_PVNV || type == SVt_NV)
- fprintf(stderr, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
+ 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)) {
- fprintf(stderr, " RV = 0x%lx\n", (long)SvRV(sv));
+ PerlIO_printf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv));
sv_dump(SvRV(sv));
return;
}
@@ -3533,103 +4851,110 @@ SV* sv;
return;
if (type <= SVt_PVLV) {
if (SvPVX(sv))
- fprintf(stderr, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n",
+ 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
- fprintf(stderr, " PV = 0\n");
+ PerlIO_printf(Perl_debug_log, " PV = 0\n");
}
if (type >= SVt_PVMG) {
if (SvMAGIC(sv)) {
- fprintf(stderr, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv));
+ PerlIO_printf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv));
}
if (SvSTASH(sv))
- fprintf(stderr, " STASH = %s\n", HvNAME(SvSTASH(sv)));
+ PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv)));
}
switch (type) {
case SVt_PVLV:
- fprintf(stderr, " TYPE = %c\n", LvTYPE(sv));
- fprintf(stderr, " TARGOFF = %ld\n", (long)LvTARGOFF(sv));
- fprintf(stderr, " TARGLEN = %ld\n", (long)LvTARGLEN(sv));
- fprintf(stderr, " TARG = 0x%lx\n", (long)LvTARG(sv));
+ 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:
- fprintf(stderr, " ARRAY = 0x%lx\n", (long)AvARRAY(sv));
- fprintf(stderr, " ALLOC = 0x%lx\n", (long)AvALLOC(sv));
- fprintf(stderr, " FILL = %ld\n", (long)AvFILL(sv));
- fprintf(stderr, " MAX = %ld\n", (long)AvMAX(sv));
- fprintf(stderr, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv));
+ 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)AvFILL(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);
- d = tmpbuf;
- if (flags & AVf_REAL) strcat(d, "REAL,");
- if (flags & AVf_REIFY) strcat(d, "REIFY,");
- if (flags & AVf_REUSED) strcat(d, "REUSED,");
- if (*d)
- d[strlen(d)-1] = '\0';
- fprintf(stderr, " FLAGS = (%s)\n", d);
+ 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:
- fprintf(stderr, " ARRAY = 0x%lx\n",(long)HvARRAY(sv));
- fprintf(stderr, " KEYS = %ld\n", (long)HvKEYS(sv));
- fprintf(stderr, " FILL = %ld\n", (long)HvFILL(sv));
- fprintf(stderr, " MAX = %ld\n", (long)HvMAX(sv));
- fprintf(stderr, " RITER = %ld\n", (long)HvRITER(sv));
- fprintf(stderr, " EITER = 0x%lx\n",(long) HvEITER(sv));
+ 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))
- fprintf(stderr, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv));
+ PerlIO_printf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv));
if (HvNAME(sv))
- fprintf(stderr, " NAME = \"%s\"\n", HvNAME(sv));
+ PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv));
break;
- case SVt_PVFM:
case SVt_PVCV:
- fprintf(stderr, " STASH = 0x%lx\n", (long)CvSTASH(sv));
- fprintf(stderr, " START = 0x%lx\n", (long)CvSTART(sv));
- fprintf(stderr, " ROOT = 0x%lx\n", (long)CvROOT(sv));
- fprintf(stderr, " XSUB = 0x%lx\n", (long)CvXSUB(sv));
- fprintf(stderr, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32);
- fprintf(stderr, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv));
- fprintf(stderr, " DEPTH = %ld\n", (long)CvDEPTH(sv));
- fprintf(stderr, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv));
- fprintf(stderr, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv));
+ if (SvPOK(sv))
+ PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,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));
if (type == SVt_PVFM)
- fprintf(stderr, " LINES = %ld\n", (long)FmLINES(sv));
+ PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv));
break;
case SVt_PVGV:
- fprintf(stderr, " NAME = %s\n", GvNAME(sv));
- fprintf(stderr, " NAMELEN = %ld\n", (long)GvNAMELEN(sv));
- fprintf(stderr, " STASH = 0x%lx\n", (long)GvSTASH(sv));
- fprintf(stderr, " GP = 0x%lx\n", (long)GvGP(sv));
- fprintf(stderr, " SV = 0x%lx\n", (long)GvSV(sv));
- fprintf(stderr, " REFCNT = %ld\n", (long)GvREFCNT(sv));
- fprintf(stderr, " IO = 0x%lx\n", (long)GvIOp(sv));
- fprintf(stderr, " FORM = 0x%lx\n", (long)GvFORM(sv));
- fprintf(stderr, " AV = 0x%lx\n", (long)GvAV(sv));
- fprintf(stderr, " HV = 0x%lx\n", (long)GvHV(sv));
- fprintf(stderr, " CV = 0x%lx\n", (long)GvCV(sv));
- fprintf(stderr, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv));
- fprintf(stderr, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv));
- fprintf(stderr, " LINE = %ld\n", (long)GvLINE(sv));
- fprintf(stderr, " FLAGS = 0x%x\n", (int)GvFLAGS(sv));
- fprintf(stderr, " STASH = 0x%lx\n", (long)GvSTASH(sv));
- fprintf(stderr, " EGV = 0x%lx\n", (long)GvEGV(sv));
+ 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", HvNAME(GvSTASH(sv)));
+ 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:
- fprintf(stderr, " IFP = 0x%lx\n", (long)IoIFP(sv));
- fprintf(stderr, " OFP = 0x%lx\n", (long)IoOFP(sv));
- fprintf(stderr, " DIRP = 0x%lx\n", (long)IoDIRP(sv));
- fprintf(stderr, " LINES = %ld\n", (long)IoLINES(sv));
- fprintf(stderr, " PAGE = %ld\n", (long)IoPAGE(sv));
- fprintf(stderr, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv));
- fprintf(stderr, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv));
- fprintf(stderr, " TOP_NAME = %s\n", IoTOP_NAME(sv));
- fprintf(stderr, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv));
- fprintf(stderr, " FMT_NAME = %s\n", IoFMT_NAME(sv));
- fprintf(stderr, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv));
- fprintf(stderr, " BOTTOM_NAME = %s\n", IoBOTTOM_NAME(sv));
- fprintf(stderr, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv));
- fprintf(stderr, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv));
- fprintf(stderr, " TYPE = %c\n", IoTYPE(sv));
- fprintf(stderr, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv));
+ 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;
}
}
@@ -3640,38 +4965,3 @@ SV* sv;
{
}
#endif
-
-IO*
-sv_2io(sv)
-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,na), FALSE, SVt_PVIO);
- if (gv)
- io = GvIO(gv);
- else
- io = 0;
- if (!io)
- croak("Bad filehandle: %s", SvPV(sv,na));
- break;
- }
- return io;
-}
-
diff --git a/gnu/usr.bin/perl/sv.h b/gnu/usr.bin/perl/sv.h
index c586de4e02a..cf180613814 100644
--- a/gnu/usr.bin/perl/sv.h
+++ b/gnu/usr.bin/perl/sv.h
@@ -1,6 +1,6 @@
/* sv.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -126,13 +126,10 @@ struct io {
#define SVpfm_COMPILED 0x80000000
#define SVpbm_VALID 0x80000000
-#define SVpbm_CASEFOLD 0x40000000
-#define SVpbm_TAIL 0x20000000
+#define SVpbm_TAIL 0x40000000
-#ifdef OVERLOAD
-#define SVpgv_AM 0x40000000
-/* #define SVpgv_badAM 0x20000000 */
-#endif /* OVERLOAD */
+#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 */
@@ -151,6 +148,13 @@ struct xpviv {
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 */
@@ -214,6 +218,8 @@ struct xpvbm {
U8 xbm_rare; /* rarest character in string */
};
+/* This structure much match XPVCV */
+
struct xpvfm {
char * xpv_pv; /* pointer to malloced string */
STRLEN xpv_cur; /* length of xpv_pv as a C string */
@@ -233,6 +239,8 @@ struct xpvfm {
long xcv_depth; /* >= 2 indicates recursive call */
AV * xcv_padlist;
CV * xcv_outside;
+ U8 xcv_flags;
+
I32 xfm_lines;
};
@@ -245,8 +253,8 @@ struct xpvio {
MAGIC* xmg_magic; /* linked list of magicalness */
HV* xmg_stash; /* class package */
- FILE * xio_ifp; /* ifp and ofp are normally the same */
- FILE * xio_ofp; /* but sockets need separate streams */
+ 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; /* $% */
@@ -267,6 +275,7 @@ struct xpvio {
#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. */
@@ -398,10 +407,6 @@ struct xpvio {
#define SvTAIL_on(sv) (SvFLAGS(sv) |= SVpbm_TAIL)
#define SvTAIL_off(sv) (SvFLAGS(sv) &= ~SVpbm_TAIL)
-#define SvCASEFOLD(sv) (SvFLAGS(sv) & SVpbm_CASEFOLD)
-#define SvCASEFOLD_on(sv) (SvFLAGS(sv) |= SVpbm_CASEFOLD)
-#define SvCASEFOLD_off(sv) (SvFLAGS(sv) &= ~SVpbm_CASEFOLD)
-
#define SvVALID(sv) (SvFLAGS(sv) & SVpbm_VALID)
#define SvVALID_on(sv) (SvFLAGS(sv) |= SVpbm_VALID)
#define SvVALID_off(sv) (SvFLAGS(sv) &= ~SVpbm_VALID)
@@ -411,6 +416,8 @@ struct xpvio {
#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
@@ -470,11 +477,16 @@ struct xpvio {
#define IoTYPE(sv) ((XPVIO*) SvANY(sv))->xio_type
#define IoFLAGS(sv) ((XPVIO*) SvANY(sv))->xio_flags
-#define SvTAINT(sv) if (tainting && tainted) sv_magic(sv, Nullsv, 't', Nullch, 0)
+#define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv))
+#define SvTAINTED_on(sv) STMT_START{ if(tainting){sv_taint(sv);} }STMT_END
+#define SvTAINTED_off(sv) STMT_START{ if(tainting){sv_untaint(sv);} }STMT_END
+
+#define SvTAINT(sv) STMT_START{ if(tainted){SvTAINTED_on(sv);} }STMT_END
#ifdef CRIPPLED_CC
IV SvIV _((SV* sv));
+UV SvUV _((SV* sv));
double SvNV _((SV* sv));
#define SvPV_force(sv, lp) sv_pvn_force(sv, &lp)
#define SvPV(sv, lp) sv_pvn(sv, &lp)
@@ -482,6 +494,7 @@ char *sv_pvn _((SV *, STRLEN *));
I32 SvTRUE _((SV *));
#define SvIVx(sv) SvIV(sv)
+#define SvUVx(sv) SvUV(sv)
#define SvNVx(sv) SvNV(sv)
#define SvPVx(sv, lp) sv_pvn(sv, &lp)
#define SvPVx_force(sv, lp) sv_pvn_force(sv, &lp)
@@ -489,14 +502,25 @@ I32 SvTRUE _((SV *));
#else /* !CRIPPLED_CC */
+#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))
-#define SvPV(sv, lp) (SvPOK(sv) ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv(sv, &lp))
+#undef SvPV
+#define SvPV(sv, lp) \
+ (SvPOK(sv) ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_2pv(sv, &lp))
-#define SvPV_force(sv, lp) ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force(sv, &lp))
+#undef SvPV_force
+#define SvPV_force(sv, lp) \
+ ((SvFLAGS(sv) & (SVf_POK|SVf_THINKFIRST)) == SVf_POK \
+ ? ((lp = SvCUR(sv)), SvPVX(sv)) : sv_pvn_force(sv, &lp))
+#undef SvTRUE
#define SvTRUE(sv) ( \
!sv \
? 0 \
@@ -515,20 +539,54 @@ I32 SvTRUE _((SV *));
: sv_2bool(sv) )
#define SvIVx(sv) ((Sv = (sv)), SvIV(Sv))
+#define SvUVx(sv) ((Sv = (sv)), SvUV(Sv))
#define SvNVx(sv) ((Sv = (sv)), SvNV(Sv))
#define SvPVx(sv, lp) ((Sv = (sv)), SvPV(Sv, lp))
#define SvTRUEx(sv) ((Sv = (sv)), SvTRUE(Sv))
#endif /* CRIPPLED_CC */
+#define newRV_inc(sv) newRV(sv)
+#ifdef CRIPPLED_CC
+SV *newRV_noinc _((SV *));
+#else
+#define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv)
+#endif
+
/* the following macro updates any magic values this sv is associated with */
#define SvSETMAGIC(x) if (SvSMAGICAL(x)) mg_set(x)
-#define SvSetSV(dst,src) if (dst != src) sv_setsv(dst,src)
+#define SvSetSV_and(dst,src,finally) \
+ if ((dst) != (src)) { \
+ sv_setsv(dst, src); \
+ finally; \
+ }
+#define SvSetSV_nosteal_and(dst,src,finally) \
+ if ((dst) != (src)) { \
+ U32 tMpF = SvFLAGS(src) & SVs_TEMP; \
+ SvTEMP_off(src); \
+ sv_setsv(dst, src); \
+ SvFLAGS(src) |= tMpF; \
+ finally; \
+ }
+
+#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)==&sv_undef || (sv)==&sv_yes || (sv)==&sv_no)
+
+#define boolSV(b) ((b) ? &sv_yes : &sv_no)
+
#define isGV(sv) (SvTYPE(sv) == SVt_PVGV)
#ifndef DOSISH
diff --git a/gnu/usr.bin/perl/t/README b/gnu/usr.bin/perl/t/README
index d714295dd25..83843491791 100644
--- a/gnu/usr.bin/perl/t/README
+++ b/gnu/usr.bin/perl/t/README
@@ -8,4 +8,9 @@ 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 come up with new tests, send them to lwall@sems.com.
+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/gnu/usr.bin/perl/t/TEST b/gnu/usr.bin/perl/t/TEST
index 291eab5bdb3..cae81031c29 100644
--- a/gnu/usr.bin/perl/t/TEST
+++ b/gnu/usr.bin/perl/t/TEST
@@ -1,63 +1,76 @@
#!./perl
-# $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $
+# 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] eq '-v') {
+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"
+die "You need to run \"make test\" first to set things up.\n"
unless -e 'perl' or -e 'perl.exe';
$ENV{EMXSHELL} = 'sh'; # For OS/2
-if ($ARGV[0] eq '') {
+if ($#ARGV == -1) {
@ARGV = split(/[ \n]/,
- `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t lib/*.t`);
+ `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`);
}
-open(CONFIG,"../config.sh");
-while (<CONFIG>) {
- if (/sharpbang='(.*)'/) {
- $sharpbang = ($1 eq '#!');
- last;
+if ($^O eq 'os2' || $^O eq 'qnx') {
+ $sharpbang = 0;
+}
+else {
+ open(CONFIG, "../config.sh");
+ while (<CONFIG>) {
+ if (/sharpbang='(.*)'/) {
+ $sharpbang = ($1 eq '#!');
+ last;
+ }
}
+ close(CONFIG);
}
-$sharpbang = 0 if $ENV{OS2_SHELL}; # OS/2
+
$bad = 0;
$good = 0;
$total = @ARGV;
+$files = 0;
+$totmax = 0;
while ($test = shift) {
if ($test =~ /^$/) {
next;
}
$te = $test;
chop($te);
- print "$te" . '.' x (15 - length($te));
+ print "$te" . '.' x (18 - length($te));
if ($sharpbang) {
- open(results,"./$test |") || (print "can't run.\n");
+ -x $test || (print "isn't executable.\n");
+ open(RESULTS,"./$test |") || (print "can't run.\n");
} else {
- open(script,"$test") || die "Can't run $test.\n";
- $_ = <script>;
- close(script);
+ open(SCRIPT,"$test") || 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 = '';
}
- open(results,"./perl$switch $test |") || (print "can't run.\n");
+ open(RESULTS,"./perl$switch $test |") || (print "can't run.\n");
}
$ok = 0;
$next = 0;
- while (<results>) {
+ while (<RESULTS>) {
if ($verbose) {
print $_;
}
@@ -80,11 +93,16 @@ while ($test = shift) {
}
$next = $next - 1;
if ($ok && $next == $max) {
- print "ok\n";
- $good = $good + 1;
+ if ($max) {
+ print "ok\n";
+ $good = $good + 1;
+ } else {
+ print "skipping test on this platform\n";
+ $files -= 1;
+ }
} else {
$next += 1;
- print "FAILED on test $next\n";
+ print "FAILED at test $next\n";
$bad = $bad + 1;
$_ = $test;
if (/^base/) {
@@ -96,17 +114,31 @@ while ($test = shift) {
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, $pct% okay.\n";
+ warn "Failed 1 test script out of $total, $pct% okay.\n";
} else {
- die "Failed $bad/$total tests, $pct% okay.\n";
+ 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".
+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 files=%d tests=%d\n",
+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/gnu/usr.bin/perl/t/base/lex.t b/gnu/usr.bin/perl/t/base/lex.t
index f25cd2a12c5..6d03b9e8df3 100644
--- a/gnu/usr.bin/perl/t/base/lex.t
+++ b/gnu/usr.bin/perl/t/base/lex.t
@@ -2,7 +2,7 @@
# $RCSfile: lex.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:04 $
-print "1..24\n";
+print "1..27\n";
$x = 'x';
@@ -76,16 +76,32 @@ 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 19\n" : "not ok 19\n";
+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}{$bar}" eq "FOO{BAR}" ? "ok 20\n" : "not ok 20\n";
-print "${foo{$bar}}" eq "BAZ" ? "ok 21\n" : "not ok 21\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";
-print "FOO:" =~ /$foo[:]/ ? "ok 22\n" : "not ok 22\n";
-print "ABC" =~ /^$ary[$A]$/ ? "ok 23\n" : "not ok 23\n";
-print "FOOZ" =~ /^$foo[$A-Z]$/ ? "ok 24\n" : "not ok 24\n";
+print (((q{{\{\(}} . q{{\)\}}}) eq '{{\(}{\)}}') ? "ok 27\n" : "not ok 27\n");
diff --git a/gnu/usr.bin/perl/t/base/term.t b/gnu/usr.bin/perl/t/base/term.t
index 42cd56fe0ba..782ad397d33 100644
--- a/gnu/usr.bin/perl/t/base/term.t
+++ b/gnu/usr.bin/perl/t/base/term.t
@@ -2,12 +2,12 @@
# $RCSfile: term.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:07 $
-print "1..6\n";
+print "1..7\n";
# check "" interpretation
$x = "\n";
-if ($x lt ' ') {print "ok 1\n";} else {print "not ok 1\n";}
+if ($x eq chr(10)) {print "ok 1\n";} else {print "not ok 1\n";}
# check `` processing
@@ -27,16 +27,19 @@ if ($#x == '1') {print "ok 3\n";} else {print "not ok 3\n";}
$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 5\n";
+ print "ok 6\n";
}
else {
- print "not ok 5\n";
+ 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 6\n";} else {print "not ok 6\n";}
+if (<try> ne '') {print "ok 7\n";} else {print "not ok 7\n";}
diff --git a/gnu/usr.bin/perl/t/cmd/mod.t b/gnu/usr.bin/perl/t/cmd/mod.t
index 9d9170ff3fa..b4f2731ffa2 100644
--- a/gnu/usr.bin/perl/t/cmd/mod.t
+++ b/gnu/usr.bin/perl/t/cmd/mod.t
@@ -2,7 +2,7 @@
# $RCSfile: mod.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:11 $
-print "1..7\n";
+print "1..11\n";
print "ok 1\n" if 1;
print "not ok 1\n" unless 1;
@@ -31,3 +31,17 @@ open(foo,'./TEST') || open(foo,'TEST') || open(foo,'t/TEST');
$x = 0;
$x++ while <foo>;
print $x > 50 && $x < 1000 ? "ok 7\n" : "not ok 7\n";
+
+$x = -0.5;
+print "not " if scalar($x) < 0 and $x >= 0;
+print "ok 8\n";
+
+print "not " unless (-(-$x) < 0) == ($x < 0);
+print "ok 9\n";
+
+print "ok 10\n" if $x < 0;
+print "not ok 10\n" unless $x < 0;
+
+print "ok 11\n" unless $x > 0;
+print "not ok 11\n" if $x > 0;
+
diff --git a/gnu/usr.bin/perl/t/cmd/while.t b/gnu/usr.bin/perl/t/cmd/while.t
index 4c8c10e990a..c6e464d444a 100644
--- a/gnu/usr.bin/perl/t/cmd/while.t
+++ b/gnu/usr.bin/perl/t/cmd/while.t
@@ -90,6 +90,7 @@ loop: while (<fh>) {
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;
diff --git a/gnu/usr.bin/perl/t/comp/cmdopt.t b/gnu/usr.bin/perl/t/comp/cmdopt.t
index 4d5c78a4cb5..3f701a456ac 100644
--- a/gnu/usr.bin/perl/t/comp/cmdopt.t
+++ b/gnu/usr.bin/perl/t/comp/cmdopt.t
@@ -2,7 +2,7 @@
# $RCSfile: cmdopt.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:17 $
-print "1..40\n";
+print "1..44\n";
# test the optimization of constants
@@ -81,3 +81,10 @@ 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/gnu/usr.bin/perl/t/comp/colon.t b/gnu/usr.bin/perl/t/comp/colon.t
new file mode 100644
index 00000000000..d2c64fe4c53
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/comp/cpp.aux b/gnu/usr.bin/perl/t/comp/cpp.aux
index 11865665d71..377c74c6c61 100644
--- a/gnu/usr.bin/perl/t/comp/cpp.aux
+++ b/gnu/usr.bin/perl/t/comp/cpp.aux
@@ -1,6 +1,6 @@
#!./perl -P
-# $RCSfile: cpp.aux,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:11 $
+# $RCSfile: cpp.aux,v $$Revision: 1.2 $$Date: 1997/11/30 08:00:02 $
print "1..3\n";
diff --git a/gnu/usr.bin/perl/t/comp/cpp.t b/gnu/usr.bin/perl/t/comp/cpp.t
index cea46f0d964..b9693d060c8 100644
--- a/gnu/usr.bin/perl/t/comp/cpp.t
+++ b/gnu/usr.bin/perl/t/comp/cpp.t
@@ -1,6 +1,6 @@
#!./perl
-# $RCSfile: cpp.t,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:11 $
+# $RCSfile: cpp.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:00:03 $
BEGIN {
chdir 't' if -d 't';
@@ -8,8 +8,9 @@ BEGIN {
}
use Config;
-if ( ($Config{'cppstdin'} =~ /\bcppstdin\b/) and
- ( ! -x $Config{'scriptdir'} . "/cppstdin") ) {
+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.
}
diff --git a/gnu/usr.bin/perl/t/comp/multiline.t b/gnu/usr.bin/perl/t/comp/multiline.t
index 634b06a7a84..fc1eedc8d25 100644
--- a/gnu/usr.bin/perl/t/comp/multiline.t
+++ b/gnu/usr.bin/perl/t/comp/multiline.t
@@ -32,9 +32,11 @@ if ($z eq $y) {print "ok 2\n";} else {print "not ok 2\n";}
if ($count == 3) {print "ok 3\n";} else {print "not ok 3\n";}
-$_ = `cat Comp.try`;
+$_ = ($^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/gnu/usr.bin/perl/t/comp/package.t b/gnu/usr.bin/perl/t/comp/package.t
index ca800bb3647..cef02c5cb4f 100644
--- a/gnu/usr.bin/perl/t/comp/package.t
+++ b/gnu/usr.bin/perl/t/comp/package.t
@@ -5,7 +5,7 @@ print "1..7\n";
$blurfl = 123;
$foo = 3;
-package XYZ;
+package xyz;
$bar = 4;
@@ -20,10 +20,10 @@ $ABC'dyick = 6;
$xyz = 2;
$main = join(':', sort(keys %main::));
-$XYZ = join(':', sort(keys %XYZ::));
+$xyz = join(':', sort(keys %xyz::));
$ABC = join(':', sort(keys %ABC::));
-print $XYZ eq 'ABC:XYZ:bar:main:xyz' ? "ok 1\n" : "not ok 1 '$XYZ'\n";
+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";
diff --git a/gnu/usr.bin/perl/t/comp/proto.t b/gnu/usr.bin/perl/t/comp/proto.t
new file mode 100644
index 00000000000..d1cfede8af9
--- /dev/null
+++ b/gnu/usr.bin/perl/t/comp/proto.t
@@ -0,0 +1,390 @@
+#!./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..76\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 \&an_array_ref, '\@';
+
+sub an_array_ref (\@) {
+ print "# \@_ = (",join(",",@_),")\n";
+ print "not " unless ref($_[0]) && 1 == @{$_[0]};
+ printf "ok %d\n",$i++;
+ @{$_[0]} = (qw(ok)," ",$i++,"\n");
+}
+
+@array = ('a');
+an_array_ref @array;
+print "not " unless @array == 4;
+print @array;
+
+# 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";
diff --git a/gnu/usr.bin/perl/t/comp/redef.t b/gnu/usr.bin/perl/t/comp/redef.t
new file mode 100644
index 00000000000..07e978bb866
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/comp/script.t b/gnu/usr.bin/perl/t/comp/script.t
index 7ca65037588..3731ca078ea 100644
--- a/gnu/usr.bin/perl/t/comp/script.t
+++ b/gnu/usr.bin/perl/t/comp/script.t
@@ -1,10 +1,11 @@
#!./perl
-# $RCSfile: script.t,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:12 $
+# $RCSfile: script.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:00:08 $
print "1..3\n";
-$x = `./perl -e 'print "ok\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";}
@@ -13,12 +14,12 @@ open(try,">Comp.script") || (die "Can't open temp file.");
print try 'print "ok\n";'; print try "\n";
close try;
-$x = `./perl Comp.script`;
+$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`;
+$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";}
diff --git a/gnu/usr.bin/perl/t/comp/term.t b/gnu/usr.bin/perl/t/comp/term.t
index b248e9b1613..eb9968003e7 100644
--- a/gnu/usr.bin/perl/t/comp/term.t
+++ b/gnu/usr.bin/perl/t/comp/term.t
@@ -4,7 +4,7 @@
# tests that aren't important enough for base.term
-print "1..14\n";
+print "1..22\n";
$x = "\\n";
print "#1\t:$x: eq " . ':\n:' . "\n";
@@ -33,3 +33,38 @@ 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/gnu/usr.bin/perl/t/comp/use.t b/gnu/usr.bin/perl/t/comp/use.t
new file mode 100644
index 00000000000..a6ce2a4d565
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/harness b/gnu/usr.bin/perl/t/harness
index c98d91e360e..fe64a046290 100644
--- a/gnu/usr.bin/perl/t/harness
+++ b/gnu/usr.bin/perl/t/harness
@@ -3,13 +3,17 @@
# We suppose that perl _mostly_ works at this moment, so may use
# sophisticated testing.
-# Note that _before install_ you may need to run it with -I ../lib flag
-
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
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 = <*/*.t> unless @tests;
+@tests = <base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t lib/*.t> unless @tests;
Test::Harness::runtests @tests;
diff --git a/gnu/usr.bin/perl/t/io/argv.t b/gnu/usr.bin/perl/t/io/argv.t
index 40ed23b373b..d99865e142e 100644
--- a/gnu/usr.bin/perl/t/io/argv.t
+++ b/gnu/usr.bin/perl/t/io/argv.t
@@ -8,16 +8,28 @@ open(try, '>Io.argv.tmp') || (die "Can't open temp file.");
print try "a line\n";
close try;
-$x = `./perl -e 'while (<>) {print \$.,\$_;}' Io.argv.tmp Io.argv.tmp`;
-
+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";}
-$x = `echo foo|./perl -e 'while (<>) {print $_;}' Io.argv.tmp -`;
-
+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";}
-$x = `echo foo|./perl -e 'while (<>) {print $_;}'`;
-
+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');
@@ -33,4 +45,4 @@ if ($y eq "1a line\n2a line\n3a line\n")
else
{print "not ok 5\n";}
-`/bin/rm -f Io.argv.tmp` if -x '/bin/rm';
+unlink 'Io.argv.tmp';
diff --git a/gnu/usr.bin/perl/t/io/dup.t b/gnu/usr.bin/perl/t/io/dup.t
index 901642d8f66..f312671e56b 100644
--- a/gnu/usr.bin/perl/t/io/dup.t
+++ b/gnu/usr.bin/perl/t/io/dup.t
@@ -17,8 +17,14 @@ select(STDOUT); $| = 1;
print STDOUT "ok 2\n";
print STDERR "ok 3\n";
-system 'echo ok 4';
-system 'echo ok 5 1>&2';
+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);
@@ -26,7 +32,8 @@ close(STDERR);
open(STDOUT,">&dupout");
open(STDERR,">&duperr");
-system 'cat Io.dup';
+if ($^O eq 'MSWin32') { print `type Io.dup` }
+else { system 'cat Io.dup' }
unlink 'Io.dup';
print STDOUT "ok 6\n";
diff --git a/gnu/usr.bin/perl/t/io/fs.t b/gnu/usr.bin/perl/t/io/fs.t
index a219b81eef1..ca82689c6fe 100644
--- a/gnu/usr.bin/perl/t/io/fs.t
+++ b/gnu/usr.bin/perl/t/io/fs.t
@@ -2,12 +2,23 @@
# $RCSfile: fs.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:28 $
-print "1..22\n";
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+
+# avoid win32 (for now)
+do { print "1..0\n"; exit(0); } if $^O eq 'MSWin32';
-$wd = `pwd`;
+print "1..26\n";
+
+$wd = (($^O eq 'MSWin32') ? `cd` : `pwd`);
chop($wd);
-`rm -f tmp 2>/dev/null; mkdir tmp 2>/dev/null`;
+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';
@@ -26,8 +37,11 @@ if (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 ($nlink == 3) {print "ok 4\n";} else {print "not ok 4\n";}
-if (($mode & 0777) == 0666) {print "ok 5\n";} else {print "not ok 5\n";}
+if ($Config{dont_use_nlink} || $nlink == 3)
+ {print "ok 4\n";} else {print "not ok 4\n";}
+
+if (($mode & 0777) == 0666 || $^O eq 'amigaos')
+ {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";}
@@ -61,7 +75,8 @@ 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 (($atime == 500000000 && $mtime == 500000001) || $wd =~ m#/afs/#)
+if (($atime == 500000000 && $mtime == 500000001)
+ || $wd =~ m#/afs/# || $^O eq 'amigaos')
{print "ok 18\n";}
else
{print "not ok 18 $atime $mtime\n";}
@@ -73,13 +88,41 @@ 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 (`ls -l perl 2>/dev/null` =~ /^l.*->/) { # we have symbolic links
+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 (-s "Iofs.tmp" == 5) {print "ok 25\n"} else {print "not ok 25\n"}
+ truncate FH, 0;
+ if (-z "Iofs.tmp") {print "ok 26\n"} else {print "not ok 26\n"}
+ close FH;
+}
+unlink "Iofs.tmp";
diff --git a/gnu/usr.bin/perl/t/io/inplace.t b/gnu/usr.bin/perl/t/io/inplace.t
index 477add19423..2652c8bebef 100644
--- a/gnu/usr.bin/perl/t/io/inplace.t
+++ b/gnu/usr.bin/perl/t/io/inplace.t
@@ -7,7 +7,16 @@ $^I = '.bak';
print "1..2\n";
@ARGV = ('.a','.b','.c');
-`echo foo | tee .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`;
+}
+else {
+ $CAT = 'cat';
+ `echo foo | tee .a .b .c`;
+}
while (<>) {
s/foo/bar/;
}
@@ -15,7 +24,7 @@ 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.bak .b.bak .c.bak` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";}
+if (`$CAT .a .b .c` eq "bar\nbar\nbar\n") {print "ok 1\n";} else {print "not ok 1\n";}
+if (`$CAT .a.bak .b.bak .c.bak` eq "foo\nfoo\nfoo\n") {print "ok 2\n";} else {print "not ok 2\n";}
unlink '.a', '.b', '.c', '.a.bak', '.b.bak', '.c.bak';
diff --git a/gnu/usr.bin/perl/t/io/pipe.t b/gnu/usr.bin/perl/t/io/pipe.t
index 95df4dccb65..ac149810ec9 100644
--- a/gnu/usr.bin/perl/t/io/pipe.t
+++ b/gnu/usr.bin/perl/t/io/pipe.t
@@ -2,8 +2,18 @@
# $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..8\n";
+print "1..10\n";
open(PIPE, "|-") || (exec 'tr', 'YX', 'ko');
print PIPE "Xk 1\n";
@@ -54,3 +64,47 @@ print WRITER "not ok 7\n";
close WRITER;
print "ok 8\n";
+
+# VMS doesn't like spawning subprocesses that are still connected to
+# STDOUT. Someone should modify tests #9 and #10 to work with VMS.
+
+if ($^O eq 'VMS') {
+ print "ok 9\n";
+ print "ok 10\n";
+ exit;
+}
+
+if ($Config{d_sfio} || $^O eq machten) {
+ # 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.
+ 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";
+}
diff --git a/gnu/usr.bin/perl/t/io/read.t b/gnu/usr.bin/perl/t/io/read.t
new file mode 100644
index 00000000000..b27fde17c7b
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/io/tell.t b/gnu/usr.bin/perl/t/io/tell.t
index 5badafeacba..83904e88bba 100644
--- a/gnu/usr.bin/perl/t/io/tell.t
+++ b/gnu/usr.bin/perl/t/io/tell.t
@@ -7,7 +7,7 @@ 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>;
diff --git a/gnu/usr.bin/perl/t/lib/abbrev.t b/gnu/usr.bin/perl/t/lib/abbrev.t
new file mode 100644
index 00000000000..fb5a9841eb1
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/anydbm.t b/gnu/usr.bin/perl/t/lib/anydbm.t
index 44bdeabc656..a83da81e1c6 100644
--- a/gnu/usr.bin/perl/t/lib/anydbm.t
+++ b/gnu/usr.bin/perl/t/lib/anydbm.t
@@ -1,6 +1,6 @@
#!./perl
-# $RCSfile: anydbm.t,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:13 $
+# $RCSfile: anydbm.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:00:20 $
BEGIN {
chdir 't' if -d 't';
@@ -15,15 +15,21 @@ 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");
+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*>;
}
-($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");
+if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') {
+ print "ok 2\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++;
}
@@ -80,7 +86,7 @@ delete $h{'goner3'};
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 gt $value) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
$key =~ y/a-z/A-Z/;
$i++ if $key eq $value;
}
@@ -111,4 +117,5 @@ 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;
diff --git a/gnu/usr.bin/perl/t/lib/autoloader.t b/gnu/usr.bin/perl/t/lib/autoloader.t
new file mode 100644
index 00000000000..b1622a8ae2e
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/basename.t b/gnu/usr.bin/perl/t/lib/basename.t
new file mode 100644
index 00000000000..860b3379b43
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/basename.t
@@ -0,0 +1,121 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use File::Basename qw(fileparse basename dirname);
+
+print "1..34\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";
diff --git a/gnu/usr.bin/perl/t/lib/bigintpm.t b/gnu/usr.bin/perl/t/lib/bigintpm.t
index b229d7c67ba..ebaecac21af 100644
--- a/gnu/usr.bin/perl/t/lib/bigintpm.t
+++ b/gnu/usr.bin/perl/t/lib/bigintpm.t
@@ -1,8 +1,11 @@
#!./perl
-BEGIN { unshift @INC, './lib', '../lib';
- require Config; import Config;
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
}
+
+use Config;
use Math::BigInt;
$test = 0;
diff --git a/gnu/usr.bin/perl/t/lib/checktree.t b/gnu/usr.bin/perl/t/lib/checktree.t
new file mode 100644
index 00000000000..b5426ca261e
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/complex.t b/gnu/usr.bin/perl/t/lib/complex.t
new file mode 100644
index 00000000000..2a01859b989
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/complex.t
@@ -0,0 +1,818 @@
+#!./perl
+
+# $RCSfile: complex.t,v $
+#
+# Regression tests for the Math::Complex pacakge
+# -- Raphael Manfredi September 1996
+# -- Jarkko Hietaniemi March-October 1997
+# -- Daniel S. Lewart September-October 1997
+
+$VERSION = '1.05';
+
+# $Id: complex.t,v 1.1 1997/11/30 08:00:23 millert Exp $
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Math::Complex;
+
+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-11;
+
+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);
+ }
+}
+
+# test the divbyzeros
+
+sub test_dbz {
+ for my $op (@_) {
+ $test++;
+
+# push(@script, qq(print "# '$op'\n";));
+ push(@script, qq(eval '$op';));
+ push(@script, qq(print 'not ' unless (\$@ =~ /Division by zero/);));
+ push(@script, qq( print "ok $test\\n";\n));
+ }
+}
+
+# test the logofzeros
+
+sub test_loz {
+ for my $op (@_) {
+ $test++;
+
+# push(@script, qq(print "# '$op'\n";));
+ push(@script, qq(eval '$op';));
+ push(@script, qq(print 'not ' unless (\$@ =~ /Logarithm of zero/);));
+ push(@script, qq( print "ok $test\\n";\n));
+ }
+}
+
+my $minusi = cplx(0, -1);
+
+test_dbz(
+ 'i/0',
+# 'tan(pi/2)', # may succeed thanks to floating point inaccuracies
+# 'sec(pi/2)', # may succeed thanks to floating point inaccuracies
+ 'csc(0)',
+ 'cot(0)',
+ 'atan(i)',
+ 'atan($minusi)',
+ 'asec(0)',
+ 'acsc(0)',
+ 'acot(i)',
+ 'acot($minusi)',
+# 'tanh(pi/2)', # may succeed thanks to floating point inaccuracies
+# 'sech(pi/2)', # may succeed thanks to floating point inaccuracies
+ 'csch(0)',
+ 'coth(0)',
+ 'atanh(1)',
+ 'asech(0)',
+ 'acsch(0)',
+ 'acoth(1)',
+ );
+
+my $zero = cplx(0, 0);
+
+test_loz(
+ 'log($zero)',
+ 'atanh(-1)',
+ 'acoth(-1)',
+ );
+
+# test the 0**0
+
+sub test_ztz {
+ $test++;
+
+# push(@script, qq(print "# 0**0\n";));
+ push(@script, qq(eval 'cplx(0)**cplx(0)';));
+ push(@script, qq(print 'not ' unless (\$@ =~ /zero raised to the/);));
+ push(@script, qq( print "ok $test\\n";\n));
+}
+
+test_ztz;
+
+# test the bad roots
+
+sub test_broot {
+ for my $op (@_) {
+ $test++;
+
+# push(@script, qq(print "# root(2, $op)\n";));
+ push(@script, qq(eval 'root(2, $op)';));
+ push(@script, qq(print 'not ' unless (\$@ =~ /root must be/);));
+ 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*\[(.*),(.*)\]/) {
+ 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/gnu/usr.bin/perl/t/lib/db-btree.t b/gnu/usr.bin/perl/t/lib/db-btree.t
index d90de6cd590..bebb63df8d0 100644
--- a/gnu/usr.bin/perl/t/lib/db-btree.t
+++ b/gnu/usr.bin/perl/t/lib/db-btree.t
@@ -1,7 +1,7 @@
-#!./perl
+#!./perl -w
BEGIN {
- @INC = '../lib';
+ @INC = '../lib' if -d '../lib' ;
require Config; import Config;
if ($Config{'extensions'} !~ /\bDB_File\b/) {
print "1..0\n";
@@ -12,73 +12,99 @@ BEGIN {
use DB_File;
use Fcntl;
-print "1..76\n";
+print "1..102\n";
-$Dfile = "Op.db-btree";
+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
-$dbh = TIEHASH DB_File::BTREEINFO ;
-print (($dbh->{flags} == undef) ? "ok 1\n" : "not ok 1\n") ;
-print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ;
-print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ;
-print (($dbh->{lorder} == undef) ? "ok 4\n" : "not ok 4\n") ;
-print (($dbh->{minkeypage} == undef) ? "ok 5\n" : "not ok 5\n") ;
-print (($dbh->{maxkeypage} == undef) ? "ok 6\n" : "not ok 6\n") ;
-print (($dbh->{compare} == undef) ? "ok 7\n" : "not ok 7\n") ;
-print (($dbh->{prefix} == undef) ? "ok 8\n" : "not ok 8\n") ;
+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 ;
-print ($dbh->{flags} == 3000 ? "ok 9\n" : "not ok 9\n") ;
+ok(9, $dbh->{flags} == 3000) ;
$dbh->{cachesize} = 9000 ;
-print ($dbh->{cachesize} == 9000 ? "ok 10\n" : "not ok 10\n") ;
-#
+ok(10, $dbh->{cachesize} == 9000);
+
$dbh->{psize} = 400 ;
-print (($dbh->{psize} == 400) ? "ok 11\n" : "not ok 11\n") ;
+ok(11, $dbh->{psize} == 400) ;
$dbh->{lorder} = 65 ;
-print (($dbh->{lorder} == 65) ? "ok 12\n" : "not ok 12\n") ;
+ok(12, $dbh->{lorder} == 65) ;
$dbh->{minkeypage} = 123 ;
-print (($dbh->{minkeypage} == 123) ? "ok 13\n" : "not ok 13\n") ;
+ok(13, $dbh->{minkeypage} == 123) ;
$dbh->{maxkeypage} = 1234 ;
-print ($dbh->{maxkeypage} == 1234 ? "ok 14\n" : "not ok 14\n") ;
+ok(14, $dbh->{maxkeypage} == 1234 );
$dbh->{compare} = 1234 ;
-print ($dbh->{compare} == 1234 ? "ok 15\n" : "not ok 15\n") ;
+ok(15, $dbh->{compare} == 1234) ;
$dbh->{prefix} = 1234 ;
-print ($dbh->{prefix} == 1234 ? "ok 16\n" : "not ok 16\n") ;
+ok(16, $dbh->{prefix} == 1234 );
# Check that an invalid entry is caught both for store & fetch
eval '$dbh->{fred} = 1234' ;
-print ($@ eq '' ? "ok 17\n" : "not ok 17\n") ;
+ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
eval '$q = $dbh->{fred}' ;
-print ($@ eq '' ? "ok 18\n" : "not ok 18\n") ;
+ok(18, $@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ) ;
# Now check the interface to BTREE
-print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 19\n" : "not ok 19");
+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);
-print (($mode & 0777) == 0640 ? "ok 20\n" : "not ok 20\n");
+ok(20, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos');
while (($key,$value) = each(%h)) {
$i++;
}
-print (!$i ? "ok 21\n" : "not ok 21\n");
+ok(21, !$i ) ;
$h{'goner1'} = 'snork';
$h{'abc'} = 'ABC';
-print ($h{'abc'} == 'ABC' ? "ok 22\n" : "not ok 22\n") ;
-print (defined $h{'jimmy'} ? "not ok 23\n" : "ok 23\n");
+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";
@@ -110,7 +136,7 @@ untie(%h);
# tie to the same file again
-print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE)) ? "ok 24\n" : "not ok 24\n");
+ok(26, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640, $DB_BTREE)) ;
# Modify an entry from the previous tie
$h{'g'} = 'G';
@@ -141,48 +167,45 @@ $X->DELETE('goner3');
@keys = keys(%h);
@values = values(%h);
-if ($#keys == 29 && $#values == 29) {print "ok 25\n";} else {print "not ok 25\n";}
+ok(27, $#keys == 29 && $#values == 29) ;
+$i = 0 ;
while (($key,$value) = each(%h)) {
- if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
+ 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 26\n";} else {print "not ok 26\n";}
+ok(28, $i == 30) ;
-@keys = ('blurfl', keys(h), 'dyick');
-if ($#keys == 31) {print "ok 27\n";} else {print "not ok 27\n";}
+@keys = ('blurfl', keys(%h), 'dyick');
+ok(29, $#keys == 31) ;
#Check that the keys can be retrieved in order
-$ok = 1 ;
-foreach (keys %h)
-{
- ($ok = 0), last if defined $previous && $previous gt $_ ;
- $previous = $_ ;
-}
-print ($ok ? "ok 28\n" : "not ok 28\n") ;
+my @b = keys %h ;
+my @c = sort lexical @b ;
+ok(30, ArrayCompare(\@b, \@c)) ;
$h{'foo'} = '';
-print ($h{'foo'} eq '' ? "ok 29\n" : "not ok 29\n") ;
+ok(31, $h{'foo'} eq '' ) ;
$h{''} = 'bar';
-print ($h{''} eq 'bar' ? "ok 30\n" : "not ok 30\n") ;
+ok(32, $h{''} eq '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 31\n" : "not ok 31\n");
+ok(33, $ok);
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($Dfile);
-print ($size > 0 ? "ok 32\n" : "not ok 32\n");
+ok(34, $size > 0 );
@h{0..200} = 200..400;
@foo = @h{0..200};
-print join(':',200..400) eq join(':',@foo) ? "ok 33\n" : "not ok 33\n";
+ok(35, join(':',200..400) eq join(':',@foo) );
# Now check all the non-tie specific stuff
@@ -191,52 +214,53 @@ print join(':',200..400) eq join(':',@foo) ? "ok 33\n" : "not ok 33\n";
# an existing record.
$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
-print ($status == 1 ? "ok 34\n" : "not ok 34\n") ;
+ok(36, $status == 1 );
# check that the value of the key 'x' has not been changed by the
# previous test
-print ($h{'x'} eq 'X' ? "ok 35\n" : "not ok 35\n") ;
+ok(37, $h{'x'} eq 'X' );
# standard put
$status = $X->put('key', 'value') ;
-print ($status == 0 ? "ok 36\n" : "not ok 36\n") ;
+ok(38, $status == 0 );
#check that previous put can be retrieved
+$value = 0 ;
$status = $X->get('key', $value) ;
-print ($status == 0 ? "ok 37\n" : "not ok 37\n") ;
-print ($value eq 'value' ? "ok 38\n" : "not ok 38\n") ;
+ok(39, $status == 0 );
+ok(40, $value eq 'value' );
# Attempting to delete an existing key should work
$status = $X->del('q') ;
-print ($status == 0 ? "ok 39\n" : "not ok 39\n") ;
+ok(41, $status == 0 );
$status = $X->del('') ;
-print ($status == 0 ? "ok 40\n" : "not ok 40\n") ;
+ok(42, $status == 0 );
# Make sure that the key deleted, cannot be retrieved
-print (($h{'q'} eq undef) ? "ok 41\n" : "not ok 41\n") ;
-print (($h{''} eq undef) ? "ok 42\n" : "not ok 42\n") ;
+ok(43, ! defined $h{'q'}) ;
+ok(44, ! defined $h{''}) ;
undef $X ;
untie %h ;
-print (($X = tie(%h, DB_File,$Dfile, O_RDWR, 0640, $DB_BTREE )) ? "ok 43\n" : "not ok 43");
+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') ;
-print ($status == 1 ? "ok 44\n" : "not ok 44\n") ;
+ok(46, $status == 1 );
# Check the get interface
# First a non-existing key
$status = $X->get('aaaa', $value) ;
-print ($status == 1 ? "ok 45\n" : "not ok 45\n") ;
+ok(47, $status == 1 );
# Next an existing key
$status = $X->get('a', $value) ;
-print ($status == 0 ? "ok 46\n" : "not ok 46\n") ;
-print ($value eq 'A' ? "ok 47\n" : "not ok 47\n") ;
+ok(48, $status == 0 );
+ok(49, $value eq 'A' );
# seq
# ###
@@ -245,15 +269,15 @@ print ($value eq 'A' ? "ok 47\n" : "not ok 47\n") ;
$key = 'ke' ;
$value = '' ;
$status = $X->seq($key, $value, R_CURSOR) ;
-print ($status == 0 ? "ok 48\n" : "not ok 48\n") ;
-print ($key eq 'key' ? "ok 49\n" : "not ok 49\n") ;
-print ($value eq 'value' ? "ok 50\n" : "not ok 50\n") ;
+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) ;
-print ($status == 1 ? "ok 51\n" : "not ok 51\n") ;
+ok(53, $status == 1 );
# use seq to set the cursor, then delete the record @ the cursor.
@@ -261,35 +285,35 @@ print ($status == 1 ? "ok 51\n" : "not ok 51\n") ;
$key = 'x' ;
$value = '' ;
$status = $X->seq($key, $value, R_CURSOR) ;
-print ($status == 0 ? "ok 52\n" : "not ok 52\n") ;
-print ($key eq 'x' ? "ok 53\n" : "not ok 53\n") ;
-print ($value eq 'X' ? "ok 54\n" : "not ok 54\n") ;
+ok(54, $status == 0 );
+ok(55, $key eq 'x' );
+ok(56, $value eq 'X' );
$status = $X->del(0, R_CURSOR) ;
-print ($status == 0 ? "ok 55\n" : "not ok 55\n") ;
+ok(57, $status == 0 );
$status = $X->get('x', $value) ;
-print ($status == 1 ? "ok 56\n" : "not ok 56\n") ;
+ok(58, $status == 1 );
# ditto, but use put to replace the key/value pair.
$key = 'y' ;
$value = '' ;
$status = $X->seq($key, $value, R_CURSOR) ;
-print ($status == 0 ? "ok 57\n" : "not ok 57\n") ;
-print ($key eq 'y' ? "ok 58\n" : "not ok 58\n") ;
-print ($value eq 'Y' ? "ok 59\n" : "not ok 59\n") ;
+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) ;
-print ($status == 0 ? "ok 60\n" : "not ok 60\n") ;
-print ($key eq 'replace key' ? "ok 61\n" : "not ok 61\n") ;
-print ($value eq 'replace value' ? "ok 62\n" : "not ok 62\n") ;
+ok(62, $status == 0 );
+ok(63, $key eq 'replace key' );
+ok(64, $value eq 'replace value' );
$status = $X->get('y', $value) ;
-print ($status == 1 ? "ok 63\n" : "not ok 63\n") ;
+ok(65, $status == 1 );
# use seq to walk forwards through a file
$status = $X->seq($key, $value, R_FIRST) ;
-print ($status == 0 ? "ok 64\n" : "not ok 64\n") ;
+ok(66, $status == 0 );
$previous = $key ;
$ok = 1 ;
@@ -298,12 +322,12 @@ while (($status = $X->seq($key, $value, R_NEXT)) == 0)
($ok = 0), last if ($previous cmp $key) == 1 ;
}
-print ($status == 1 ? "ok 65\n" : "not ok 65\n") ;
-print ($ok == 1 ? "ok 66\n" : "not ok 66\n") ;
+ok(67, $status == 1 );
+ok(68, $ok == 1 );
# use seq to walk backwards through a file
$status = $X->seq($key, $value, R_LAST) ;
-print ($status == 0 ? "ok 67\n" : "not ok 67\n") ;
+ok(69, $status == 0 );
$previous = $key ;
$ok = 1 ;
@@ -313,8 +337,8 @@ while (($status = $X->seq($key, $value, R_PREV)) == 0)
#print "key = [$key] value = [$value]\n" ;
}
-print ($status == 1 ? "ok 68\n" : "not ok 68\n") ;
-print ($ok == 1 ? "ok 69\n" : "not ok 69\n") ;
+ok(70, $status == 1 );
+ok(71, $ok == 1 );
# check seq FIRST/LAST
@@ -323,14 +347,14 @@ print ($ok == 1 ? "ok 69\n" : "not ok 69\n") ;
# ####
$status = $X->sync ;
-print ($status == 0 ? "ok 70\n" : "not ok 70\n") ;
+ok(72, $status == 0 );
# fd
# ##
$status = $X->fd ;
-print ($status != 0 ? "ok 71\n" : "not ok 71\n") ;
+ok(73, $status != 0 );
undef $X ;
@@ -339,41 +363,92 @@ untie %h ;
unlink $Dfile;
# Now try an in memory file
-print (($Y = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 72\n" : "not ok 72");
+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 ;
-print ($status == -1 ? "ok 73\n" : "not ok 73\n") ;
+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 = TIEHASH DB_File::BTREEINFO ;
-$dbh1->{compare} = sub { $_[0] <=> $_[1] } ;
+$dbh1 = new DB_File::BTREEINFO ;
+{ local $^W = 0 ;
+ $dbh1->{compare} = sub { $_[0] <=> $_[1] } ; }
-$dbh2 = TIEHASH DB_File::BTREEINFO ;
+$dbh2 = new DB_File::BTREEINFO ;
$dbh2->{compare} = sub { $_[0] cmp $_[1] } ;
-$dbh3 = TIEHASH DB_File::BTREEINFO ;
+$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 ) ;
+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 ) ;
-@srt_1 = sort { $a <=> $b } @Keys ;
+{ 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) {
- $h{$_} = 1 ;
+ { local $^W = 0 ;
+ $h{$_} = 1 ; }
$g{$_} = 1 ;
$k{$_} = 1 ;
}
@@ -392,13 +467,142 @@ sub ArrayCompare
1 ;
}
-print ( ArrayCompare (\@srt_1, [keys %h]) ? "ok 74\n" : "not ok 74\n") ;
-print ( ArrayCompare (\@srt_2, [keys %g]) ? "ok 75\n" : "not ok 75\n") ;
-print ( ArrayCompare (\@srt_3, [keys %k]) ? "ok 76\n" : "not ok 76\n") ;
+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]]") ;
+
+ unlink "SubDB.pm", "dbbtree.tmp" ;
+
+}
+
exit ;
diff --git a/gnu/usr.bin/perl/t/lib/db-hash.t b/gnu/usr.bin/perl/t/lib/db-hash.t
index 6c3ef552001..9df918cce5a 100644
--- a/gnu/usr.bin/perl/t/lib/db-hash.t
+++ b/gnu/usr.bin/perl/t/lib/db-hash.t
@@ -1,7 +1,7 @@
-#!./perl
+#!./perl -w
BEGIN {
- @INC = '../lib';
+ @INC = '../lib' if -d '../lib' ;
require Config; import Config;
if ($Config{'extensions'} !~ /\bDB_File\b/) {
print "1..0\n";
@@ -12,65 +12,78 @@ BEGIN {
use DB_File;
use Fcntl;
-print "1..43\n";
+print "1..62\n";
-$Dfile = "Op.db-hash";
+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
-$dbh = TIEHASH DB_File::HASHINFO ;
-print (($dbh->{bsize} == undef) ? "ok 1\n" : "not ok 1\n") ;
-print (($dbh->{ffactor} == undef) ? "ok 2\n" : "not ok 2\n") ;
-print (($dbh->{nelem} == undef) ? "ok 3\n" : "not ok 3\n") ;
-print (($dbh->{cachesize} == undef) ? "ok 4\n" : "not ok 4\n") ;
-print (($dbh->{hash} == undef) ? "ok 5\n" : "not ok 5\n") ;
-print (($dbh->{lorder} == undef) ? "ok 6\n" : "not ok 6\n") ;
+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 ;
-print ($dbh->{bsize} == 3000 ? "ok 7\n" : "not ok 7\n") ;
+ok(7, $dbh->{bsize} == 3000 );
$dbh->{ffactor} = 9000 ;
-print ($dbh->{ffactor} == 9000 ? "ok 8\n" : "not ok 8\n") ;
-#
+ok(8, $dbh->{ffactor} == 9000 );
+
$dbh->{nelem} = 400 ;
-print (($dbh->{nelem} == 400) ? "ok 9\n" : "not ok 9\n") ;
+ok(9, $dbh->{nelem} == 400 );
$dbh->{cachesize} = 65 ;
-print (($dbh->{cachesize} == 65) ? "ok 10\n" : "not ok 10\n") ;
+ok(10, $dbh->{cachesize} == 65 );
$dbh->{hash} = "abc" ;
-print (($dbh->{hash} eq "abc") ? "ok 11\n" : "not ok 11\n") ;
+ok(11, $dbh->{hash} eq "abc" );
$dbh->{lorder} = 1234 ;
-print ($dbh->{lorder} == 1234 ? "ok 12\n" : "not ok 12\n") ;
+ok(12, $dbh->{lorder} == 1234 );
# Check that an invalid entry is caught both for store & fetch
eval '$dbh->{fred} = 1234' ;
-print ($@ eq '' ? "ok 13\n" : "not ok 13\n") ;
-eval '$q = $dbh->{fred}' ;
-print ($@ eq '' ? "ok 14\n" : "not ok 14\n") ;
+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
-print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_HASH )) ? "ok 15\n" : "not ok 15");
+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);
-print (($mode & 0777) == 0640 ? "ok 16\n" : "not ok 16\n");
+ok(16, ($mode & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640) || $^O eq 'amigaos');
while (($key,$value) = each(%h)) {
$i++;
}
-print (!$i ? "ok 17\n" : "not ok 17\n");
+ok(17, !$i );
$h{'goner1'} = 'snork';
$h{'abc'} = 'ABC';
-print ($h{'abc'} == 'ABC' ? "ok 18\n" : "not ok 18\n") ;
-print (defined $h{'jimmy'} ? "not ok 19\n" : "ok 19\n");
+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";
@@ -102,7 +115,7 @@ untie(%h);
# tie to the same file again, do not supply a type - should default to HASH
-print (($X = tie(%h,DB_File,$Dfile, O_RDWR, 0640)) ? "ok 20\n" : "not ok 20: $!\n");
+ok(22, $X = tie(%h,'DB_File',$Dfile, O_RDWR, 0640) );
# Modify an entry from the previous tie
$h{'g'} = 'G';
@@ -133,39 +146,40 @@ $X->DELETE('goner3');
@keys = keys(%h);
@values = values(%h);
-if ($#keys == 29 && $#values == 29) {print "ok 21\n";} else {print "not ok 21\n";}
+ok(23, $#keys == 29 && $#values == 29) ;
-while (($key,$value) = each(h)) {
- if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
+$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;
}
}
-if ($i == 30) {print "ok 22\n";} else {print "not ok 22\n";}
+ok(24, $i == 30) ;
-@keys = ('blurfl', keys(h), 'dyick');
-if ($#keys == 31) {print "ok 23\n";} else {print "not ok 23\n";}
+@keys = ('blurfl', keys(%h), 'dyick');
+ok(25, $#keys == 31) ;
$h{'foo'} = '';
-print ($h{'foo'} eq '' ? "ok 24\n" : "not ok 24\n") ;
+ok(26, $h{'foo'} eq '' );
$h{''} = 'bar';
-print ($h{''} eq 'bar' ? "ok 25\n" : "not ok 25\n") ;
+ok(27, $h{''} eq '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 26\n" : "not ok 26\n");
+ok(28, $ok );
($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
$blksize,$blocks) = stat($Dfile);
-print ($size > 0 ? "ok 27\n" : "not ok 27\n");
+ok(29, $size > 0 );
@h{0..200} = 200..400;
@foo = @h{0..200};
-print join(':',200..400) eq join(':',@foo) ? "ok 28\n" : "not ok 28\n";
+ok(30, join(':',200..400) eq join(':',@foo) );
# Now check all the non-tie specific stuff
@@ -174,44 +188,47 @@ print join(':',200..400) eq join(':',@foo) ? "ok 28\n" : "not ok 28\n";
# an existing record.
$status = $X->put( 'x', 'newvalue', R_NOOVERWRITE) ;
-print ($status == 1 ? "ok 29\n" : "not ok 29\n") ;
+ok(31, $status == 1 );
# check that the value of the key 'x' has not been changed by the
# previous test
-print ($h{'x'} eq 'X' ? "ok 30\n" : "not ok 30\n") ;
+ok(32, $h{'x'} eq 'X' );
# standard put
$status = $X->put('key', 'value') ;
-print ($status == 0 ? "ok 31\n" : "not ok 31\n") ;
+ok(33, $status == 0 );
#check that previous put can be retrieved
+$value = 0 ;
$status = $X->get('key', $value) ;
-print ($status == 0 ? "ok 32\n" : "not ok 32\n") ;
-print ($value eq 'value' ? "ok 33\n" : "not ok 33\n") ;
+ok(34, $status == 0 );
+ok(35, $value eq 'value' );
# Attempting to delete an existing key should work
$status = $X->del('q') ;
-print ($status == 0 ? "ok 34\n" : "not ok 34\n") ;
+ok(36, $status == 0 );
# Make sure that the key deleted, cannot be retrieved
-print (($h{'q'} eq undef) ? "ok 35\n" : "not ok 35\n") ;
+$^W = 0 ;
+ok(37, $h{'q'} eq undef );
+$^W = 1 ;
# Attempting to delete a non-existant key should fail
$status = $X->del('joe') ;
-print ($status == 1 ? "ok 36\n" : "not ok 36\n") ;
+ok(38, $status == 1 );
# Check the get interface
# First a non-existing key
$status = $X->get('aaaa', $value) ;
-print ($status == 1 ? "ok 37\n" : "not ok 37\n") ;
+ok(39, $status == 1 );
# Next an existing key
$status = $X->get('a', $value) ;
-print ($status == 0 ? "ok 38\n" : "not ok 38\n") ;
-print ($value eq 'A' ? "ok 39\n" : "not ok 39\n") ;
+ok(40, $status == 0 );
+ok(41, $value eq 'A' );
# seq
# ###
@@ -226,28 +243,172 @@ print ($value eq 'A' ? "ok 39\n" : "not ok 39\n") ;
# ####
$status = $X->sync ;
-print ($status == 0 ? "ok 40\n" : "not ok 40\n") ;
+ok(42, $status == 0 );
# fd
# ##
$status = $X->fd ;
-print ($status != 0 ? "ok 41\n" : "not ok 41\n") ;
+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
-print (($X = tie(%h, DB_File,undef, O_RDWR|O_CREAT, 0640, $DB_HASH )) ? "ok 42\n" : "not ok 42");
+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 ;
-print ($status == -1 ? "ok 43\n" : "not ok 43\n") ;
+ok(48, $status == -1 );
-untie %h ;
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]]") ;
+
+ unlink "SubDB.pm", "dbhash.tmp" ;
+
+}
exit ;
diff --git a/gnu/usr.bin/perl/t/lib/db-recno.t b/gnu/usr.bin/perl/t/lib/db-recno.t
index 64ad7b8a9ef..9950741ffea 100644
--- a/gnu/usr.bin/perl/t/lib/db-recno.t
+++ b/gnu/usr.bin/perl/t/lib/db-recno.t
@@ -1,7 +1,7 @@
-#!./perl
+#!./perl -w
BEGIN {
- @INC = '../lib';
+ @INC = '../lib' if -d '../lib' ;
require Config; import Config;
if ($Config{'extensions'} !~ /\bDB_File\b/) {
print "1..0\n";
@@ -11,126 +11,185 @@ BEGIN {
use DB_File;
use Fcntl;
+use strict ;
+use vars qw($dbh $Dfile $bad_ones) ;
-print "1..30\n";
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
-$Dfile = "Op.db-recno";
-unlink $Dfile;
+ 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..66\n";
+
+my $Dfile = "recno.tmp";
+unlink $Dfile ;
umask(0);
# Check the interface to RECNOINFO
-$dbh = TIEHASH DB_File::RECNOINFO ;
-print (($dbh->{bval} == undef) ? "ok 1\n" : "not ok 1\n") ;
-print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ;
-print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ;
-print (($dbh->{flags} == undef) ? "ok 4\n" : "not ok 4\n") ;
-print (($dbh->{lorder} == undef) ? "ok 5\n" : "not ok 5\n") ;
-print (($dbh->{reclen} == undef) ? "ok 6\n" : "not ok 6\n") ;
-print (($dbh->{bfname} == undef) ? "ok 7\n" : "not ok 7\n") ;
+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 ;
-print ($dbh->{bval} == 3000 ? "ok 8\n" : "not ok 8\n") ;
+ok(8, $dbh->{bval} == 3000 );
$dbh->{cachesize} = 9000 ;
-print ($dbh->{cachesize} == 9000 ? "ok 9\n" : "not ok 9\n") ;
+ok(9, $dbh->{cachesize} == 9000 );
$dbh->{psize} = 400 ;
-print (($dbh->{psize} == 400) ? "ok 10\n" : "not ok 10\n") ;
+ok(10, $dbh->{psize} == 400 );
$dbh->{flags} = 65 ;
-print (($dbh->{flags} == 65) ? "ok 11\n" : "not ok 11\n") ;
+ok(11, $dbh->{flags} == 65 );
$dbh->{lorder} = 123 ;
-print (($dbh->{lorder} == 123) ? "ok 12\n" : "not ok 12\n") ;
+ok(12, $dbh->{lorder} == 123 );
$dbh->{reclen} = 1234 ;
-print ($dbh->{reclen} == 1234 ? "ok 13\n" : "not ok 13\n") ;
+ok(13, $dbh->{reclen} == 1234 );
$dbh->{bfname} = 1234 ;
-print ($dbh->{bfname} == 1234 ? "ok 14\n" : "not ok 14\n") ;
+ok(14, $dbh->{bfname} == 1234 );
# Check that an invalid entry is caught both for store & fetch
eval '$dbh->{fred} = 1234' ;
-print ($@ eq '' ? "ok 15\n" : "not ok 15\n") ;
-eval '$q = $dbh->{fred}' ;
-print ($@ eq '' ? "ok 16\n" : "not ok 16\n") ;
+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
-print (($X = tie(@h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO )) ? "ok 17\n" : "not ok 17");
+my $X ;
+my @h ;
+ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
-($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
- $blksize,$blocks) = stat($Dfile);
-print (($mode & 0777) == 0640 ? "ok 18\n" : "not ok 18\n");
+ok(18, ((stat($Dfile))[2] & 0777) == (($^O eq 'os2' || $^O eq 'MSWin32') ? 0666 : 0640)
+ || $^O eq 'amigaos') ;
-#$l = @h ;
-$l = $X->length ;
-print (!$l ? "ok 19\n" : "not ok 19\n");
+#my $l = @h ;
+my $l = $X->length ;
+ok(19, !$l );
-@data = qw( a b c d ever f g h i j k longername m n o p) ;
+my @data = qw( a b c d ever f g h i j k longername m n o p) ;
$h[0] = shift @data ;
-print ($h[0] eq 'a' ? "ok 20\n" : "not ok 20\n") ;
+ok(20, $h[0] eq 'a' );
+my $ i;
foreach (@data)
{ $h[++$i] = $_ }
unshift (@data, 'a') ;
-print (defined $h[1] ? "ok 21\n" : "not ok 21\n");
-print (! defined $h[16] ? "ok 22\n" : "not ok 22\n");
-print ($X->length == @data ? "ok 23\n" : "not ok 23\n") ;
+ok(21, defined $h[1] );
+ok(22, ! defined $h[16] );
+ok(23, $X->length == @data );
# Overwrite an entry & check fetch it
$h[3] = 'replaced' ;
$data[3] = 'replaced' ;
-print ($h[3] eq 'replaced' ? "ok 24\n" : "not ok 24\n");
+ok(24, $h[3] eq 'replaced' );
#PUSH
-@push_data = qw(added to the end) ;
-#push (@h, @push_data) ;
+my @push_data = qw(added to the end) ;
+#my push (@h, @push_data) ;
$X->push(@push_data) ;
push (@data, @push_data) ;
-print ($h[++$i] eq 'added' ? "ok 25\n" : "not ok 25\n");
+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
-pop (@data) ;
-#$value = pop(@h) ;
-$value = $X->pop ;
-print ($value eq 'end' ? "not ok 26\n" : "ok 26\n");
+my $popped = pop (@data) ;
+#my $value = pop(@h) ;
+my $value = $X->pop ;
+ok(29, $value eq $popped) ;
# SHIFT
#$value = shift @h
$value = $X->shift ;
-print ($value eq shift @data ? "not ok 27\n" : "ok 27\n");
+my $shifted = shift @data ;
+ok(30, $value eq $shifted );
# UNSHIFT
# empty list
$X->unshift ;
-print ($X->length == @data ? "ok 28\n" : "not ok 28\n") ;
+ok(31, $X->length == @data );
-@new_data = qw(add this to the start of the array) ;
+my @new_data = qw(add this to the start of the array) ;
#unshift @h, @new_data ;
$X->unshift (@new_data) ;
unshift (@data, @new_data) ;
-print ($X->length == @data ? "ok 29\n" : "not ok 29\n") ;
+ok(32, $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
-$ok = 1 ;
-$j = 0 ;
+my $ok = 1 ;
+my $j = 0 ;
foreach (@data)
{
$ok = 0, last if $_ ne $h[$j ++] ;
}
-print ($ok ? "ok 30\n" : "not ok 30\n") ;
+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[$X->length -1] );
+
+# get the first element using a negative subscript
+eval '$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 + $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.
@@ -139,4 +198,188 @@ 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]]") ;
+
+ unlink "SubDB.pm", "recno.tmp" ;
+
+}
+
exit ;
diff --git a/gnu/usr.bin/perl/t/lib/dirhand.t b/gnu/usr.bin/perl/t/lib/dirhand.t
index 8403609578e..aa7be356df3 100644
--- a/gnu/usr.bin/perl/t/lib/dirhand.t
+++ b/gnu/usr.bin/perl/t/lib/dirhand.t
@@ -4,7 +4,7 @@ BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
- if ($Config{'extensions'} !~ /\bPOSIX\b/) {
+ if (not $Config{'d_readdir'}) {
print "1..0\n";
exit 0;
}
@@ -17,7 +17,7 @@ print "1..5\n";
$dot = new DirHandle ".";
print defined($dot) ? "ok" : "not ok", " 1\n";
-@a = <*>;
+@a = sort <*>;
do { $first = $dot->read } while defined($first) && $first =~ /^\./;
print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n";
diff --git a/gnu/usr.bin/perl/t/lib/dosglob.t b/gnu/usr.bin/perl/t/lib/dosglob.t
new file mode 100644
index 00000000000..7398a140652
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/dosglob.t
@@ -0,0 +1,94 @@
+#!./perl
+
+#
+# test glob() in File::DosGlob
+#
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..9\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";
+
diff --git a/gnu/usr.bin/perl/t/lib/env.t b/gnu/usr.bin/perl/t/lib/env.t
new file mode 100644
index 00000000000..5a8220778aa
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/filecache.t b/gnu/usr.bin/perl/t/lib/filecache.t
new file mode 100644
index 00000000000..a97fdd532c6
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/filecopy.t b/gnu/usr.bin/perl/t/lib/filecopy.t
new file mode 100644
index 00000000000..b718215a1e4
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/filecopy.t
@@ -0,0 +1,88 @@
+#!./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;
+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";
+
+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/gnu/usr.bin/perl/t/lib/filefind.t b/gnu/usr.bin/perl/t/lib/filefind.t
new file mode 100644
index 00000000000..21e29a2d7fb
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/filefind.t
@@ -0,0 +1,13 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..1\n";
+
+use File::Find;
+
+# hope we will eventually find ourself
+find(sub { print "ok 1\n" if $_ eq 'filefind.t'; }, ".");
diff --git a/gnu/usr.bin/perl/t/lib/filehand.t b/gnu/usr.bin/perl/t/lib/filehand.t
index fc433502126..cedc2ebcb82 100644
--- a/gnu/usr.bin/perl/t/lib/filehand.t
+++ b/gnu/usr.bin/perl/t/lib/filehand.t
@@ -4,7 +4,7 @@ BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
- if ($Config{'extensions'} !~ /\bFileHandle\b/ && $^O ne 'VMS') {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
print "1..0\n";
exit 0;
}
@@ -13,23 +13,72 @@ BEGIN {
use FileHandle;
use strict subs;
+autoflush STDOUT 1;
+
$mystdout = new_from_fd FileHandle 1,"w";
-autoflush STDOUT;
+$| = 1;
autoflush $mystdout;
-print "1..4\n";
+print "1..11\n";
print $mystdout "ok ",fileno($mystdout),"\n";
-$fh = new FileHandle "TEST", O_RDONLY and print "ok 2\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";
-if ($^O eq 'VMS') {
- ungetc $fh 65;
- CORE::read($fh, $buf,1);
+
+ungetc $fh 65;
+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";
+
+($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 {
- ungetc STDIN 65;
- CORE::read(STDIN, $buf,1);
+ if (fork) {
+ $wr->close;
+ print $rd->getline;
+ }
+ else {
+ $rd->close;
+ $wr->printf("ok %d\n",11);
+ exit(0);
+ }
}
-print $buf eq 'A' ? "ok 4\n" : "not ok 4\n";
diff --git a/gnu/usr.bin/perl/t/lib/filepath.t b/gnu/usr.bin/perl/t/lib/filepath.t
new file mode 100644
index 00000000000..c3bf4a44799
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/findbin.t b/gnu/usr.bin/perl/t/lib/findbin.t
new file mode 100644
index 00000000000..3e742f9a4f7
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/gdbm.t b/gnu/usr.bin/perl/t/lib/gdbm.t
index e79df424657..53b0351ed3a 100644
--- a/gnu/usr.bin/perl/t/lib/gdbm.t
+++ b/gnu/usr.bin/perl/t/lib/gdbm.t
@@ -1,6 +1,6 @@
#!./perl
-# $RCSfile: gdbm.t,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:15 $
+# $RCSfile: gdbm.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:00:31 $
BEGIN {
@INC = '../lib';
@@ -13,7 +13,7 @@ BEGIN {
use GDBM_File;
-print "1..12\n";
+print "1..20\n";
unlink <Op.dbmx*>;
@@ -24,9 +24,14 @@ $Dfile = "Op.dbmx.pag";
if (! -e $Dfile) {
($Dfile) = <Op.dbmx*>;
}
-($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");
+if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') {
+ print "ok 2\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++;
}
@@ -83,7 +88,7 @@ delete $h{'goner3'};
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 gt $value) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
$key =~ y/a-z/A-Z/;
$i++ if $key eq $value;
}
@@ -114,4 +119,88 @@ 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]]") ;
+
+ unlink "SubDB.pm", <dbhash.tmp*> ;
+
+}
diff --git a/gnu/usr.bin/perl/t/lib/getopt.t b/gnu/usr.bin/perl/t/lib/getopt.t
new file mode 100644
index 00000000000..fb70f10aae8
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/hostname.t b/gnu/usr.bin/perl/t/lib/hostname.t
new file mode 100644
index 00000000000..e4ac36521c7
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/io_dup.t b/gnu/usr.bin/perl/t/lib/io_dup.t
new file mode 100644
index 00000000000..6b0caf14fad
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/io_pipe.t b/gnu/usr.bin/perl/t/lib/io_pipe.t
new file mode 100644
index 00000000000..eee374149ca
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/io_pipe.t
@@ -0,0 +1,109 @@
+#!./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";
+
+$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;
+
+
+print "ok 10\n";
+
diff --git a/gnu/usr.bin/perl/t/lib/io_sel.t b/gnu/usr.bin/perl/t/lib/io_sel.t
new file mode 100644
index 00000000000..b9c10974040
--- /dev/null
+++ b/gnu/usr.bin/perl/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') { # 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/gnu/usr.bin/perl/t/lib/io_sock.t b/gnu/usr.bin/perl/t/lib/io_sock.t
new file mode 100644
index 00000000000..0971e7803f0
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/io_sock.t
@@ -0,0 +1,81 @@
+#!./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";
+
+$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.)
+
+ $sock = IO::Socket::INET->new(PeerPort => $port,
+ Proto => 'tcp',
+ PeerAddr => 'localhost'
+ ) or die "$!";
+
+ $sock->autoflush(1);
+
+ print $sock "ok 3\n";
+
+ print $sock->getline();
+
+ $sock->close;
+
+ exit;
+} else {
+ die;
+}
+
+
+
+
+
+
diff --git a/gnu/usr.bin/perl/t/lib/io_taint.t b/gnu/usr.bin/perl/t/lib/io_taint.t
new file mode 100644
index 00000000000..0ef2cfd63f5
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/io_tell.t b/gnu/usr.bin/perl/t/lib/io_tell.t
new file mode 100644
index 00000000000..d8ebae24fd0
--- /dev/null
+++ b/gnu/usr.bin/perl/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';
+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/gnu/usr.bin/perl/t/lib/io_udp.t b/gnu/usr.bin/perl/t/lib/io_udp.t
new file mode 100644
index 00000000000..3e167141182
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/io_udp.t
@@ -0,0 +1,44 @@
+#!./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.)
+
+$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost');
+$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost');
+
+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/gnu/usr.bin/perl/t/lib/io_xs.t b/gnu/usr.bin/perl/t/lib/io_xs.t
new file mode 100644
index 00000000000..1a6fd381a30
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/ndbm.t b/gnu/usr.bin/perl/t/lib/ndbm.t
index 77f331ca441..e9f88bcef51 100644
--- a/gnu/usr.bin/perl/t/lib/ndbm.t
+++ b/gnu/usr.bin/perl/t/lib/ndbm.t
@@ -1,6 +1,6 @@
#!./perl
-# $RCSfile: ndbm.t,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:15 $
+# $RCSfile: ndbm.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:04:58 $
BEGIN {
chdir 't' if -d 't';
@@ -16,7 +16,7 @@ require NDBM_File;
#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
use Fcntl;
-print "1..12\n";
+print "1..18\n";
unlink <Op.dbmx*>;
@@ -27,9 +27,14 @@ $Dfile = "Op.dbmx.pag";
if (! -e $Dfile) {
($Dfile) = <Op.dbmx*>;
}
-($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");
+if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') {
+ print "ok 2\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++;
}
@@ -86,7 +91,7 @@ delete $h{'goner3'};
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 gt $value) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
$key =~ y/a-z/A-Z/;
$i++ if $key eq $value;
}
@@ -117,4 +122,84 @@ 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]]") ;
+
+ unlink "SubDB.pm", <dbhash.tmp*> ;
+
+}
diff --git a/gnu/usr.bin/perl/t/lib/odbm.t b/gnu/usr.bin/perl/t/lib/odbm.t
index 1c5b4ac4612..da2f885bc7b 100644
--- a/gnu/usr.bin/perl/t/lib/odbm.t
+++ b/gnu/usr.bin/perl/t/lib/odbm.t
@@ -1,6 +1,6 @@
#!./perl
-# $RCSfile: odbm.t,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:15 $
+# $RCSfile: odbm.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:04:59 $
BEGIN {
chdir 't' if -d 't';
@@ -16,7 +16,7 @@ require ODBM_File;
#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
use Fcntl;
-print "1..12\n";
+print "1..18\n";
unlink <Op.dbmx*>;
@@ -27,9 +27,14 @@ $Dfile = "Op.dbmx.pag";
if (! -e $Dfile) {
($Dfile) = <Op.dbmx*>;
}
-($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");
+if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') {
+ print "ok 2\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++;
}
@@ -86,7 +91,7 @@ delete $h{'goner3'};
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 gt $value) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
$key =~ y/a-z/A-Z/;
$i++ if $key eq $value;
}
@@ -117,4 +122,84 @@ 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]]") ;
+
+ unlink "SubDB.pm", <dbhash.tmp*> ;
+
+}
diff --git a/gnu/usr.bin/perl/t/lib/opcode.t b/gnu/usr.bin/perl/t/lib/opcode.t
new file mode 100644
index 00000000000..a785fce48b6
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/open2.t b/gnu/usr.bin/perl/t/lib/open2.t
new file mode 100644
index 00000000000..a2e6a07a7b0
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/open2.t
@@ -0,0 +1,46 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ unless ($Config{'d_fork'}) {
+ 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;
+ }
+}
+
+my ($pid, $reaped_pid);
+STDOUT->autoflush;
+STDERR->autoflush;
+
+print "1..7\n";
+
+ok 1, $pid = open2 'READ', 'WRITE', $perl, '-e', 'print scalar <STDIN>';
+ok 2, print WRITE "hi kid\n";
+ok 3, <READ> eq "hi kid\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/gnu/usr.bin/perl/t/lib/open3.t b/gnu/usr.bin/perl/t/lib/open3.t
new file mode 100644
index 00000000000..4258eec4018
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/open3.t
@@ -0,0 +1,121 @@
+#!./perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ unless ($Config{'d_fork'}) {
+ 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;
+ }
+}
+
+my ($pid, $reaped_pid);
+STDOUT->autoflush;
+STDERR->autoflush;
+
+print "1..21\n";
+
+# basic
+ok 1, $pid = open3 'WRITE', 'READ', 'ERROR', $perl, '-e', <<'EOF';
+ $| = 1;
+ print scalar <STDIN>;
+ print STDERR "hi error\n";
+EOF
+ok 2, print WRITE "hi kid\n";
+ok 3, <READ> eq "hi kid\n";
+ok 4, <ERROR> eq "hi error\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', <<'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', <<'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', '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', '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', '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', <<'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', <<'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/gnu/usr.bin/perl/t/lib/ops.t b/gnu/usr.bin/perl/t/lib/ops.t
new file mode 100644
index 00000000000..56b1bacabb0
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/parsewords.t b/gnu/usr.bin/perl/t/lib/parsewords.t
new file mode 100644
index 00000000000..47a75881dc7
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/parsewords.t
@@ -0,0 +1,28 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..4\n";
+
+use Text::ParseWords;
+
+@words = shellwords(qq(foo "bar quiz" zoo));
+#print join(";", @words), "\n";
+
+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";
+
+# Test quotewords() with other parameters
+@words = quotewords(":+", 1, qq(foo:::"bar:foo":zoo zoo:));
+#print join(";", @words), "\n";
+print "not " unless join(";", @words) eq qq(foo;"bar:foo";zoo zoo);
+print "ok 4\n";
diff --git a/gnu/usr.bin/perl/t/lib/posix.t b/gnu/usr.bin/perl/t/lib/posix.t
index 23007ff0595..6ae88c0dd20 100644
--- a/gnu/usr.bin/perl/t/lib/posix.t
+++ b/gnu/usr.bin/perl/t/lib/posix.t
@@ -14,7 +14,7 @@ use POSIX qw(fcntl_h signal_h limits_h _exit getcwd open read write);
use strict subs;
$| = 1;
-print "1..14\n";
+print "1..17\n";
$testfd = open("TEST", O_RDONLY, 0) and print "ok 1\n";
read($testfd, $buffer, 9) if $testfd > 2;
@@ -58,8 +58,27 @@ 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 14\n" : "not ok 14\n";
+print &POSIX::acos(1.0) == 0.0 ? "ok 17\n" : "not ok 17\n";
$| = 0;
print '@#!*$@(!@#$';
diff --git a/gnu/usr.bin/perl/t/lib/safe.t b/gnu/usr.bin/perl/t/lib/safe.t
deleted file mode 100644
index e59c81406b1..00000000000
--- a/gnu/usr.bin/perl/t/lib/safe.t
+++ /dev/null
@@ -1,96 +0,0 @@
-#!./perl
-
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bSafe\b/ && $^O ne 'VMS') {
- print "1..0\n";
- exit 0;
- }
-}
-
-use Safe qw(opname opcode ops_to_mask mask_to_ops);
-
-print "1..23\n";
-
-# Set up a package namespace of things to be visible to the unsafe code
-$Root::foo = "visible";
-
-# Stop perl from moaning about identifies which are apparently only used once
-$Root::foo .= "";
-$bar .= "";
-
-$bar = "invisible";
-$cpt = new Safe "Root";
-$cpt->reval(q{
- system("echo not ok 1");
-});
-if ($@ =~ /^system trapped by operation mask/) {
- print "ok 1\n";
-} else {
- 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 = "o";
-push(@baz, "10"); # Two steps to prevent "Identifier used only once..."
-$glob = "ok 11\n";
-@glob = qw(not ok 16);
-
-$" = 'k ';
-
-sub sayok12 { print "ok 12\n" }
-
-$cpt->share(qw($foo %bar @baz *glob &sayok12 $"));
-
-$cpt->reval(q{
- print $foo ? $foo : "not ok 8\n";
- print $bar{key} ? $bar{key} : "not ok 9\n";
- if (@baz) {
- print "@baz\n";
- } else {
- print "not ok 10\n";
- }
- print $glob;
- sayok12();
- $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";
-
-print opname(23) eq "bless" ? "ok 19\n" : "not ok 19\n";
-print opcode("bless") == 23 ? "ok 20\n" : "not ok 20\n";
-
-$m1 = $cpt->mask();
-$cpt->trap("negate");
-$m2 = $cpt->mask();
-@masked = mask_to_ops($m1);
-print $m2 eq ops_to_mask("negate", @masked) ? "ok 21\n" : "not ok 21\n";
-$cpt->untrap(187);
-substr($m2, 187, 1) = "\0";
-print $m2 eq $cpt->mask() ? "ok 22\n" : "not ok 22\n";
-
-print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
diff --git a/gnu/usr.bin/perl/t/lib/safe1.t b/gnu/usr.bin/perl/t/lib/safe1.t
new file mode 100644
index 00000000000..27993d95c9f
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/safe2.t b/gnu/usr.bin/perl/t/lib/safe2.t
new file mode 100644
index 00000000000..40c50980580
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/safe2.t
@@ -0,0 +1,144 @@
+#!./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->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/ ||
+ $! =~ /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/gnu/usr.bin/perl/t/lib/sdbm.t b/gnu/usr.bin/perl/t/lib/sdbm.t
index 3a56f5ccbf5..7eda515adf2 100644
--- a/gnu/usr.bin/perl/t/lib/sdbm.t
+++ b/gnu/usr.bin/perl/t/lib/sdbm.t
@@ -1,6 +1,6 @@
#!./perl
-# $RCSfile: sdbm.t,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:15 $
+# $RCSfile: sdbm.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:05:04 $
BEGIN {
chdir 't' if -d 't';
@@ -15,20 +15,26 @@ require SDBM_File;
#If Fcntl is not available, try 0x202 or 0x102 for O_RDWR|O_CREAT
use Fcntl;
-print "1..12\n";
+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");
+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*>;
}
-($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");
+if ($^O eq 'amigaos' || $^O eq 'os2' || $^O eq 'MSWin32') {
+ print "ok 2\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++;
}
@@ -85,7 +91,7 @@ delete $h{'goner3'};
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 gt $value) {
+ if ($key eq $keys[$i] && $value eq $values[$i] && $key eq lc($value)) {
$key =~ y/a-z/A-Z/;
$i++ if $key eq $value;
}
@@ -116,4 +122,84 @@ 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 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]]") ;
+
+ unlink "SubDB.pm", <dbhash.tmp*> ;
+
+}
diff --git a/gnu/usr.bin/perl/t/lib/searchdict.t b/gnu/usr.bin/perl/t/lib/searchdict.t
new file mode 100644
index 00000000000..447c425b276
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/selectsaver.t b/gnu/usr.bin/perl/t/lib/selectsaver.t
new file mode 100644
index 00000000000..3b58d709ab3
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/socket.t b/gnu/usr.bin/perl/t/lib/socket.t
index afc2a5bb751..4e382958ce4 100644
--- a/gnu/usr.bin/perl/t/lib/socket.t
+++ b/gnu/usr.bin/perl/t/lib/socket.t
@@ -5,7 +5,7 @@ BEGIN {
@INC = '../lib' if -d '../lib';
require Config; import Config;
if ($Config{'extensions'} !~ /\bSocket\b/ &&
- !(($^O eq 'VMS') && $Config{d_has_socket})) {
+ !(($^O eq 'VMS') && $Config{d_socket})) {
print "1..0\n";
exit 0;
}
@@ -26,6 +26,10 @@ if (socket(T,PF_INET,SOCK_STREAM,6)) {
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 {
@@ -52,6 +56,10 @@ if( socket(S,PF_INET,SOCK_STREAM,6) ){
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 {
diff --git a/gnu/usr.bin/perl/t/lib/soundex.t b/gnu/usr.bin/perl/t/lib/soundex.t
index 6a3fbbf0547..61fdad4d98d 100644
--- a/gnu/usr.bin/perl/t/lib/soundex.t
+++ b/gnu/usr.bin/perl/t/lib/soundex.t
@@ -1,13 +1,12 @@
#!./perl
#
-# $Id: soundex.t,v 1.1.1.1 1996/08/19 10:13:15 downsj Exp $
+# $Id: soundex.t,v 1.2 1997/11/30 08:05:07 millert Exp $
#
# test module for soundex.pl
#
# $Log: soundex.t,v $
-# Revision 1.1.1.1 1996/08/19 10:13:15 downsj
-# Import of Perl 5.003 into the tree. Makefile.bsd-wrapper and
-# config.sh.OpenBSD are the only local changes.
+# Revision 1.2 1997/11/30 08:05:07 millert
+# perl 5.004_04
#
# Revision 1.2 1994/03/24 00:30:27 mike
# Subtle bug (any excuse :-) spotted by Rich Pinder <rpinder@hsc.usc.edu>
diff --git a/gnu/usr.bin/perl/t/lib/symbol.t b/gnu/usr.bin/perl/t/lib/symbol.t
new file mode 100644
index 00000000000..03449a3ed74
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/texttabs.t b/gnu/usr.bin/perl/t/lib/texttabs.t
new file mode 100644
index 00000000000..ea9012c6526
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/textwrap.t b/gnu/usr.bin/perl/t/lib/textwrap.t
new file mode 100644
index 00000000000..9c8d1b49756
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/lib/timelocal.t b/gnu/usr.bin/perl/t/lib/timelocal.t
new file mode 100644
index 00000000000..adc1b1b0615
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/timelocal.t
@@ -0,0 +1,87 @@
+#!./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, 1, 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],
+ );
+
+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/gnu/usr.bin/perl/t/lib/trig.t b/gnu/usr.bin/perl/t/lib/trig.t
new file mode 100644
index 00000000000..c2bc2a8b5bc
--- /dev/null
+++ b/gnu/usr.bin/perl/t/lib/trig.t
@@ -0,0 +1,57 @@
+#!./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;
+
+sub near ($$;$) {
+ abs($_[0] - $_[1]) < (defined $_[2] ? $_[2] : $eps);
+}
+
+print "1..7\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";
+
+# eof
diff --git a/gnu/usr.bin/perl/t/op/arith.t b/gnu/usr.bin/perl/t/op/arith.t
new file mode 100644
index 00000000000..43af807b8b4
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/op/assignwarn.t b/gnu/usr.bin/perl/t/op/assignwarn.t
new file mode 100644
index 00000000000..57e89c45e04
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/op/bop.t b/gnu/usr.bin/perl/t/op/bop.t
new file mode 100644
index 00000000000..0c55029b931
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/bop.t
@@ -0,0 +1,55 @@
+#!./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");
+
+# short strings
+print (("AAAAA" & "zzzzz") eq '@@@@@' ? "ok 13\n" : "not ok 13\n");
+print (("AAAAA" | "zzzzz") eq '{{{{{' ? "ok 14\n" : "not ok 14\n");
+print (("AAAAA" ^ "zzzzz") eq ';;;;;' ? "ok 15\n" : "not ok 15\n");
+
+# long strings
+$foo = "A" x 150;
+$bar = "z" x 75;
+print (($foo & $bar) eq ('@'x75 ) ? "ok 16\n" : "not ok 16\n");
+print (($foo | $bar) eq ('{'x75 . 'A'x75) ? "ok 17\n" : "not ok 17\n");
+print (($foo ^ $bar) eq (';'x75 . 'A'x75) ? "ok 18\n" : "not ok 18\n");
diff --git a/gnu/usr.bin/perl/t/op/chop.t b/gnu/usr.bin/perl/t/op/chop.t
index 3516c2d18cc..77263ad3ad1 100644
--- a/gnu/usr.bin/perl/t/op/chop.t
+++ b/gnu/usr.bin/perl/t/op/chop.t
@@ -2,7 +2,7 @@
# $RCSfile: chop.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:40 $
-print "1..22\n";
+print "1..28\n";
# optimized
@@ -70,3 +70,18 @@ $_ = "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/gnu/usr.bin/perl/t/op/closure.t b/gnu/usr.bin/perl/t/op/closure.t
new file mode 100644
index 00000000000..1220998b6b6
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/closure.t
@@ -0,0 +1,454 @@
+#!./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..167\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
+ };
+
+# 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/gnu/usr.bin/perl/t/op/cmp.t b/gnu/usr.bin/perl/t/op/cmp.t
new file mode 100644
index 00000000000..4a7e68d4487
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/op/delete.t b/gnu/usr.bin/perl/t/op/delete.t
index 010cbf10035..4e00566cd74 100644
--- a/gnu/usr.bin/perl/t/op/delete.t
+++ b/gnu/usr.bin/perl/t/op/delete.t
@@ -2,11 +2,13 @@
# $RCSfile: delete.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:44 $
-print "1..7\n";
+print "1..16\n";
$foo{1} = 'a';
$foo{2} = 'b';
$foo{3} = 'c';
+$foo{4} = 'd';
+$foo{5} = 'e';
$foo = delete $foo{2};
@@ -14,9 +16,21 @@ 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 5\n";} else {print "not ok 5\n";}
+if ($foo eq 'ac' || $foo eq 'ca') {print "ok 14\n";} else {print "not ok 14\n";}
foreach $key (keys foo) {
delete $foo{$key};
@@ -26,7 +40,7 @@ $foo{'foo'} = 'x';
$foo{'bar'} = 'y';
$foo = join('',values(foo));
-if ($foo eq 'xy' || $foo eq 'yx') {print "ok 6\n";} else {print "not ok 6\n";}
+print +($foo eq 'xy' || $foo eq 'yx') ? "ok 15\n" : "not ok 15\n";
$refhash{"top"}->{"foo"} = "FOO";
$refhash{"top"}->{"bar"} = "BAR";
@@ -34,4 +48,4 @@ $refhash{"top"}->{"bar"} = "BAR";
delete $refhash{"top"}->{"bar"};
@list = keys %{$refhash{"top"}};
-print "@list" eq "foo" ? "ok 7\n" : "not ok 7 @list\n";
+print "@list" eq "foo" ? "ok 16\n" : "not ok 16 @list\n";
diff --git a/gnu/usr.bin/perl/t/op/each.t b/gnu/usr.bin/perl/t/op/each.t
index 7a58fc8dcc1..b92dd1770c6 100644
--- a/gnu/usr.bin/perl/t/op/each.t
+++ b/gnu/usr.bin/perl/t/op/each.t
@@ -2,7 +2,7 @@
# $RCSfile: each.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:47 $
-print "1..3\n";
+print "1..14\n";
$h{'abc'} = 'ABC';
$h{'def'} = 'DEF';
@@ -40,8 +40,10 @@ $h{'z'} = 'Z';
if ($#keys == 29 && $#values == 29) {print "ok 1\n";} else {print "not ok 1\n";}
-while (($key,$value) = each(h)) {
- if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
+$i = 0; # stop -w complaints
+
+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;
}
@@ -51,3 +53,57 @@ 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";
+
diff --git a/gnu/usr.bin/perl/t/op/exec.t b/gnu/usr.bin/perl/t/op/exec.t
index 1103a1a4649..7dfcd6177f9 100644
--- a/gnu/usr.bin/perl/t/op/exec.t
+++ b/gnu/usr.bin/perl/t/op/exec.t
@@ -3,6 +3,13 @@
# $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";
+ print "1..0\n";
+ exit(0);
+}
+
print "1..8\n";
print "not ok 1\n" if system "echo ok \\1"; # shell interpreted
diff --git a/gnu/usr.bin/perl/t/op/flip.t b/gnu/usr.bin/perl/t/op/flip.t
index 475f55a8c87..7852d0cee91 100644
--- a/gnu/usr.bin/perl/t/op/flip.t
+++ b/gnu/usr.bin/perl/t/op/flip.t
@@ -2,7 +2,7 @@
# $RCSfile: flip.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:52 $
-print "1..8\n";
+print "1..9\n";
@a = (1,2,3,4,5,6,7,8,9,10,11,12);
@@ -24,3 +24,6 @@ while (<of>) {
$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/gnu/usr.bin/perl/t/op/fork.t b/gnu/usr.bin/perl/t/op/fork.t
index 598310b63f5..9790ff0f8ce 100644
--- a/gnu/usr.bin/perl/t/op/fork.t
+++ b/gnu/usr.bin/perl/t/op/fork.t
@@ -2,6 +2,16 @@
# $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";
diff --git a/gnu/usr.bin/perl/t/op/glob.t b/gnu/usr.bin/perl/t/op/glob.t
index b4038442bdc..253e4a312fb 100644
--- a/gnu/usr.bin/perl/t/op/glob.t
+++ b/gnu/usr.bin/perl/t/op/glob.t
@@ -2,14 +2,21 @@
# $RCSfile: glob.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:55 $
-print "1..4\n";
+print "1..6\n";
-@ops = <op/*>;
-$list = join(' ',@ops);
+@oops = @ops = <op/*>;
-chop($otherway = `echo op/*`);
-
-print $list eq $otherway ? "ok 1\n" : "not ok 1\n$list\n$otherway\n";
+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";
@@ -20,3 +27,11 @@ while (<jskdfjskdfj* op/* jskdjfjkosvk*>) {
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/gnu/usr.bin/perl/t/op/goto.t b/gnu/usr.bin/perl/t/op/goto.t
index 087331907e3..1b34acda395 100644
--- a/gnu/usr.bin/perl/t/op/goto.t
+++ b/gnu/usr.bin/perl/t/op/goto.t
@@ -31,7 +31,8 @@ label4:
print "#2\t:$foo: == 4\n";
if ($foo == 4) {print "ok 2\n";} else {print "not ok 2\n";}
-$x = `./perl -e 'goto foo;' 2>&1`;
+$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";}
diff --git a/gnu/usr.bin/perl/t/op/groups.t b/gnu/usr.bin/perl/t/op/groups.t
index 4445953966b..47aabe3d7b4 100644
--- a/gnu/usr.bin/perl/t/op/groups.t
+++ b/gnu/usr.bin/perl/t/op/groups.t
@@ -1,6 +1,9 @@
#!./perl
-if (! -x '/usr/ucb/groups') {
+if (! -x ($groups = '/usr/ucb/groups') &&
+ ! -x ($groups = '/usr/bin/groups') &&
+ ! -x ($groups = '/bin/groups')
+) {
print "1..0\n";
exit 0;
}
@@ -26,7 +29,7 @@ for (split(' ', $()) {
$gr1 = join(' ', sort @gr);
-$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',`/usr/ucb/groups`)));
+$gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',`$groups`)));
if ($gr1 eq $gr2) {
print "ok 1\n";
diff --git a/gnu/usr.bin/perl/t/op/gv.t b/gnu/usr.bin/perl/t/op/gv.t
new file mode 100644
index 00000000000..ece32d936cd
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/gv.t
@@ -0,0 +1,59 @@
+#!./perl
+
+#
+# various typeglob tests
+#
+
+print "1..11\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";
+}
+
diff --git a/gnu/usr.bin/perl/t/op/inc.t b/gnu/usr.bin/perl/t/op/inc.t
new file mode 100644
index 00000000000..e5a2a921b3f
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/op/local.t b/gnu/usr.bin/perl/t/op/local.t
index 043201072db..f527c9c9a90 100644
--- a/gnu/usr.bin/perl/t/op/local.t
+++ b/gnu/usr.bin/perl/t/op/local.t
@@ -2,7 +2,7 @@
# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $
-print "1..20\n";
+print "1..23\n";
sub foo {
local($a, $b) = @_;
@@ -43,3 +43,12 @@ $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";
diff --git a/gnu/usr.bin/perl/t/op/magic.t b/gnu/usr.bin/perl/t/op/magic.t
index b43f71c809c..bddcd27679a 100644
--- a/gnu/usr.bin/perl/t/op/magic.t
+++ b/gnu/usr.bin/perl/t/op/magic.t
@@ -1,45 +1,181 @@
#!./perl
-# $RCSfile: magic.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:05 $
+BEGIN {
+ $^W = 1;
+ $| = 1;
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ $SIG{__WARN__} = sub { die "Dying on warning: ", @_ };
+}
-$| = 1; # command buffering
+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';
+$PERL = ($Is_MSWin32 ? '.\perl' : './perl');
-print "1..6\n";
+print "1..30\n";
eval '$ENV{"foo"} = "hi there";'; # check that ENV is inited inside eval
-if (`echo \$foo` eq "hi there\n") {print "ok 1\n";} else {print "not ok 1\n";}
+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');
-if ($!) {print "ok 2\n";} else {print "not ok 2\n";}
+open(FOO,'ajslkdfpqjsjfk');
+ok 2, $!, $!;
+close FOO; # just mention it, squelch used-only-once
-# 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';
+if ($Is_MSWin32) {
+ ok 3,1;
+ ok 4,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",$$;
- $SIG{"INT"} = "IGNORE"; kill 2,$$; print "ok 4\n";
- $SIG{"INT"} = "DEFAULT"; kill 2,$$; print "not ok\n";
+ $SIG{"INT"} = "ok3"; kill "INT",$$;
+ $SIG{"INT"} = "IGNORE"; kill "INT",$$; print "ok 4\n";
+ $SIG{"INT"} = "DEFAULT"; kill "INT",$$; print "not ok\n";
sub ok3 {
if (($x = pop(@_)) eq "INT") {
print "ok 3\n";
}
else {
- print "not ok 3 $a\n";
+ print "not ok 3 ($x @_)\n";
}
}
END
+}
-@val1 = @ENV{keys(%ENV)}; # can we slice ENV?
+# 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 = `pwd`);
+ }
+ 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
+ }
+ $s1 = $s2 = "\$^X is $perl, \$0 is $script\n";
+ if ($^O eq 'os2') {
+ # Started by ksh, which adds suffixes '.exe' and '.' to perl and script
+ $s2 = "\$^X is $wd/perl.exe, \$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{\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`;
+ 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;
-print join(':',@val1) eq join(':',@val2) ? "ok 5\n" : "not ok 5\n";
+if ($Is_VMS) {
+ ok 29, 1;
+ ok 30, 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") );
-print @val1 > 1 ? "ok 6\n" : "not ok 6\n";
+ $ENV{NoNeSuCh} = "foo";
+ $0 = "bar";
+ ok 30, ($Is_MSWin32 ? (`cmd /x /c set NoNeSuCh` eq "NoNeSuCh=foo\n")
+ : (`echo \$NoNeSuCh` eq "foo\n") );
+}
diff --git a/gnu/usr.bin/perl/t/op/method.t b/gnu/usr.bin/perl/t/op/method.t
new file mode 100644
index 00000000000..d955705d1a1
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/method.t
@@ -0,0 +1,122 @@
+#!./perl
+
+#
+# test method calls and autoloading.
+#
+
+print "1..24\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");
+
+*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/gnu/usr.bin/perl/t/op/misc.t b/gnu/usr.bin/perl/t/op/misc.t
index 8fdd11a7d4a..6156ac2f217 100644
--- a/gnu/usr.bin/perl/t/op/misc.t
+++ b/gnu/usr.bin/perl/t/op/misc.t
@@ -1,5 +1,8 @@
#!./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";
@@ -14,17 +17,24 @@ $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 = $&;
+ if (s/^\s*(-\w.*)//){
+ $switch = $1;
}
my($prog,$expected) = split(/\nEXPECT\n/, $_);
- open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1";
+ 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 = `$CAT $tmpfile`;
$results =~ s/\n+$//;
$expected =~ s/\n+$//;
if ( $results ne $expected){
@@ -37,6 +47,18 @@ for (@prgs){
}
__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" without a package or object reference at - line 1.
@@ -62,7 +84,7 @@ EXPECT
########
eval {sub bar {print "In bar";}}
########
-system "./perl -ne 'print if eof' /dev/null"
+system './perl -ne "print if eof" /dev/null'
########
chop($file = <>);
########
@@ -76,7 +98,8 @@ EXPECT
########
%@x=0;
EXPECT
-Can't coerce HASH to string in repeat at - line 1.
+Can't modify hash deref in repeat at - line 1, near "0;"
+Execution of - aborted due to compilation errors.
########
$_="foo";
printf(STDOUT "%s\n", $_);
@@ -169,3 +192,155 @@ 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';
+########
+sub foo { local(@_) = ('p', 'q', 'r'); }
+sub bar { unshift @_, 'D'; @_ }
+sub baz { push @_, 'E'; return @_ }
+for (1..3) { print foo('a', 'b', 'c'), bar('d'), baz('e'), "\n" }
+EXPECT
+pqrDdeE
+pqrDdeE
+pqrDdeE
diff --git a/gnu/usr.bin/perl/t/op/mkdir.t b/gnu/usr.bin/perl/t/op/mkdir.t
index 7db5ec91e45..5ba0a0f18d1 100644
--- a/gnu/usr.bin/perl/t/op/mkdir.t
+++ b/gnu/usr.bin/perl/t/op/mkdir.t
@@ -4,11 +4,14 @@
print "1..7\n";
-`rm -rf blurfl`;
+$^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/ ? "ok 3\n" : "not ok 3\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");
diff --git a/gnu/usr.bin/perl/t/op/my.t b/gnu/usr.bin/perl/t/op/my.t
index 4ce020f2066..06c69635346 100644
--- a/gnu/usr.bin/perl/t/op/my.t
+++ b/gnu/usr.bin/perl/t/op/my.t
@@ -1,8 +1,8 @@
#!./perl
-# $RCSfile: local.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:04 $
+# $RCSfile: my.t,v $
-print "1..20\n";
+print "1..28\n";
sub foo {
my($a, $b) = @_;
@@ -44,3 +44,42 @@ $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";
diff --git a/gnu/usr.bin/perl/t/op/oct.t b/gnu/usr.bin/perl/t/op/oct.t
index 7890643aef4..24b5c4309d4 100644
--- a/gnu/usr.bin/perl/t/op/oct.t
+++ b/gnu/usr.bin/perl/t/op/oct.t
@@ -2,7 +2,7 @@
# $RCSfile: oct.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:08 $
-print "1..6\n";
+print "1..8\n";
print +(oct('01234') == 01234) ? "ok" : "not ok", " 1\n";
print +(oct('0x1234') == 0x1234) ? "ok" : "not ok", " 2\n";
@@ -10,3 +10,5 @@ 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/gnu/usr.bin/perl/t/op/pack.t b/gnu/usr.bin/perl/t/op/pack.t
index 1cfcd60b086..f9a89a3ec02 100644
--- a/gnu/usr.bin/perl/t/op/pack.t
+++ b/gnu/usr.bin/perl/t/op/pack.t
@@ -2,9 +2,9 @@
# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
-print "1..8\n";
+print "1..29\n";
-$format = "c2x5CCxsdila6";
+$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");
@@ -41,3 +41,62 @@ 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");
+
diff --git a/gnu/usr.bin/perl/t/op/pat.t b/gnu/usr.bin/perl/t/op/pat.t
index d5d1aa63010..4f44fb09be3 100644
--- a/gnu/usr.bin/perl/t/op/pat.t
+++ b/gnu/usr.bin/perl/t/op/pat.t
@@ -1,8 +1,8 @@
#!./perl
-# $RCSfile: pat.t,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:20 $
+# $RCSfile: pat.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:05:33 $
-print "1..60\n";
+print "1..62\n";
$x = "abc\ndef\n";
@@ -134,17 +134,19 @@ print join(':',@words) eq "now:is:the:time:for:all:good:men:to:come:to"
: "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";
+ : "not ok 46 `@words'\n";
+pos $_ = 0;
@words = /to/g;
print join(':',@words) eq "to:to"
? "ok 47\n"
- : "not ok 47 @words\n";
+ : "not ok 47 `@words'\n";
$_ = "abcdefghi";
@@ -191,12 +193,14 @@ $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;
@@ -204,3 +208,12 @@ 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";
diff --git a/gnu/usr.bin/perl/t/op/quotemeta.t b/gnu/usr.bin/perl/t/op/quotemeta.t
index 09794571b1d..20dd312b316 100644
--- a/gnu/usr.bin/perl/t/op/quotemeta.t
+++ b/gnu/usr.bin/perl/t/op/quotemeta.t
@@ -1,15 +1,15 @@
#!./perl
print "1..15\n";
-$_=join "", grep $_=chr($_), 32..127;
+$_=join "", map chr($_), 32..127;
-#95 characters - 52 letters - 10 digits = 33 backslashes
-#95 characters + 33 backslashes = 128 characters
+# 96 characters - 52 letters - 10 digits - 1 underscore = 33 backslashes
+# 96 characters + 33 backslashes = 129 characters
$_=quotemeta $_;
-if ( length == 128 ){print "ok 1\n"} else {print "not ok 1\n"}
-if (tr/\\//cd == 94){print "ok 2\n"} else {print "not ok 2\n"}
+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"}
-#perl5a11 bus errors on this:
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";
diff --git a/gnu/usr.bin/perl/t/op/rand.t b/gnu/usr.bin/perl/t/op/rand.t
index 5c0eccf15f1..c779f9dad9c 100644
--- a/gnu/usr.bin/perl/t/op/rand.t
+++ b/gnu/usr.bin/perl/t/op/rand.t
@@ -1,52 +1,348 @@
#!./perl
-# From: kgb@ast.cam.ac.uk (Karl Glazebrook)
+# From Tom Phoenix <rootbeer@teleport.com> 22 Feb 1997
+# Based upon a test script by kgb@ast.cam.ac.uk (Karl Glazebrook)
-print "1..4\n";
+# 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.
-srand;
-
-$m=0;
-for(1..1000){
- $n = rand(1);
- if ($n<0 || $n>=1) {
- print "not ok 1\n# The value of randbits is likely too low in config.sh\n";
- exit
- }
- $m += $n;
+# 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";
}
-$m=$m/1000;
-print "ok 1\n";
-if ($m<0.4) {
- print "not ok 2\n# The value of randbits is likely too high in config.sh\n";
+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;
}
-elsif ($m>0.6) {
- print "not ok 2\n# Something's really weird about rand()'s distribution.\n";
-}else{
- print "ok 2\n";
+
+# 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;
+{
+ 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";
+ }
-$m=0;
-for(1..1000){
- $n = rand(100);
- if ($n<0 || $n>=100) {
- print "not ok 3\n";
- exit
- }
- $m += $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";
+ }
}
-$m=$m/1000;
-print "ok 3\n";
-if ($m<40 || $m>60) {
- print "not ok 4\n";
-}else{
- print "ok 4\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/gnu/usr.bin/perl/t/op/re_tests b/gnu/usr.bin/perl/t/op/re_tests
index f8c4c6eafbc..ce4c5a51a23 100644
--- a/gnu/usr.bin/perl/t/op/re_tests
+++ b/gnu/usr.bin/perl/t/op/re_tests
@@ -42,9 +42,9 @@ 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 - c - -
-a[ - c - -
+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
@@ -53,24 +53,60 @@ 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 - -
-(*)b - c - -
+*a - c - /*a/: ?+*{} follows nothing in regexp
+(*)b - c - /(*)b/: ?+*{} follows nothing in regexp
$b b n - -
-a\ - c - -
+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 - c - -
+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** - 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
@@ -78,7 +114,7 @@ a.+?c abcabc y $& abc
(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 - -
+)( - c - /)(/: unmatched () in regexp
[^ab]* cde y $& cde
abc n - -
a* y $&
@@ -169,9 +205,9 @@ a[-]?c ac y $& ac
'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'i - c - -
-'a['i - c - -
+'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
@@ -183,21 +219,21 @@ a[-]?c ac y $& ac
'ab|cd'i ABC y $& AB
'ab|cd'i ABCD y $& AB
'()ef'i DEF y $&-$1 EF-
-'*a'i - c - -
-'(*)b'i - c - -
+'*a'i - c - /*a/: ?+*{} follows nothing in regexp
+'(*)b'i - c - /(*)b/: ?+*{} follows nothing in regexp
'$b'i B n - -
-'a\'i - c - -
+'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'i - c - -
+'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**'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
@@ -208,7 +244,7 @@ a[-]?c ac y $& ac
'(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 - -
+')('i - c - /)(/: unmatched () in regexp
'[^ab]*'i CDE y $& CDE
'abc'i n - -
'a*'i y $&
@@ -265,3 +301,8 @@ a(?:b|c|d)*(.) ace y $1 e
a(?:b|c|d)+?(.) ace y $1 e
a(?:b|(c|e){1,2}?|d)+?(.) ace y $1$2 ce
^(.+)?B AB y $1 A
+'([a-z]+)\s\1'i Aa aa y $&-$1 Aa aa-Aa
+'([a-z]+)\s\1'i Ab ab y $&-$1 Ab ab-Ab
+foo\w*\d{4}baz foobar1234baz y $& foobar1234baz
+((foo)|(bar))* foobar y $1-$2-$3 bar-foo-bar
+:(?: - c - Sequence (? incomplete
diff --git a/gnu/usr.bin/perl/t/op/readdir.t b/gnu/usr.bin/perl/t/op/readdir.t
index 1215f11c8a3..ca19ebc7db4 100644
--- a/gnu/usr.bin/perl/t/op/readdir.t
+++ b/gnu/usr.bin/perl/t/op/readdir.t
@@ -12,7 +12,7 @@ closedir(OP);
if (@D > 20 && @D < 100) { print "ok 2\n"; } else { print "not ok 2\n"; }
@R = sort @D;
-@G = <op/*.t>;
+@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
diff --git a/gnu/usr.bin/perl/t/op/recurse.t b/gnu/usr.bin/perl/t/op/recurse.t
new file mode 100644
index 00000000000..6594940a903
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/op/ref.t b/gnu/usr.bin/perl/t/op/ref.t
index 38e34f002b1..9fcc8ac15ce 100644
--- a/gnu/usr.bin/perl/t/op/ref.t
+++ b/gnu/usr.bin/perl/t/op/ref.t
@@ -1,6 +1,6 @@
#!./perl
-print "1..41\n";
+print "1..51\n";
# Test glob operations.
@@ -101,7 +101,7 @@ $subref = \&mysub;
&$subref;
$subrefref = \\&mysub2;
-&$$subrefref("ok 24\n");
+$$subrefref->("ok 24\n");
sub mysub2 { print shift }
# Test the ref operator.
@@ -189,12 +189,54 @@ 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";
+
package FINALE;
{
- $ref3 = bless ["ok 41\n"]; # package destruction
- my $ref2 = bless ["ok 40\n"]; # lexical destruction
- local $ref1 = bless ["ok 39\n"]; # dynamic destruction
+ $ref3 = bless ["ok 51\n"]; # package destruction
+ my $ref2 = bless ["ok 50\n"]; # lexical destruction
+ local $ref1 = bless ["ok 49\n"]; # dynamic destruction
1; # flush any temp values on stack
}
diff --git a/gnu/usr.bin/perl/t/op/regexp.t b/gnu/usr.bin/perl/t/op/regexp.t
index 2ef6791110e..803f1d0dabf 100644
--- a/gnu/usr.bin/perl/t/op/regexp.t
+++ b/gnu/usr.bin/perl/t/op/regexp.t
@@ -1,35 +1,58 @@
#!./perl
-# $RCSfile: regexp.t,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:22 $
+# 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.
open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
|| die "Can't open re_tests";
+
while (<TESTS>) { }
$numtests = $.;
-close(TESTS);
+seek(TESTS,0,0);
+$. = 0;
-print "1..$numtests\n";
-open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests')
- || die "Can't open re_tests";
$| = 1;
+print "1..$numtests\n";
+TEST:
while (<TESTS>) {
($pat, $subject, $result, $repl, $expect) = split(/[\t\n]/,$_);
$input = join(':',$pat,$subject,$result,$repl,$expect);
- $pat = "'$pat'" unless $pat =~ /^'/;
- eval "\$match = (\$subject =~ m$pat); \$got = \"$repl\";";
- if ($result eq 'c') {
- if ($@ ne '') {print "ok $.\n";} else {print "not ok $.\n";}
- }
- elsif ($result eq 'n') {
- if (!$match) {print "ok $.\n";} else {print "not ok $. $input => $got\n";}
- }
- else {
- if ($match && $got eq $expect) {
- print "ok $.\n";
+ $pat = "'$pat'" unless $pat =~ /^[:']/;
+ for $study ("", "study \$subject") {
+ eval "$study; \$match = (\$subject =~ m$pat); \$got = \"$repl\";";
+ if ($result eq 'c') {
+ if ($@ !~ m!^\Q$expect!) { print "not ok $.\n"; next TEST }
+ last; # no need to study a syntax error
+ }
+ elsif ($result eq 'n') {
+ if ($match) { print "not ok $. $input => $got\n"; next TEST }
}
else {
- print "not ok $. $input => $got\n";
+ if (!$match || $got ne $expect) {
+ print "not ok $. $input => $got\n";
+ next TEST;
+ }
}
}
+ print "ok $.\n";
}
+
close(TESTS);
diff --git a/gnu/usr.bin/perl/t/op/runlevel.t b/gnu/usr.bin/perl/t/op/runlevel.t
new file mode 100644
index 00000000000..6693a829a88
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/runlevel.t
@@ -0,0 +1,317 @@
+#!./perl
+
+##
+## all of these tests are from Michael Schroeder
+## <Michael.Schroeder@informatik.uni-erlangen.de>
+##
+## The more esoteric failure modes require Michael's
+## stack-of-stacks patch (so we don't test them here,
+## and they are commented out before the __END__).
+##
+## The remaining tests pass with a simpler fix
+## intended for 5.004
+##
+## Gurusamy Sarathy <gsar@umich.edu> 97-02-24
+##
+
+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";
+}
+
+=head2 stay out of here (the real tests are after __END__)
+
+##
+## these tests don't pass yet (need the full stack-of-stacks patch)
+## GSAR 97-02-24
+##
+
+########
+# sort within sort
+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
+---- 1, 2, 3
+########
+# trapping eval within sort (doesn't work currently because
+# die does a SWITCHSTACK())
+@a = (3, 2, 1);
+@a = sort { eval('die("no way")') , $a <=> $b} @a;
+print join(", ", @a)."\n";
+EXPECT
+1, 2, 3
+########
+# this actually works fine, but results in a poor error message
+@a = (1, 2, 3);
+foo:
+{
+ @a = sort { last foo; } @a;
+}
+EXPECT
+cannot reach destination block 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
+cannot reach destination 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
+bbb
+########
+# trapping eval within sort (doesn't work currently because
+# die does a SWITCHSTACK())
+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;
+ next;
+ return bless \$foo;
+}
+package main;
+{
+tie $bar, TEST;
+}
+EXPECT
+cannot reach destination block at - line 4.
+########
+# large stack extension causes realloc, and segfault
+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";
+
+=cut
+
+##
+##
+## The real tests begin here
+##
+##
+
+__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.
diff --git a/gnu/usr.bin/perl/t/op/sleep.t b/gnu/usr.bin/perl/t/op/sleep.t
index 07cdb826d18..5f6c4c0bbbe 100644
--- a/gnu/usr.bin/perl/t/op/sleep.t
+++ b/gnu/usr.bin/perl/t/op/sleep.t
@@ -4,5 +4,5 @@
print "1..1\n";
-$x = sleep 2;
+$x = sleep 3;
if ($x >= 2 && $x <= 10) {print "ok 1\n";} else {print "not ok 1 $x\n";}
diff --git a/gnu/usr.bin/perl/t/op/sort.t b/gnu/usr.bin/perl/t/op/sort.t
index dc01e5f11dd..c792bbb48e6 100644
--- a/gnu/usr.bin/perl/t/op/sort.t
+++ b/gnu/usr.bin/perl/t/op/sort.t
@@ -2,21 +2,24 @@
# $RCSfile: sort.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:24 $
-print "1..10\n";
+print "1..19\n";
-sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0; }
+sub backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
@harry = ('dog','cat','x','Cain','Abel');
-@george = ('gone','chased','yz','Punished','Axed');
+@george = ('gone','chased','yz','punished','Axed');
$x = join('', sort @harry);
print ($x eq 'AbelCaincatdogx' ? "ok 1\n" : "not ok 1\n");
+print "# x = '$x'\n";
$x = join('', sort( backwards @harry));
print ($x eq 'xdogcatCainAbel' ? "ok 2\n" : "not ok 2\n");
+print "# x = '$x'\n";
$x = join('', sort @george, 'to', @harry);
-print ($x eq 'AbelAxedCainPunishedcatchaseddoggonetoxyz'?"ok 3\n":"not ok 3\n");
+print ($x eq 'AbelAxedCaincatchaseddoggonepunishedtoxyz'?"ok 3\n":"not ok 3\n");
+print "# x = '$x'\n";
@a = ();
@b = reverse @a;
@@ -46,3 +49,45 @@ $sub = 'backwards';
$x = join('', sort $sub @harry);
print ($x eq 'xdogcatCainAbel' ? "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";
diff --git a/gnu/usr.bin/perl/t/op/split.t b/gnu/usr.bin/perl/t/op/split.t
index 23545308179..07246522ee1 100644
--- a/gnu/usr.bin/perl/t/op/split.t
+++ b/gnu/usr.bin/perl/t/op/split.t
@@ -2,7 +2,7 @@
# $RCSfile: split.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:26 $
-print "1..12\n";
+print "1..20\n";
$FS = ':';
@@ -47,7 +47,8 @@ $_ = 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?
-$foo = `./perl -D1024 -e '(\$a,\$b) = split;' 2>&1`;
+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;"`;
}
@@ -58,3 +59,34 @@ print $foo =~ /DEBUGGING/ || $foo =~ /SV = IV\(3\)/ ? "ok 11\n" : "not ok 11\n";
$_ = 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";
+
diff --git a/gnu/usr.bin/perl/t/op/sprintf.t b/gnu/usr.bin/perl/t/op/sprintf.t
index 8e1ef6958f2..1450ae375f0 100644
--- a/gnu/usr.bin/perl/t/op/sprintf.t
+++ b/gnu/usr.bin/perl/t/op/sprintf.t
@@ -2,7 +2,32 @@
# $RCSfile: sprintf.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:27 $
-print "1..1\n";
+print "1..4\n";
+$^W = 1;
+$SIG{__WARN__} = sub {
+ if ($_[0] =~ /^Invalid conversion/) {
+ $w++;
+ } else {
+ warn @_;
+ }
+};
+
+$w = 0;
$x = sprintf("%3s %-4s%%foo %5d%c%3.1f","hi",123,456,65,3.0999);
-if ($x eq ' hi 123 %foo 456A3.1') {print "ok 1\n";} else {print "not ok 1 '$x'\n";}
+if ($x eq ' hi 123 %foo 456A3.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/gnu/usr.bin/perl/t/op/stat.t b/gnu/usr.bin/perl/t/op/stat.t
index 0ec31689cd6..97f81928856 100644
--- a/gnu/usr.bin/perl/t/op/stat.t
+++ b/gnu/usr.bin/perl/t/op/stat.t
@@ -1,65 +1,82 @@
#!./perl
# $RCSfile: stat.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:28 $
-# 950521 DFD This version hacked to make test 39 succeed on MachTen
-# though the O.S. wrongly thinks /dev/null is a terminal
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use Config;
+
print "1..56\n";
-chop($cwd = `pwd`);
+$Is_MSWin32 = $^O eq 'MSWin32';
+chop($cwd = ($Is_MSWin32 ? `cd` : `pwd`));
-$DEV = `ls -l /dev`;
+$DEV = `ls -l /dev` unless $Is_MSWin32;
unlink "Op.stat.tmp";
open(FOO, ">Op.stat.tmp");
-$junk = `ls Op.stat.tmp`; # hack to make Apollo update link count
+# hack to make Apollo update link count:
+$junk = `ls Op.stat.tmp` unless $Is_MSWin32;
($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 ($mtime && $mtime == $ctime) {print "ok 2\n";} else {print "not ok 2\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;
-`rm -f Op.stat.tmp2; ln Op.stat.tmp Op.stat.tmp2; chmod 644 Op.stat.tmp`;
+if ($Is_MSWin32) { 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 ($nlink == 2) {print "ok 3\n";} else {print "not ok 3\n";}
-if (($mtime && $mtime != $ctime) || $cwd =~ m#/afs/#) {
+if ($Is_MSWin32 || $Config{dont_use_nlink} || $nlink == 2)
+ {print "ok 3\n";} else {print "# \$nlink is |$nlink|\nnot ok 3\n";}
+
+if ($Is_MSWin32 || ($mtime && $mtime != $ctime) || $cwd =~ m#/afs/# || $^O eq 'amigaos') {
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';
- print '#4 of some sort. Building in /tmp sometimes has this problem.';
+ 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: != :$ctime:\n";
-`rm -f Op.stat.tmp`;
-`touch Op.stat.tmp`;
+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";}
-`echo hi >Op.stat.tmp`;
+$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
-`echo hi >Op.stat.tmp`;
+$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 (!$> || ! -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";}
+
+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
@@ -68,7 +85,7 @@ foreach ((12,13,14,15,16,17)) {
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 (-x 'Op.stat.tmp') {print "ok 20\n";} else {print "not ok 20\n";}
+if ($Is_MSWin32 or -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";}
@@ -76,7 +93,7 @@ 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 (`ls -l perl` =~ /^l.*->/) {
+if (!$Is_MSWin32 and `ls -l perl` =~ /^l.*->/) {
if (-l 'perl') {print "ok 25\n";} else {print "not ok 25\n";}
}
else {
@@ -86,10 +103,12 @@ else {
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";}
-`rm -f Op.stat.tmp Op.stat.tmp2`;
+unlink 'Op.stat.tmp', 'Op.stat.tmp2';
if (! -e 'Op.stat.tmp') {print "ok 28\n";} else {print "not ok 28\n";}
-if ($DEV !~ /\nc.* (\S+)\n/)
+if ($Is_MSWin32)
+ {print "ok 29\n";}
+elsif ($DEV !~ /\nc.* (\S+)\n/)
{print "ok 29\n";}
elsif (-c "/dev/$1")
{print "ok 29\n";}
@@ -97,7 +116,9 @@ else
{print "not ok 29\n";}
if (! -c '.') {print "ok 30\n";} else {print "not ok 30\n";}
-if ($DEV !~ /\ns.* (\S+)\n/)
+if ($Is_MSWin32)
+ {print "ok 31\n";}
+elsif ($DEV !~ /\ns.* (\S+)\n/)
{print "ok 31\n";}
elsif (-S "/dev/$1")
{print "ok 31\n";}
@@ -105,7 +126,9 @@ else
{print "not ok 31\n";}
if (! -S '.') {print "ok 32\n";} else {print "not ok 32\n";}
-if ($DEV !~ /\nb.* (\S+)\n/)
+if ($Is_MSWin32)
+ {print "ok 33\n";}
+elsif ($DEV !~ /\nb.* (\S+)\n/)
{print "ok 33\n";}
elsif (-b "/dev/$1")
{print "ok 33\n";}
@@ -113,17 +136,21 @@ else
{print "not ok 33\n";}
if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";}
+if ($^O eq 'amigaos' or $Is_MSWin32) {print "ok 35\n"; goto tty_test;}
+
$cnt = $uid = 0;
die "Can't run op/stat.t test 35 without pwd working" unless $cwd;
-print ("not ok 35\n"), goto tty_test unless -d '/usr/bin';
-chdir '/usr/bin' || die "Can't cd to /usr/bin";
-while (defined($_ = <*>)) {
+($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;
}
-chdir $cwd || die "Can't cd back to $cwd";
+closedir BIN;
# I suppose this is going to fail somewhere...
if ($uid > 0 && $uid < $cnt)
@@ -133,18 +160,35 @@ else
tty_test:
-unless (open(tty,"/dev/tty")) {
- print STDERR "Can't open /dev/tty--run t/TEST outside of make.\n";
+# 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";
}
-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";}
open(null,"/dev/null");
-if (! -t null || -e '/xenix' || -e '/MachTen')
- {print "ok 39\n";} else {print "not ok 39\n";}
+if (! -t null || -e '/xenix' || $^O eq 'machten' || $Is_MSWin32)
+ {print "ok 40\n";} else {print "not ok 40\n";}
close(null);
-if (-t) {print "ok 40\n";} else {print "not ok 40\n";}
# These aren't strictly "stat" calls, but so what?
diff --git a/gnu/usr.bin/perl/t/op/subst.t b/gnu/usr.bin/perl/t/op/subst.t
index f80f807948c..a3d132b8dbb 100644
--- a/gnu/usr.bin/perl/t/op/subst.t
+++ b/gnu/usr.bin/perl/t/op/subst.t
@@ -1,8 +1,8 @@
#!./perl
-# $RCSfile: subst.t,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:23 $
+# $RCSfile: subst.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:05:45 $
-print "1..56\n";
+print "1..62\n";
$x = 'foo';
$_ = "x";
@@ -198,3 +198,44 @@ 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 = $&, m#.#/eg;
+print $x eq "cd" ? "ok 61\n" : "not ok 61\n";
+
+# check parsing of split subst with comment
+eval 's{foo} # this is a comment, not a delimiter
+ {bar};';
+print @? ? "not ok 62\n" : "ok 62\n";
diff --git a/gnu/usr.bin/perl/t/op/substr.t b/gnu/usr.bin/perl/t/op/substr.t
index 240b51f98ed..7950474814a 100644
--- a/gnu/usr.bin/perl/t/op/substr.t
+++ b/gnu/usr.bin/perl/t/op/substr.t
@@ -1,26 +1,41 @@
#!./perl
-# $RCSfile: substr.t,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:23 $
+# $RCSfile: substr.t,v $$Revision: 1.2 $$Date: 1997/11/30 08:05:45 $
-print "1..22\n";
+print "1..97\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;
+ } else {
+ warn @_;
+ }
+};
-print (substr($a,0,3) eq 'abc' ? "ok 1\n" : "not ok 1\n");
-print (substr($a,3,3) eq 'def' ? "ok 2\n" : "not ok 2\n");
-print (substr($a,6,999) eq 'xyz' ? "ok 3\n" : "not ok 3\n");
-print (substr($a,999,999) eq '' ? "ok 4\n" : "not ok 4\n");
-print (substr($a,0,-6) eq 'abc' ? "ok 5\n" : "not ok 5\n");
-print (substr($a,-3,1) eq 'x' ? "ok 6\n" : "not ok 6\n");
+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");
-print (substr($a,4,3) eq 'def' ? "ok 8\n" : "not ok 8\n");
-print (substr($a,7,999) eq 'xyz' ? "ok 9\n" : "not ok 9\n");
-print (substr($a,999,999) eq '' ? "ok 10\n" : "not ok 10\n");
-print (substr($a,1,-6) eq 'abc' ? "ok 11\n" : "not ok 11\n");
-print (substr($a,-3,1) eq 'x' ? "ok 12\n" : "not ok 12\n");
+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;
@@ -28,7 +43,6 @@ 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";
-y/a/a/;
substr($a,0,0) = 'ab';
print $a eq 'abcXYZxyz' ? "ok 15\n" : "not ok 15 $a\n";
substr($a,0,0) = '12345678';
@@ -42,6 +56,125 @@ 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");
-print (substr($a,-3) eq 'xyz' ? "ok 21\n" : "not ok 21\n");
-print (substr($a,999) eq '' ? "ok 22\n" : "not ok 22\n");
+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";
diff --git a/gnu/usr.bin/perl/t/op/sysio.t b/gnu/usr.bin/perl/t/op/sysio.t
new file mode 100644
index 00000000000..0af333db848
--- /dev/null
+++ b/gnu/usr.bin/perl/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');
+
+$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/gnu/usr.bin/perl/t/op/taint.t b/gnu/usr.bin/perl/t/op/taint.t
new file mode 100644
index 00000000000..8437c43c453
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/taint.t
@@ -0,0 +1,574 @@
+#!./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;
+
+my $Is_VMS = $^O eq 'VMS';
+my $Is_MSWin32 = $^O eq 'MSWin32';
+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..140\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) {
+ 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) {
+ 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 $_\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 {
+ print "# can't find world-writeable directory to test DCL\$PATH\n";
+ for (10..11) { print "ok $_\n" }
+ }
+ $ENV{'DCL$PATH'} = '';
+ }
+ else {
+ print "# This is not VMS\n";
+ for (8..11) { print "ok $_\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';
+
+ my $pi = 4 * atan2(1,1) + $TAINT0;
+ test 22, tainted $pi;
+
+ ($pi) = $pi =~ /(\d+\.\d+)/;
+ test 23, not tainted $pi;
+ test 24, 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 25, !$?, "Exited with status $?";
+ unlink $arg;
+}
+
+# Reading from a file should be tainted
+{
+ my $file = './TEST';
+ test 26, open(FILE, $file), "Couldn't open '$file': $!";
+
+ my $block;
+ sysread(FILE, $block, 100);
+ my $line = <FILE>;
+ close FILE;
+ test 27, tainted $block;
+ test 28, tainted $line;
+}
+
+# Globs should be forbidden, except under VMS,
+# which doesn't spawn an external program.
+if ($Is_VMS) {
+ for (29..30) { print "ok $_\n"; }
+}
+else {
+ my @globs = eval { <*> };
+ test 29, @globs == 0 && $@ =~ /^Insecure dependency/;
+
+ @globs = eval { glob '*' };
+ test 30, @globs == 0 && $@ =~ /^Insecure dependency/;
+}
+
+# Output of commands should be tainted
+{
+ my $foo = `$echo abc`;
+ test 31, tainted $foo;
+}
+
+# Certain system variables should be tainted
+{
+ test 32, all_tainted $^X, $0;
+}
+
+# Results of matching should all be untainted
+{
+ my $foo = "abcdefghi" . $TAINT;
+ test 33, tainted $foo;
+
+ $foo =~ /def/;
+ test 34, not any_tainted $`, $&, $';
+
+ $foo =~ /(...)(...)(...)/;
+ test 35, not any_tainted $1, $2, $3, $+;
+
+ my @bar = $foo =~ /(...)(...)(...)/;
+ test 36, not any_tainted @bar;
+
+ test 37, tainted $foo; # $foo should still be tainted!
+ test 38, $foo eq "abcdefghi";
+}
+
+# Operations which affect files can't use tainted data.
+{
+ test 39, eval { chmod 0, $TAINT } eq '', 'chmod';
+ test 40, $@ =~ /^Insecure dependency/, $@;
+
+ # There is no feature test in $Config{} for truncate,
+ # so we allow for the possibility that it's missing.
+ test 41, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate';
+ test 42, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@;
+
+ test 43, eval { rename '', $TAINT } eq '', 'rename';
+ test 44, $@ =~ /^Insecure dependency/, $@;
+
+ test 45, eval { unlink $TAINT } eq '', 'unlink';
+ test 46, $@ =~ /^Insecure dependency/, $@;
+
+ test 47, eval { utime $TAINT } eq '', 'utime';
+ test 48, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_chown}) {
+ test 49, eval { chown -1, -1, $TAINT } eq '', 'chown';
+ test 50, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# chown() is not available\n";
+ for (49..50) { print "ok $_\n" }
+ }
+
+ if ($Config{d_link}) {
+ test 51, eval { link $TAINT, '' } eq '', 'link';
+ test 52, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# link() is not available\n";
+ for (51..52) { print "ok $_\n" }
+ }
+
+ if ($Config{d_symlink}) {
+ test 53, eval { symlink $TAINT, '' } eq '', 'symlink';
+ test 54, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# symlink() is not available\n";
+ for (53..54) { print "ok $_\n" }
+ }
+}
+
+# Operations which affect directories can't use tainted data.
+{
+ test 55, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir';
+ test 56, $@ =~ /^Insecure dependency/, $@;
+
+ test 57, eval { rmdir $TAINT } eq '', 'rmdir';
+ test 58, $@ =~ /^Insecure dependency/, $@;
+
+ test 59, eval { chdir $TAINT } eq '', 'chdir';
+ test 60, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_chroot}) {
+ test 61, eval { chroot $TAINT } eq '', 'chroot';
+ test 62, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# chroot() is not available\n";
+ for (61..62) { print "ok $_\n" }
+ }
+}
+
+# Some operations using files can't use tainted data.
+{
+ my $foo = "imaginary library" . $TAINT;
+ test 63, eval { require $foo } eq '', 'require';
+ test 64, $@ =~ /^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 65, eval { open FOO, $foo } eq '', 'open for read';
+ test 66, $@ eq '', $@; # NB: This should be allowed
+ test 67, $! == 2; # File not found
+
+ test 68, eval { open FOO, "> $foo" } eq '', 'open for write';
+ test 69, $@ =~ /^Insecure dependency/, $@;
+}
+
+# Commands to the system can't use tainted data
+{
+ my $foo = $TAINT;
+
+ if ($^O eq 'amigaos') {
+ print "# open(\"|\") is not available\n";
+ for (70..73) { print "ok $_\n" }
+ }
+ else {
+ test 70, eval { open FOO, "| $foo" } eq '', 'popen to';
+ test 71, $@ =~ /^Insecure dependency/, $@;
+
+ test 72, eval { open FOO, "$foo |" } eq '', 'popen from';
+ test 73, $@ =~ /^Insecure dependency/, $@;
+ }
+
+ test 74, eval { exec $TAINT } eq '', 'exec';
+ test 75, $@ =~ /^Insecure dependency/, $@;
+
+ test 76, eval { system $TAINT } eq '', 'system';
+ test 77, $@ =~ /^Insecure dependency/, $@;
+
+ $foo = "*";
+ taint_these $foo;
+
+ test 78, eval { `$echo 1$foo` } eq '', 'backticks';
+ test 79, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe
+ test 80, join('', eval { glob $foo } ) ne '', 'globbing';
+ test 81, $@ eq '', $@;
+ }
+ else {
+ for (80..81) { print "ok $_\n"; }
+ }
+}
+
+# Operations which affect processes can't use tainted data.
+{
+ test 82, eval { kill 0, $TAINT } eq '', 'kill';
+ test 83, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_setpgrp}) {
+ test 84, eval { setpgrp 0, $TAINT } eq '', 'setpgrp';
+ test 85, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# setpgrp() is not available\n";
+ for (84..85) { print "ok $_\n" }
+ }
+
+ if ($Config{d_setprior}) {
+ test 86, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority';
+ test 87, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# setpriority() is not available\n";
+ for (86..87) { print "ok $_\n" }
+ }
+}
+
+# Some miscellaneous operations can't use tainted data.
+{
+ if ($Config{d_syscall}) {
+ test 88, eval { syscall $TAINT } eq '', 'syscall';
+ test 89, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# syscall() is not available\n";
+ for (88..89) { print "ok $_\n" }
+ }
+
+ {
+ my $foo = "x" x 979;
+ taint_these $foo;
+ local *FOO;
+ my $temp = "./taintC$$";
+ END { unlink $temp }
+ test 90, open(FOO, "> $temp"), "Couldn't open $temp for write: $!";
+
+ test 91, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl';
+ test 92, $@ =~ /^Insecure dependency/, $@;
+
+ if ($Config{d_fcntl}) {
+ test 93, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl';
+ test 94, $@ =~ /^Insecure dependency/, $@;
+ }
+ else {
+ print "# fcntl() is not available\n";
+ for (93..94) { print "ok $_\n" }
+ }
+
+ close FOO;
+ }
+}
+
+# Some tests involving references
+{
+ my $foo = 'abc' . $TAINT;
+ my $fooref = \$foo;
+ test 95, not tainted $fooref;
+ test 96, tainted $$fooref;
+ test 97, tainted $foo;
+}
+
+# Some tests involving assignment
+{
+ my $foo = $TAINT0;
+ my $bar = $foo;
+ test 98, all_tainted $foo, $bar;
+ test 99, tainted($foo = $bar);
+ test 100, tainted($bar = $bar);
+ test 101, tainted($bar += $bar);
+ test 102, tainted($bar -= $bar);
+ test 103, tainted($bar *= $bar);
+ test 104, tainted($bar++);
+ test 105, tainted($bar /= $bar);
+ test 106, tainted($bar += 0);
+ test 107, tainted($bar -= 2);
+ test 108, tainted($bar *= -1);
+ test 109, tainted($bar /= 1);
+ test 110, tainted($bar--);
+ test 111, $bar == 0;
+}
+
+# Test assignment and return of lists
+{
+ my @foo = ("A", "tainted" . $TAINT, "B");
+ test 112, not tainted $foo[0];
+ test 113, tainted $foo[1];
+ test 114, not tainted $foo[2];
+ my @bar = @foo;
+ test 115, not tainted $bar[0];
+ test 116, tainted $bar[1];
+ test 117, not tainted $bar[2];
+ my @baz = eval { "A", "tainted" . $TAINT, "B" };
+ test 118, not tainted $baz[0];
+ test 119, tainted $baz[1];
+ test 120, not tainted $baz[2];
+ my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ];
+ test 121, not tainted $plugh[0];
+ test 122, tainted $plugh[1];
+ test 123, not tainted $plugh[2];
+ my $nautilus = sub { "A", "tainted" . $TAINT, "B" };
+ test 124, not tainted ((&$nautilus)[0]);
+ test 125, tainted ((&$nautilus)[1]);
+ test 126, not tainted ((&$nautilus)[2]);
+ my @xyzzy = &$nautilus;
+ test 127, not tainted $xyzzy[0];
+ test 128, tainted $xyzzy[1];
+ test 129, not tainted $xyzzy[2];
+ my $red_october = sub { return "A", "tainted" . $TAINT, "B" };
+ test 130, not tainted ((&$red_october)[0]);
+ test 131, tainted ((&$red_october)[1]);
+ test 132, not tainted ((&$red_october)[2]);
+ my @corge = &$red_october;
+ test 133, not tainted $corge[0];
+ test 134, tainted $corge[1];
+ test 135, 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 136,( 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 {
+ print "# getpwent() is not available\n";
+ print "ok 136\n";
+ }
+
+ if ($Config{d_readdir}) { # pretty hard to imagine not
+ local(*D);
+ opendir(D, "op") or die "opendir: $!\n";
+ my $readdir = readdir(D);
+ test 137, tainted $readdir;
+ closedir(OP);
+ } else {
+ print "# readdir() is not available\n";
+ print "ok 137\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 138, tainted $readlink;
+ unlink($symlink);
+ } else {
+ print "# readlink() or symlink() is not available\n";
+ print "ok 138\n";
+ }
+}
+
+# test bitwise ops (regression bug)
+{
+ my $why = "y";
+ my $j = "x" | $why;
+ test 139, not tainted $j;
+ $why = $TAINT."y";
+ $j = "x" | $why;
+ test 140, tainted $j;
+}
+
diff --git a/gnu/usr.bin/perl/t/op/tie.t b/gnu/usr.bin/perl/t/op/tie.t
new file mode 100644
index 00000000000..77e74db4e2c
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/op/universal.t b/gnu/usr.bin/perl/t/op/universal.t
new file mode 100644
index 00000000000..bd6c73afe99
--- /dev/null
+++ b/gnu/usr.bin/perl/t/op/universal.t
@@ -0,0 +1,96 @@
+#!./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::;
+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
+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/gnu/usr.bin/perl/t/op/write.t b/gnu/usr.bin/perl/t/op/write.t
index d14cef3cd64..705fa7977b3 100644
--- a/gnu/usr.bin/perl/t/op/write.t
+++ b/gnu/usr.bin/perl/t/op/write.t
@@ -2,7 +2,9 @@
# $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $
-print "1..3\n";
+print "1..5\n";
+
+my $CAT = ($^O eq 'MSWin32') ? 'type' : 'cat';
format OUT =
the quick brown @<<
@@ -42,7 +44,7 @@ the course
of huma...
now is the time for all good men to come to\n";
-if (`cat Op_write.tmp` eq $right)
+if (`$CAT Op_write.tmp` eq $right)
{ print "ok 1\n"; unlink 'Op_write.tmp'; }
else
{ print "not ok 1\n"; }
@@ -84,7 +86,7 @@ becomes
necessary
now is the time for all good men to come to\n";
-if (`cat Op_write.tmp` eq $right)
+if (`$CAT Op_write.tmp` eq $right)
{ print "ok 2\n"; unlink 'Op_write.tmp'; }
else
{ print "not ok 2\n"; }
@@ -128,8 +130,40 @@ becomes
necessary
now is the time for all good men to come to\n";
-if (`cat Op_write.tmp` eq $right)
+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/gnu/usr.bin/perl/t/pragma/constant.t b/gnu/usr.bin/perl/t/pragma/constant.t
new file mode 100644
index 00000000000..0095f3b627b
--- /dev/null
+++ b/gnu/usr.bin/perl/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', "\x45", chr 70;
+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/gnu/usr.bin/perl/t/pragma/locale.t b/gnu/usr.bin/perl/t/pragma/locale.t
new file mode 100644
index 00000000000..8e296db8a7c
--- /dev/null
+++ b/gnu/usr.bin/perl/t/pragma/locale.t
@@ -0,0 +1,475 @@
+#!./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++;
+};
+
+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 (length(@English) > length(@Locale));
+($Locale, @Locale) = ($German, @German)
+ if (length(@German) > length(@Locale));
+($Locale, @Locale) = ($French, @French)
+ if (length(@French) > length(@Locale));
+($Locale, @Locale) = ($Spanish, @Spanish)
+ if (length(@Spanish) > length(@Locale));
+
+print "# Locale = $Locale\n";
+print "# Alnum_ = @Locale\n";
+
+{
+ local $^W = 0;
+ setlocale(&LC_ALL, $Locale);
+}
+
+{
+ 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/gnu/usr.bin/perl/t/op/overload.t b/gnu/usr.bin/perl/t/pragma/overload.t
index 183cb273f70..42d045741de 100644
--- a/gnu/usr.bin/perl/t/op/overload.t
+++ b/gnu/usr.bin/perl/t/pragma/overload.t
@@ -1,9 +1,12 @@
#!./perl
-BEGIN { unshift @INC, './lib', '../lib';
- require Config; import Config;
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
}
+use Config;
+
package Oscalar;
use overload (
# Anonymous subroutines:
@@ -30,7 +33,7 @@ qw(
sub new {
my $foo = $_[1];
- bless \$foo;
+ bless \$foo, $_[0];
}
sub stringify { "${$_[0]}" }
@@ -52,7 +55,9 @@ $a = new Oscalar "087";
$b= "$a";
# All test numbers in comments are off by 1.
-# So much for hard-wiring them in :-)
+# 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
@@ -252,16 +257,107 @@ $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._"); # 89
+test ("b${a}" eq "_.b.__.xx._"); # 93
$x="1";
bless \$x, Oscalar;
-test ("b${a}c" eq "bxxc"); # 90
+test ("b${a}c" eq "bxxc"); # 94
new Oscalar 1;
-test ("b${a}c" eq "bxxc"); # 91
+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
-# Last test is number 90.
-sub last {90}
+# Last test is:
+sub last {115}
diff --git a/gnu/usr.bin/perl/t/pragma/strict-refs b/gnu/usr.bin/perl/t/pragma/strict-refs
new file mode 100644
index 00000000000..7bf1556e10a
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/pragma/strict-subs b/gnu/usr.bin/perl/t/pragma/strict-subs
new file mode 100644
index 00000000000..43fce712d57
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/pragma/strict-vars b/gnu/usr.bin/perl/t/pragma/strict-vars
new file mode 100644
index 00000000000..7ca9843c2c0
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/pragma/strict.t b/gnu/usr.bin/perl/t/pragma/strict.t
new file mode 100644
index 00000000000..fc3282089fa
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/pragma/subs.t b/gnu/usr.bin/perl/t/pragma/subs.t
new file mode 100644
index 00000000000..056c4bd7cf4
--- /dev/null
+++ b/gnu/usr.bin/perl/t/pragma/subs.t
@@ -0,0 +1,132 @@
+#!./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
+ $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/gnu/usr.bin/perl/t/pragma/warn-1global b/gnu/usr.bin/perl/t/pragma/warn-1global
new file mode 100644
index 00000000000..33252731b0e
--- /dev/null
+++ b/gnu/usr.bin/perl/t/pragma/warn-1global
@@ -0,0 +1,146 @@
+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.
diff --git a/gnu/usr.bin/perl/t/pragma/warning.t b/gnu/usr.bin/perl/t/pragma/warning.t
new file mode 100644
index 00000000000..fa0301ea6a6
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/t/re_tests b/gnu/usr.bin/perl/t/re_tests
deleted file mode 100644
index 2ac666ab382..00000000000
--- a/gnu/usr.bin/perl/t/re_tests
+++ /dev/null
@@ -1,3 +0,0 @@
-a.+?c abcabc y $& abc
-(a+|b)* ab y $&-$1 ab-b
-(a+|b){0,} ab y $&-$1 ab-b
diff --git a/gnu/usr.bin/perl/taint.c b/gnu/usr.bin/perl/taint.c
index 6c64b39fc77..6776272782c 100644
--- a/gnu/usr.bin/perl/taint.c
+++ b/gnu/usr.bin/perl/taint.c
@@ -8,37 +8,26 @@
#include "perl.h"
void
-taint_not(s)
-char *s;
-{
- if (euid != uid)
- croak("No %s allowed while running setuid", s);
- if (egid != gid)
- croak("No %s allowed while running setgid", s);
-}
-
-void
taint_proper(f, s)
-char *f;
+const char *f;
char *s;
{
- if (tainting) {
- DEBUG_u(fprintf(stderr,"%s %d %d %d\n",s,tainted,uid, euid));
- if (tainted) {
- char *ug = 0;
- if (euid != uid)
- ug = " while running setuid";
- else if (egid != gid)
- ug = " while running setgid";
- else if (tainting)
- ug = " while running with -T switch";
- if (ug) {
- if (!unsafe)
- croak(f, s, ug);
- else if (dowarn)
- warn(f, s, ug);
- }
- }
+ char *ug;
+
+ DEBUG_u(PerlIO_printf(Perl_debug_log,
+ "%s %d %d %d\n", s, tainted, uid, euid));
+
+ if (tainted) {
+ if (euid != uid)
+ ug = " while running setuid";
+ else if (egid != gid)
+ ug = " while running setgid";
+ else
+ ug = " while running with -T switch";
+ if (!unsafe)
+ croak(f, s, ug);
+ else if (dowarn)
+ warn(f, s, ug);
}
}
@@ -46,26 +35,74 @@ void
taint_env()
{
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
+ };
- if (tainting) {
- MAGIC *mg = 0;
- svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE);
- if (!svp || *svp == &sv_undef ||
- ((mg = mg_find(*svp, 't')) && mg->mg_len & 1))
- {
- tainted = TRUE;
- if (mg && MgTAINTEDDIR(mg))
- taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
- else
- taint_proper("Insecure %s%s", "$ENV{PATH}");
+#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(envgv), name, strlen(name), FALSE);
+ if (!svp || *svp == &sv_undef)
+ break;
+ if (SvTAINTED(*svp)) {
+ TAINT;
+ taint_proper("Insecure %s%s", "$ENV{DCL$PATH}");
}
- svp = hv_fetch(GvHVn(envgv),"IFS",3,FALSE);
- if (svp && *svp != &sv_undef &&
- (mg = mg_find(*svp, 't')) && mg->mg_len & 1)
- {
- tainted = TRUE;
- taint_proper("Insecure %s%s", "$ENV{IFS}");
+ if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
+ TAINT;
+ taint_proper("Insecure directory in %s%s", "$ENV{DCL$PATH}");
}
+ i++;
}
-}
+#endif /* VMS */
+ svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE);
+ if (svp && *svp) {
+ if (SvTAINTED(*svp)) {
+ TAINT;
+ taint_proper("Insecure %s%s", "$ENV{PATH}");
+ }
+ if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) {
+ TAINT;
+ taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
+ }
+ }
+
+#ifndef VMS
+ /* tainted $TERM is okay if it contains no metachars */
+ svp = hv_fetch(GvHVn(envgv),"TERM",4,FALSE);
+ if (svp && *svp && SvTAINTED(*svp)) {
+ bool was_tainted = tainted;
+ char *t = SvPV(*svp, na);
+ char *e = t + na;
+ 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(envgv), *e, strlen(*e), FALSE);
+ if (svp && *svp != &sv_undef && SvTAINTED(*svp)) {
+ TAINT;
+ taint_proper("Insecure $ENV{%s}%s", *e);
+ }
+ }
+}
diff --git a/gnu/usr.bin/perl/toke.c b/gnu/usr.bin/perl/toke.c
index 5a43c097b5c..b2e8aac6d3e 100644
--- a/gnu/usr.bin/perl/toke.c
+++ b/gnu/usr.bin/perl/toke.c
@@ -1,6 +1,6 @@
/* toke.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -16,18 +16,21 @@
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 *q _((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, I32 ck_uni));
+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));
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, int allow_package, STRLEN *slp));
+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));
@@ -39,27 +42,43 @@ 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, FILE *fp));
+static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
static void restore_rsfp _((void *f));
+static char ident_too_long[] = "Identifier too long";
+
+static char *linestart; /* beg. of most recently read line */
+
+static char pending_ident; /* pending identifier lookup */
+
+static struct {
+ I32 super_state; /* lexer state to save */
+ I32 sub_inwhat; /* "lex_inwhat" to use */
+ OP *sub_op; /* "lex_op" to use */
+} sublex_info;
+
/* 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_NORMAL 9
-#define LEX_INTERPNORMAL 8
-#define LEX_INTERPCASEMOD 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
+/* #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>
@@ -68,6 +87,12 @@ static void restore_rsfp _((void *f));
#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
@@ -138,12 +163,11 @@ no_op(what, s)
char *what;
char *s;
{
- char tmpbuf[128];
char *oldbp = bufptr;
- bool is_first = (oldbufptr == SvPVX(linestr));
+ bool is_first = (oldbufptr == linestart);
+
bufptr = s;
- sprintf(tmpbuf, "%s found where operator expected", what);
- yywarn(tmpbuf);
+ yywarn(form("%s found where operator expected", what));
if (is_first)
warn("\t(Missing semicolon on previous line?)\n");
else if (oldoldbufptr && isIDFIRST(*oldoldbufptr)) {
@@ -172,7 +196,7 @@ char *s;
}
else if (multi_close < 32 || multi_close == 127) {
*tmpbuf = '^';
- tmpbuf[1] = multi_close ^ 64;
+ tmpbuf[1] = toCTRL(multi_close);
s = "\\n";
tmpbuf[2] = '\0';
s = tmpbuf;
@@ -207,19 +231,20 @@ SV *line;
char *s;
STRLEN len;
- SAVEINT(lex_dojoin);
- SAVEINT(lex_brackets);
- SAVEINT(lex_fakebrack);
- SAVEINT(lex_casemods);
- SAVEINT(lex_starts);
- SAVEINT(lex_state);
+ SAVEI32(lex_dojoin);
+ SAVEI32(lex_brackets);
+ SAVEI32(lex_fakebrack);
+ SAVEI32(lex_casemods);
+ SAVEI32(lex_starts);
+ SAVEI32(lex_state);
SAVESPTR(lex_inpat);
- SAVEINT(lex_inwhat);
- SAVEINT(curcop->cop_line);
+ SAVEI32(lex_inwhat);
+ SAVEI16(curcop->cop_line);
SAVEPPTR(bufptr);
SAVEPPTR(bufend);
SAVEPPTR(oldbufptr);
SAVEPPTR(oldoldbufptr);
+ SAVEPPTR(linestart);
SAVESPTR(linestr);
SAVEPPTR(lex_brackstack);
SAVEPPTR(lex_casestack);
@@ -256,7 +281,7 @@ SV *line;
sv_catpvn(linestr, "\n;", 2);
}
SvTEMP_off(linestr);
- oldoldbufptr = oldbufptr = bufptr = SvPVX(linestr);
+ oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
bufend = bufptr + SvCUR(linestr);
SvREFCNT_dec(rs);
rs = newSVpv("\n", 1);
@@ -266,18 +291,19 @@ SV *line;
void
lex_end()
{
+ doextract = FALSE;
}
static void
restore_rsfp(f)
void *f;
{
- FILE *fp = (FILE*)f;
+ PerlIO *fp = (PerlIO*)f;
- if (rsfp == stdin)
- clearerr(rsfp);
+ if (rsfp == PerlIO_stdin())
+ PerlIO_clearerr(rsfp);
else if (rsfp && (rsfp != fp))
- fclose(rsfp);
+ PerlIO_close(rsfp);
rsfp = fp;
}
@@ -332,6 +358,7 @@ register char *s;
return s;
}
for (;;) {
+ STRLEN prevlen;
while (s < bufend && isSPACE(*s))
s++;
if (s < bufend && *s == '#') {
@@ -342,33 +369,38 @@ register char *s;
}
if (s < bufend || !rsfp || lex_state != LEX_NORMAL)
return s;
- if ((s = filter_gets(linestr, rsfp)) == Nullch) {
+ if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) {
if (minus_n || minus_p) {
- sv_setpv(linestr,minus_p ? ";}continue{print" : "");
+ sv_setpv(linestr,minus_p ?
+ ";}continue{print or die qq(-p destination: $!\\n)" :
+ "");
sv_catpv(linestr,";}");
minus_n = minus_p = 0;
}
else
sv_setpv(linestr,";");
- oldoldbufptr = oldbufptr = bufptr = s = SvPVX(linestr);
+ oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
bufend = SvPVX(linestr) + SvCUR(linestr);
if (preprocess && !in_eval)
(void)my_pclose(rsfp);
- else if ((FILE*)rsfp == stdin)
- clearerr(stdin);
+ else if ((PerlIO*)rsfp == PerlIO_stdin())
+ PerlIO_clearerr(rsfp);
else
- (void)fclose(rsfp);
+ (void)PerlIO_close(rsfp);
+ if (e_fp == rsfp)
+ e_fp = Nullfp;
rsfp = Nullfp;
return s;
}
- oldoldbufptr = oldbufptr = bufptr = s;
- bufend = bufptr + SvCUR(linestr);
+ linestart = bufptr = s + prevlen;
+ bufend = s + SvCUR(linestr);
+ s = bufptr;
incline(s);
- if (perldb && curstash != debstash) {
+ if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(85,0);
sv_upgrade(sv, SVt_PVMG);
- sv_setsv(sv,linestr);
+ sv_setpvn(sv,bufptr,bufend-bufptr);
av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv);
}
}
@@ -422,10 +454,15 @@ char *s;
#define LOP(f,x) return lop(f,x,s)
static I32
-lop(f,x,s)
+lop
+#ifdef CAN_PROTOTYPE
+ (I32 f, expectation x, char *s)
+#else
+ (f,x,s)
I32 f;
expectation x;
char *s;
+#endif /* CAN_PROTOTYPE */
{
yylval.ival = f;
CLINE;
@@ -474,7 +511,7 @@ int allow_tick;
(allow_pack && *s == ':') ||
(allow_tick && *s == '\'') )
{
- s = scan_word(s, tokenbuf, allow_pack, &len);
+ s = scan_word(s, tokenbuf, sizeof tokenbuf, allow_pack, &len);
if (check_keyword && keyword(tokenbuf, len))
return start;
if (token == METHOD) {
@@ -505,7 +542,10 @@ int kind;
force_next(WORD);
if (kind) {
op->op_private = OPpCONST_ENTERED;
- gv_fetchpv(s, TRUE,
+ /* 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, in_eval ? GV_ADDMULTI : TRUE,
kind == '$' ? SVt_PV :
kind == '@' ? SVt_PVAV :
kind == '%' ? SVt_PVHV :
@@ -515,6 +555,34 @@ int kind;
}
}
+static char *
+force_version(s)
+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 */
+ nextval[nexttoke].opval = version;
+ force_next(WORD);
+
+ return (s);
+}
+
static SV *
q(sv)
SV *sv;
@@ -560,24 +628,49 @@ sublex_start()
return THING;
}
if (op_type == OP_CONST || op_type == OP_READLINE) {
- yylval.opval = (OP*)newSVOP(op_type, 0, q(lex_stuff));
+ SV *sv = q(lex_stuff);
+ STRLEN len;
+ char *p = SvPV(sv, len);
+ yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len));
+ SvREFCNT_dec(sv);
lex_stuff = Nullsv;
return THING;
}
+ sublex_info.super_state = lex_state;
+ sublex_info.sub_inwhat = op_type;
+ sublex_info.sub_op = lex_op;
+ lex_state = LEX_INTERPPUSH;
+
+ expect = XTERM;
+ if (lex_op) {
+ yylval.opval = lex_op;
+ lex_op = Nullop;
+ return PMFUNC;
+ }
+ else
+ return FUNC;
+}
+
+static I32
+sublex_push()
+{
push_scope();
- SAVEINT(lex_dojoin);
- SAVEINT(lex_brackets);
- SAVEINT(lex_fakebrack);
- SAVEINT(lex_casemods);
- SAVEINT(lex_starts);
- SAVEINT(lex_state);
+
+ lex_state = sublex_info.super_state;
+ SAVEI32(lex_dojoin);
+ SAVEI32(lex_brackets);
+ SAVEI32(lex_fakebrack);
+ SAVEI32(lex_casemods);
+ SAVEI32(lex_starts);
+ SAVEI32(lex_state);
SAVESPTR(lex_inpat);
- SAVEINT(lex_inwhat);
- SAVEINT(curcop->cop_line);
+ SAVEI32(lex_inwhat);
+ SAVEI16(curcop->cop_line);
SAVEPPTR(bufptr);
SAVEPPTR(oldbufptr);
SAVEPPTR(oldoldbufptr);
+ SAVEPPTR(linestart);
SAVESPTR(linestr);
SAVEPPTR(lex_brackstack);
SAVEPPTR(lex_casestack);
@@ -585,7 +678,7 @@ sublex_start()
linestr = lex_stuff;
lex_stuff = Nullsv;
- bufend = bufptr = oldbufptr = oldoldbufptr = SvPVX(linestr);
+ bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
bufend += SvCUR(linestr);
SAVEFREESV(linestr);
@@ -602,21 +695,13 @@ sublex_start()
lex_state = LEX_INTERPCONCAT;
curcop->cop_line = multi_start;
- lex_inwhat = op_type;
- if (op_type == OP_MATCH || op_type == OP_SUBST)
- lex_inpat = lex_op;
+ lex_inwhat = sublex_info.sub_inwhat;
+ if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST)
+ lex_inpat = sublex_info.sub_op;
else
- lex_inpat = 0;
+ lex_inpat = Nullop;
- expect = XTERM;
- force_next('(');
- if (lex_op) {
- yylval.opval = lex_op;
- lex_op = Nullop;
- return PMFUNC;
- }
- else
- return FUNC;
+ return '(';
}
static I32
@@ -637,7 +722,7 @@ sublex_done()
if (lex_repl && (lex_inwhat == OP_SUBST || lex_inwhat == OP_TRANS)) {
linestr = lex_repl;
lex_inpat = 0;
- bufend = bufptr = oldbufptr = oldoldbufptr = SvPVX(linestr);
+ bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr);
bufend += SvCUR(linestr);
SAVEFREESV(linestr);
lex_dojoin = FALSE;
@@ -758,10 +843,8 @@ char *start;
continue;
case 'c':
s++;
- *d = *s++;
- if (isLOWER(*d))
- *d = toUPPER(*d);
- *d++ ^= 64;
+ len = *s++;
+ *d++ = toCTRL(len);
continue;
case 'b':
*d++ = '\b';
@@ -846,7 +929,7 @@ register char *s;
char seen[256];
unsigned char un_char = 0, last_un_char;
char *send = strchr(s,']');
- char tmpbuf[512];
+ char tmpbuf[sizeof tokenbuf * 4];
if (!send) /* has to be an expression */
return TRUE;
@@ -871,7 +954,7 @@ register char *s;
case '$':
weight -= seen[un_char] * 10;
if (isALNUM(s[1])) {
- scan_ident(s,send,tmpbuf,FALSE);
+ scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
weight -= 100;
else
@@ -941,17 +1024,17 @@ char *start;
GV *gv;
{
char *s = start + (*start == '$');
- char tmpbuf[1024];
+ char tmpbuf[sizeof tokenbuf];
STRLEN len;
GV* indirgv;
if (gv) {
if (GvIO(gv))
return 0;
- if (!GvCV(gv))
+ if (!GvCVu(gv))
gv = 0;
}
- s = scan_word(s, tmpbuf, TRUE, &len);
+ s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
if (*start == '$') {
if (gv || last_lop_op == OP_PRINT || isUPPER(*tokenbuf))
return 0;
@@ -962,11 +1045,13 @@ GV *gv;
}
if (!keyword(tmpbuf, len)) {
indirgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVCV);
- if (indirgv && GvCV(indirgv))
+ if (indirgv && GvCVu(indirgv))
return 0;
/* filehandle or package name makes it a method */
- if (!gv || GvIO(indirgv) || gv_stashpv(tmpbuf, FALSE)) {
+ if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
s = skipspace(s);
+ if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
+ return 0; /* no assumptions -- "=>" quotes bearword */
nextval[nexttoke].opval =
(OP*)newSVOP(OP_CONST, 0,
newSVpv(tmpbuf,0));
@@ -1029,7 +1114,7 @@ filter_add(funcp, datasv)
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 %lx (%s)", funcp, SvPV(datasv,na));
+ warn("filter_add func %p (%s)", funcp, SvPV(datasv,na));
av_unshift(rsfp_filters, 1);
av_store(rsfp_filters, 0, datasv) ;
return(datasv);
@@ -1042,7 +1127,7 @@ filter_del(funcp)
filter_t funcp;
{
if (filter_debug)
- warn("filter_del func %lx", funcp);
+ warn("filter_del func %p", funcp);
if (!rsfp_filters || AvFILL(rsfp_filters)<0)
return;
/* if filter is on top of stack (usual case) just pop it off */
@@ -1081,8 +1166,8 @@ filter_read(idx, buf_sv, maxlen)
/* ensure buf_sv is large enough */
SvGROW(buf_sv, old_len + maxlen) ;
- if ((len = fread(SvPVX(buf_sv) + old_len, 1, maxlen, rsfp)) <= 0){
- if (ferror(rsfp))
+ if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
+ if (PerlIO_error(rsfp))
return -1; /* error */
else
return 0 ; /* end of file */
@@ -1091,7 +1176,7 @@ filter_read(idx, buf_sv, maxlen)
} else {
/* Want a line */
if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) {
- if (ferror(rsfp))
+ if (PerlIO_error(rsfp))
return -1; /* error */
else
return 0 ; /* end of file */
@@ -1108,7 +1193,7 @@ filter_read(idx, buf_sv, maxlen)
/* Get function pointer hidden within datasv */
funcp = (filter_t)IoDIRP(datasv);
if (filter_debug)
- warn("filter_read %d: via function %lx (%s)\n",
+ warn("filter_read %d: via function %p (%s)\n",
idx, funcp, SvPV(datasv,na));
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
@@ -1117,20 +1202,22 @@ filter_read(idx, buf_sv, maxlen)
}
static char *
-filter_gets(sv,fp)
+filter_gets(sv,fp, append)
register SV *sv;
-register FILE *fp;
+register PerlIO *fp;
+STRLEN append;
{
if (rsfp_filters) {
- SvCUR_set(sv, 0); /* start with empty line */
+ 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, 0)) ;
+ return (sv_gets(sv, fp, append));
}
@@ -1140,7 +1227,7 @@ register FILE *fp;
{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
#endif
-extern int yychar; /* last token */
+EXT int yychar; /* last token */
int
yylex()
@@ -1150,6 +1237,57 @@ yylex()
register I32 tmp;
STRLEN len;
+ if (pending_ident) {
+ char pit = pending_ident;
+ pending_ident = 0;
+
+ if (in_my) {
+ if (strchr(tokenbuf,':'))
+ croak(no_myglob,tokenbuf);
+ yylval.opval = newOP(OP_PADANY, 0);
+ yylval.opval->op_targ = pad_allocmy(tokenbuf);
+ return PRIVATEREF;
+ }
+
+ if (!strchr(tokenbuf,':') && (tmp = pad_findmy(tokenbuf))) {
+ if (last_lop_op == OP_SORT &&
+ tokenbuf[0] == '$' &&
+ (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
+ && !tokenbuf[2])
+ {
+ for (d = in_eval ? oldoldbufptr : linestart;
+ d < bufend && *d != '\n';
+ d++)
+ {
+ if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
+ croak("Can't use \"my %s\" in sort comparison",
+ tokenbuf);
+ }
+ }
+ }
+
+ yylval.opval = newOP(OP_PADANY, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
+
+ /* Force them to make up their mind on "@foo". */
+ if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) {
+ GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV);
+ if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
+ yyerror(form("In string, %s now must be written as \\%s",
+ tokenbuf, tokenbuf));
+ }
+
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
+ yylval.opval->op_private = OPpCONST_ENTERED;
+ gv_fetchpv(tokenbuf+1, in_eval ? GV_ADDMULTI : TRUE,
+ ((tokenbuf[0] == '$') ? SVt_PV
+ : (tokenbuf[0] == '@') ? SVt_PVAV
+ : SVt_PVHV));
+ return WORD;
+ }
+
switch (lex_state) {
#ifdef COMMENTARY
case LEX_NORMAL: /* Some compilers will produce faster */
@@ -1199,7 +1337,7 @@ yylex()
return ')';
}
if (lex_casemods > 10) {
- char* newlb = (char*)realloc(lex_casestack, lex_casemods + 2);
+ char* newlb = Renew(lex_casestack, lex_casemods + 2, char);
if (newlb != lex_casestack) {
SAVEFREEPV(newlb);
lex_casestack = newlb;
@@ -1233,6 +1371,9 @@ yylex()
return yylex();
}
+ case LEX_INTERPPUSH:
+ return sublex_push();
+
case LEX_INTERPSTART:
if (bufptr == bufend)
return sublex_done();
@@ -1254,9 +1395,7 @@ yylex()
s = bufptr;
Aop(OP_CONCAT);
}
- else
- return yylex();
- break;
+ return yylex();
case LEX_INTERPENDMAYBE:
if (intuit_more(bufptr)) {
@@ -1320,19 +1459,20 @@ yylex()
oldoldbufptr = oldbufptr;
oldbufptr = s;
DEBUG_p( {
- fprintf(stderr,"### Tokener expecting %s at %s\n", exp_name[expect], s);
+ PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s);
} )
retry:
switch (*s) {
default:
- warn("Unrecognized character \\%03o ignored", *s++ & 255);
- goto retry;
+ croak("Unrecognized character \\%03o", *s & 255);
case 4:
case 26:
goto fake_eof; /* emulate EOF on ^D or ^Z */
case 0:
if (!rsfp) {
+ last_uni = 0;
+ last_lop = 0;
if (lex_brackets)
yyerror("Missing right bracket");
TOKEN(0);
@@ -1360,25 +1500,37 @@ yylex()
sv_catpv(linestr, "LINE: while (<>) {");
if (minus_l)
sv_catpv(linestr,"chomp;");
- if (minus_a){
- if (minus_F){
- char tmpbuf1[50];
- if ( splitstr[0] == '/' ||
- splitstr[0] == '\'' ||
- splitstr[0] == '"' )
- sprintf( tmpbuf1, "@F=split(%s);", splitstr );
- else
- sprintf( tmpbuf1, "@F=split('%s');", splitstr );
- sv_catpv(linestr,tmpbuf1);
+ if (minus_a) {
+ GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
+ if (gv)
+ GvIMPORTED_AV_on(gv);
+ if (minus_F) {
+ if (strchr("/'\"", *splitstr)
+ && strchr(splitstr + 1, *splitstr))
+ sv_catpvf(linestr, "@F=split(%s);", splitstr);
+ else {
+ char delim;
+ s = "'~#\200\1'"; /* surely one char is unused...*/
+ while (s[1] && strchr(splitstr, *s)) s++;
+ delim = *s;
+ sv_catpvf(linestr, "@F=split(%s%c",
+ "q" + (delim == '\''), delim);
+ for (s = splitstr; *s; s++) {
+ if (*s == '\\')
+ sv_catpvn(linestr, "\\", 1);
+ sv_catpvn(linestr, s, 1);
+ }
+ sv_catpvf(linestr, "%c);", delim);
+ }
}
else
sv_catpv(linestr,"@F=split(' ');");
}
}
sv_catpv(linestr, "\n");
- oldoldbufptr = oldbufptr = s = SvPVX(linestr);
+ oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
bufend = SvPVX(linestr) + SvCUR(linestr);
- if (perldb && curstash != debstash) {
+ if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(85,0);
sv_upgrade(sv, SVt_PVMG);
@@ -1388,26 +1540,28 @@ yylex()
goto retry;
}
do {
- if ((s = filter_gets(linestr, rsfp)) == Nullch) {
+ if ((s = filter_gets(linestr, rsfp, 0)) == Nullch) {
fake_eof:
if (rsfp) {
if (preprocess && !in_eval)
(void)my_pclose(rsfp);
- else if ((FILE*)rsfp == stdin)
- clearerr(stdin);
+ else if ((PerlIO *)rsfp == PerlIO_stdin())
+ PerlIO_clearerr(rsfp);
else
- (void)fclose(rsfp);
+ (void)PerlIO_close(rsfp);
+ if (e_fp == rsfp)
+ e_fp = Nullfp;
rsfp = Nullfp;
}
if (!in_eval && (minus_n || minus_p)) {
sv_setpv(linestr,minus_p ? ";}continue{print" : "");
sv_catpv(linestr,";}");
- oldoldbufptr = oldbufptr = s = SvPVX(linestr);
+ oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
bufend = SvPVX(linestr) + SvCUR(linestr);
minus_n = minus_p = 0;
goto retry;
}
- oldoldbufptr = oldbufptr = s = SvPVX(linestr);
+ oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
sv_setpv(linestr,"");
TOKEN(';'); /* not infinite loop because rsfp is NULL now */
}
@@ -1418,15 +1572,15 @@ yylex()
/* Incest with pod. */
if (*s == '=' && strnEQ(s, "=cut", 4)) {
sv_setpv(linestr, "");
- oldoldbufptr = oldbufptr = s = SvPVX(linestr);
+ oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
bufend = SvPVX(linestr) + SvCUR(linestr);
doextract = FALSE;
}
}
incline(s);
} while (doextract);
- oldoldbufptr = oldbufptr = bufptr = s;
- if (perldb && curstash != debstash) {
+ oldoldbufptr = oldbufptr = bufptr = linestart = s;
+ if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(85,0);
sv_upgrade(sv, SVt_PVMG);
@@ -1439,25 +1593,84 @@ yylex()
s++;
if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
s++;
- if (!in_eval && *s == '#' && s[1] == '!') {
+ d = Nullch;
+ if (!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(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 &&
!minus_c &&
!instr(s,"indir") &&
instr(origargv[0],"perl"))
{
char **newargv;
- char *cmd;
- s += 2;
- if (*s == ' ')
- s++;
- cmd = s;
- while (s < bufend && !isSPACE(*s))
- s++;
- *s++ = '\0';
+ *ipathend = '\0';
+ s = ipathend + 1;
while (s < bufend && isSPACE(*s))
s++;
if (s < bufend) {
@@ -1470,30 +1683,38 @@ yylex()
}
else
newargv = origargv;
- newargv[0] = cmd;
- execv(cmd,newargv);
- croak("Can't exec %s", cmd);
+ newargv[0] = ipath;
+ execv(ipath, newargv);
+ croak("Can't exec %s", ipath);
}
if (d) {
- int oldpdb = perldb;
- int oldn = minus_n;
- int oldp = minus_p;
+ U32 oldpdb = perldb;
+ bool oldn = minus_n;
+ bool oldp = minus_p;
while (*d && !isSPACE(*d)) d++;
- while (*d == ' ') d++;
+ while (*d == ' ' || *d == '\t') d++;
if (*d++ == '-') {
- while (d = moreswitches(d)) ;
- if (perldb && !oldpdb ||
+ 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 ||
( minus_n || minus_p ) && !(oldn || oldp) )
/* if we have already added "LINE: while (<>) {",
we must not do it again */
{
sv_setpv(linestr, "");
- oldoldbufptr = oldbufptr = s = SvPVX(linestr);
+ oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
bufend = SvPVX(linestr) + SvCUR(linestr);
preambled = FALSE;
- if (perldb)
+ if (PERLDB_LINE)
(void)gv_fetchfile(origfilename);
goto retry;
}
@@ -1507,7 +1728,11 @@ yylex()
return yylex();
}
goto retry;
- case ' ': case '\t': case '\f': case '\r': case 013:
+ case '\r':
+ warn("Illegal character \\%03o (carriage return)", '\r');
+ croak(
+ "(Maybe you didn't strip carriage returns after a network transfer?)\n");
+ case ' ': case '\t': case '\f': case 013:
s++;
goto retry;
case '#':
@@ -1542,7 +1767,7 @@ yylex()
if (strnEQ(s,"=>",2)) {
if (dowarn)
warn("Ambiguous use of -%c => resolved to \"-%c\" =>",
- tmp, tmp);
+ (int)tmp, (int)tmp);
s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
OPERATOR('-'); /* unary minus */
}
@@ -1577,7 +1802,7 @@ yylex()
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", tmp);
+ croak("Unrecognized file test: -%c", (int)tmp);
break;
}
}
@@ -1628,7 +1853,7 @@ yylex()
case '*':
if (expect != XOPERATOR) {
- s = scan_ident(s, bufend, tokenbuf, TRUE);
+ s = scan_ident(s, bufend, tokenbuf, sizeof tokenbuf, TRUE);
expect = XOPERATOR;
force_ident(tokenbuf, '*');
if (!*tokenbuf)
@@ -1643,35 +1868,19 @@ yylex()
Mop(OP_MULTIPLY);
case '%':
- if (expect != XOPERATOR) {
- s = scan_ident(s, bufend, tokenbuf + 1, TRUE);
- if (tokenbuf[1]) {
- expect = XOPERATOR;
- tokenbuf[0] = '%';
- if (in_my) {
- if (strchr(tokenbuf,':'))
- croak(no_myglob,tokenbuf);
- nextval[nexttoke].opval = newOP(OP_PADANY, 0);
- nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf);
- force_next(PRIVATEREF);
- TERM('%');
- }
- if (!strchr(tokenbuf,':')) {
- if (tmp = pad_findmy(tokenbuf)) {
- nextval[nexttoke].opval = newOP(OP_PADANY, 0);
- nextval[nexttoke].opval->op_targ = tmp;
- force_next(PRIVATEREF);
- TERM('%');
- }
- }
- force_ident(tokenbuf + 1, *tokenbuf);
- }
- else
- PREREF('%');
- TERM('%');
+ if (expect == XOPERATOR) {
+ ++s;
+ Mop(OP_MODULO);
+ }
+ tokenbuf[0] = '%';
+ s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, TRUE);
+ if (!tokenbuf[1]) {
+ if (s == bufend)
+ yyerror("Final % should be \\% or %name");
+ PREREF('%');
}
- ++s;
- Mop(OP_MODULO);
+ pending_ident = '%';
+ TERM('%');
case '^':
s++;
@@ -1725,7 +1934,7 @@ yylex()
leftbracket:
s++;
if (lex_brackets > 100) {
- char* newlb = (char*)realloc(lex_brackstack, lex_brackets + 1);
+ char* newlb = Renew(lex_brackstack, lex_brackets + 1, char);
if (newlb != lex_brackstack) {
SAVEFREEPV(newlb);
lex_brackstack = newlb;
@@ -1742,21 +1951,33 @@ yylex()
else
lex_brackstack[lex_brackets++] = XOPERATOR;
OPERATOR(HASHBRACK);
- break;
case XOPERATOR:
while (s < bufend && (*s == ' ' || *s == '\t'))
s++;
- if (s < bufend && isALPHA(*s)) {
- d = scan_word(s, tokenbuf, FALSE, &len);
+ d = s;
+ tokenbuf[0] = '\0';
+ if (d < bufend && *d == '-') {
+ tokenbuf[0] = '-';
+ d++;
+ while (d < bufend && (*d == ' ' || *d == '\t'))
+ d++;
+ }
+ if (d < bufend && isIDFIRST(*d)) {
+ d = scan_word(d, tokenbuf + 1, sizeof tokenbuf - 1,
+ FALSE, &len);
while (d < bufend && (*d == ' ' || *d == '\t'))
d++;
if (*d == '}') {
+ char minus = (tokenbuf[0] == '-');
if (dowarn &&
- (keyword(tokenbuf, len) ||
- perl_get_cv(tokenbuf, FALSE) ))
+ (keyword(tokenbuf + 1, len) ||
+ (minus && len == 1 && isALPHA(tokenbuf[1])) ||
+ perl_get_cv(tokenbuf + 1, FALSE) ))
warn("Ambiguous use of {%s} resolved to {\"%s\"}",
- tokenbuf, tokenbuf);
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ tokenbuf + !minus, tokenbuf + !minus);
+ s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
+ if (minus)
+ force_next('-');
}
}
/* FALL THROUGH */
@@ -1777,19 +1998,73 @@ yylex()
s = skipspace(s);
if (*s == '}')
OPERATOR(HASHBRACK);
- if (isALPHA(*s)) {
- for (t = s; t < bufend && isALNUM(*t); t++) ;
+ /* 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 < bufend && *t != *s;)
+ if (*t++ == '\\' && (*t == '\\' || *t == *s))
+ t++;
+ t++;
}
- else if (*s == '\'' || *s == '"') {
- t = strchr(s+1,*s);
- if (!t++)
- t = s;
+ else if (*s == 'q') {
+ if (++t < bufend
+ && (!isALNUM(*t)
+ || ((*t == 'q' || *t == 'x') && ++t < bufend
+ && !isALNUM(*t)))) {
+ char *tmps;
+ char open, close, term;
+ I32 brackets = 1;
+
+ while (t < bufend && isSPACE(*t))
+ t++;
+ term = *t;
+ open = term;
+ if (term && (tmps = strchr("([{< )]}> )]}>",term)))
+ term = tmps[5];
+ close = term;
+ if (open == close)
+ for (t++; t < bufend; t++) {
+ if (*t == '\\' && t+1 < bufend && open != '\\')
+ t++;
+ else if (*t == open)
+ break;
+ }
+ else
+ for (t++; t < bufend; t++) {
+ if (*t == '\\' && t+1 < bufend)
+ t++;
+ else if (*t == close && --brackets <= 0)
+ break;
+ else if (*t == open)
+ brackets++;
+ }
+ }
+ t++;
+ }
+ else if (isALPHA(*s)) {
+ for (t++; t < bufend && isALNUM(*t); t++) ;
}
- else
- t = s;
while (t < bufend && isSPACE(*t))
t++;
- if ((*t == ',' && !isLOWER(*s)) || (*t == '=' && t[1] == '>'))
+ /* if comma follows first term, call it an anon hash */
+ /* XXX it could be a comma expression with loop modifiers */
+ if (t < bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
+ || (*t == '=' && t[1] == '>')))
OPERATOR(HASHBRACK);
if (expect == XREF)
expect = XTERM;
@@ -1820,7 +2095,9 @@ yylex()
bufptr = s;
return yylex(); /* ignore fake brackets */
}
- if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
+ if (*s == '-' && s[1] == '>')
+ lex_state = LEX_INTERPENDMAYBE;
+ else if (*s != '[' && *s != '{')
lex_state = LEX_INTERPEND;
}
}
@@ -1838,7 +2115,7 @@ yylex()
AOPERATOR(ANDAND);
s--;
if (expect == XOPERATOR) {
- if (dowarn && isALPHA(*s) && bufptr == SvPVX(linestr)) {
+ if (dowarn && isALPHA(*s) && bufptr == linestart) {
curcop->cop_line--;
warn(warn_nosemi);
curcop->cop_line++;
@@ -1846,7 +2123,7 @@ yylex()
BAop(OP_BIT_AND);
}
- s = scan_ident(s-1, bufend, tokenbuf, TRUE);
+ s = scan_ident(s - 1, bufend, tokenbuf, sizeof tokenbuf, TRUE);
if (*tokenbuf) {
expect = XOPERATOR;
force_ident(tokenbuf, '&');
@@ -1873,10 +2150,10 @@ yylex()
if (tmp == '~')
PMop(OP_MATCH);
if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
- warn("Reversed %c= operator",tmp);
+ warn("Reversed %c= operator",(int)tmp);
s--;
if (expect == XSTATE && isALPHA(tmp) &&
- (s == SvPVX(linestr)+1 || s[-2] == '\n') )
+ (s == linestart+1 || s[-2] == '\n') )
{
if (in_eval && !rsfp) {
d = bufend;
@@ -1954,184 +2231,147 @@ yylex()
Rop(OP_GT);
case '$':
- if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
- s = scan_ident(s+1, bufend, tokenbuf+1, FALSE);
- if (expect == XOPERATOR) {
- if (lex_formbrack && lex_brackets == lex_formbrack) {
- expect = XTERM;
- depcom();
- return ','; /* grandfather non-comma-format format */
- }
- else
- no_op("Array length",s);
- }
- else if (!tokenbuf[1])
- PREREF(DOLSHARP);
- if (!strchr(tokenbuf+1,':')) {
- tokenbuf[0] = '@';
- if (tmp = pad_findmy(tokenbuf)) {
- nextval[nexttoke].opval = newOP(OP_PADANY, 0);
- nextval[nexttoke].opval->op_targ = tmp;
- expect = XOPERATOR;
- force_next(PRIVATEREF);
- TOKEN(DOLSHARP);
- }
- }
- expect = XOPERATOR;
- force_ident(tokenbuf+1, *tokenbuf);
- TOKEN(DOLSHARP);
- }
- s = scan_ident(s, bufend, tokenbuf+1, FALSE);
+ CLINE;
+
if (expect == XOPERATOR) {
if (lex_formbrack && lex_brackets == lex_formbrack) {
expect = XTERM;
depcom();
- return ','; /* grandfather non-comma-format format */
+ return ','; /* grandfather non-comma-format format */
}
- else
- no_op("Scalar",s);
}
- if (tokenbuf[1]) {
- expectation oldexpect = expect;
- /* This kludge not intended to be bulletproof. */
- if (tokenbuf[1] == '[' && !tokenbuf[2]) {
- yylval.opval = newSVOP(OP_CONST, 0,
- newSViv((IV)compiling.cop_arybase));
- yylval.opval->op_private = OPpCONST_ARYBASE;
- TERM(THING);
- }
- tokenbuf[0] = '$';
- if (dowarn) {
- char *t;
- if (*s == '[' && oldexpect != XREF) {
- for (t = s+1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ;
+ if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) {
+ if (expect == XOPERATOR)
+ no_op("Array length", bufptr);
+ tokenbuf[0] = '@';
+ s = scan_ident(s + 1, bufend, tokenbuf + 1, sizeof tokenbuf - 1,
+ FALSE);
+ if (!tokenbuf[1])
+ PREREF(DOLSHARP);
+ expect = XOPERATOR;
+ pending_ident = '#';
+ TOKEN(DOLSHARP);
+ }
+
+ if (expect == XOPERATOR)
+ no_op("Scalar", bufptr);
+ tokenbuf[0] = '$';
+ s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
+ if (!tokenbuf[1]) {
+ if (s == bufend)
+ yyerror("Final $ should be \\$ or $name");
+ PREREF('$');
+ }
+
+ /* This kludge not intended to be bulletproof. */
+ if (tokenbuf[1] == '[' && !tokenbuf[2]) {
+ yylval.opval = newSVOP(OP_CONST, 0,
+ newSViv((IV)compiling.cop_arybase));
+ yylval.opval->op_private = OPpCONST_ARYBASE;
+ TERM(THING);
+ }
+
+ d = s;
+ if (lex_state == LEX_NORMAL)
+ s = skipspace(s);
+
+ if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
+ char *t;
+ if (*s == '[') {
+ tokenbuf[0] = '@';
+ if (dowarn) {
+ for(t = s + 1;
+ isSPACE(*t) || isALNUM(*t) || *t == '$';
+ t++) ;
if (*t++ == ',') {
bufptr = skipspace(bufptr);
- while (t < bufend && *t != ']') t++;
+ while (t < bufend && *t != ']')
+ t++;
warn("Multidimensional syntax %.*s not supported",
- t-bufptr+1, bufptr);
+ (t - bufptr) + 1, bufptr);
}
}
- if (*s == '{' && strEQ(tokenbuf, "$SIG") &&
- (t = strchr(s,'}')) && (t = strchr(t,'='))) {
- char tmpbuf[1024];
+ }
+ else if (*s == '{') {
+ tokenbuf[0] = '%';
+ if (dowarn && strEQ(tokenbuf+1, "SIG") &&
+ (t = strchr(s, '}')) && (t = strchr(t, '=')))
+ {
+ char tmpbuf[sizeof tokenbuf];
STRLEN len;
for (t++; isSPACE(*t); t++) ;
if (isIDFIRST(*t)) {
- t = scan_word(t, tmpbuf, TRUE, &len);
+ t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
warn("You need to quote \"%s\"", tmpbuf);
}
}
}
- expect = XOPERATOR;
- if (lex_state == LEX_NORMAL && isSPACE(*s)) {
- bool islop = (last_lop == oldoldbufptr);
- s = skipspace(s);
- if (!islop || last_lop_op == OP_GREPSTART)
- expect = XOPERATOR;
- else if (strchr("$@\"'`q", *s))
- expect = XTERM; /* e.g. print $fh "foo" */
- else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
- expect = XTERM; /* e.g. print $fh &sub */
- else if (isDIGIT(*s))
- expect = XTERM; /* e.g. print $fh 3 */
- else if (*s == '.' && isDIGIT(s[1]))
- expect = XTERM; /* e.g. print $fh .3 */
- else if (strchr("/?-+", *s) && !isSPACE(s[1]))
- expect = XTERM; /* e.g. print $fh -1 */
- else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
- expect = XTERM; /* print $fh <<"EOF" */
- }
- if (in_my) {
- if (strchr(tokenbuf,':'))
- croak(no_myglob,tokenbuf);
- nextval[nexttoke].opval = newOP(OP_PADANY, 0);
- nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf);
- force_next(PRIVATEREF);
- }
- else if (!strchr(tokenbuf,':')) {
- if (oldexpect != XREF || oldoldbufptr == last_lop) {
- if (intuit_more(s)) {
- if (*s == '[')
- tokenbuf[0] = '@';
- else if (*s == '{')
- tokenbuf[0] = '%';
+ }
+
+ expect = XOPERATOR;
+ if (lex_state == LEX_NORMAL && isSPACE(*d)) {
+ bool islop = (last_lop == oldoldbufptr);
+ if (!islop || last_lop_op == OP_GREPSTART)
+ expect = XOPERATOR;
+ else if (strchr("$@\"'`q", *s))
+ expect = XTERM; /* e.g. print $fh "foo" */
+ else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
+ expect = XTERM; /* e.g. print $fh &sub */
+ else if (isIDFIRST(*s)) {
+ char tmpbuf[sizeof 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:
+ expect = XTERM; /* e.g. print $fh length() */
+ break;
}
}
- if (tmp = pad_findmy(tokenbuf)) {
- if (!tokenbuf[2] && *tokenbuf =='$' &&
- tokenbuf[1] <= 'b' && tokenbuf[1] >= 'a')
- {
- for (d = in_eval ? oldoldbufptr : SvPVX(linestr);
- d < bufend && *d != '\n';
- d++)
- {
- if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
- croak("Can't use \"my %s\" in sort comparison",
- tokenbuf);
- }
- }
- }
- nextval[nexttoke].opval = newOP(OP_PADANY, 0);
- nextval[nexttoke].opval->op_targ = tmp;
- force_next(PRIVATEREF);
+ else {
+ GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
+ if (gv && GvCVu(gv))
+ expect = XTERM; /* e.g. print $fh subr() */
}
- else
- force_ident(tokenbuf+1, *tokenbuf);
}
- else
- force_ident(tokenbuf+1, *tokenbuf);
- }
- else {
- if (s == bufend)
- yyerror("Final $ should be \\$ or $name");
- PREREF('$');
- }
+ else if (isDIGIT(*s))
+ expect = XTERM; /* e.g. print $fh 3 */
+ else if (*s == '.' && isDIGIT(s[1]))
+ expect = XTERM; /* e.g. print $fh .3 */
+ else if (strchr("/?-+", *s) && !isSPACE(s[1]))
+ expect = XTERM; /* e.g. print $fh -1 */
+ else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
+ expect = XTERM; /* print $fh <<"EOF" */
+ }
+ pending_ident = '$';
TOKEN('$');
case '@':
- s = scan_ident(s, bufend, tokenbuf+1, FALSE);
if (expect == XOPERATOR)
- no_op("Array",s);
- if (tokenbuf[1]) {
- GV* gv;
-
- tokenbuf[0] = '@';
- expect = XOPERATOR;
- if (in_my) {
- if (strchr(tokenbuf,':'))
- croak(no_myglob,tokenbuf);
- nextval[nexttoke].opval = newOP(OP_PADANY, 0);
- nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf);
- force_next(PRIVATEREF);
- TERM('@');
- }
- else if (!strchr(tokenbuf,':')) {
- if (intuit_more(s)) {
- if (*s == '{')
- tokenbuf[0] = '%';
- }
- if (tmp = pad_findmy(tokenbuf)) {
- nextval[nexttoke].opval = newOP(OP_PADANY, 0);
- nextval[nexttoke].opval->op_targ = tmp;
- force_next(PRIVATEREF);
- TERM('@');
- }
- }
-
- /* Force them to make up their mind on "@foo". */
- if (lex_state != LEX_NORMAL && !lex_brackets &&
- ( !(gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV)) ||
- (*tokenbuf == '@'
- ? !GvAV(gv)
- : !GvHV(gv) )))
- {
- char tmpbuf[1024];
- sprintf(tmpbuf, "Literal @%s now requires backslash",tokenbuf+1);
- yyerror(tmpbuf);
- }
+ no_op("Array", s);
+ tokenbuf[0] = '@';
+ s = scan_ident(s, bufend, tokenbuf + 1, sizeof tokenbuf - 1, FALSE);
+ if (!tokenbuf[1]) {
+ if (s == bufend)
+ yyerror("Final @ should be \\@ or @name");
+ PREREF('@');
+ }
+ if (lex_state == LEX_NORMAL)
+ s = skipspace(s);
+ if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) {
+ if (*s == '{')
+ tokenbuf[0] = '%';
/* Warn about @ where they meant $. */
if (dowarn) {
@@ -2147,13 +2387,8 @@ yylex()
}
}
}
- force_ident(tokenbuf+1, *tokenbuf);
- }
- else {
- if (s == bufend)
- yyerror("Final @ should be \\@ or @name");
- PREREF('@');
}
+ pending_ident = '@';
TERM('@');
case '/': /* may either be division or pattern */
@@ -2170,7 +2405,7 @@ yylex()
case '.':
if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' &&
- (s == SvPVX(linestr) || s[-1] == '\n') ) {
+ (s == linestart || s[-1] == '\n') ) {
lex_formbrack = 0;
expect = XSTATE;
goto rightbracket;
@@ -2292,17 +2527,35 @@ yylex()
keylookup:
bufptr = s;
- s = scan_word(s, tokenbuf, FALSE, &len);
-
- if (*s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
+ s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
+
+ /* Some keywords can be followed by any delimiter, including ':' */
+ tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
+ len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
+ (tokenbuf[0] == 'q' &&
+ strchr("qwx", tokenbuf[1]))));
+
+ /* x::* is just a word, unless x is "CORE" */
+ if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
goto just_a_word;
+ d = s;
+ while (d < bufend && isSPACE(*d))
+ d++; /* no comments skipped here, or s### is misparsed */
+
+ /* Is this a label? */
+ if (!tmp && expect == XSTATE
+ && d < bufend && *d == ':' && *(d + 1) != ':') {
+ s = d + 1;
+ yylval.pval = savepv(tokenbuf);
+ CLINE;
+ TOKEN(LABEL);
+ }
+
+ /* Check for keywords */
tmp = keyword(tokenbuf, len);
/* Is this a word before a => operator? */
- d = s;
- while (d < bufend && (*d == ' ' || *d == '\t'))
- d++; /* no comments skipped here, or s### is misparsed */
if (strnEQ(d,"=>",2)) {
CLINE;
if (dowarn && (tmp || perl_get_cv(tokenbuf, FALSE)))
@@ -2332,35 +2585,26 @@ yylex()
default: /* not a keyword */
just_a_word: {
GV *gv;
+ SV *sv;
char lastchar = (bufptr == oldoldbufptr ? 0 : bufptr[-1]);
/* Get the rest if it looks like a package qualifier */
if (*s == '\'' || *s == ':' && s[1] == ':') {
- s = scan_word(s, tokenbuf + len, TRUE, &len);
+ s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
+ TRUE, &len);
if (!len)
croak("Bad name after %s::", tokenbuf);
}
- /* Do special processing at start of statement. */
-
- if (expect == XSTATE) {
- while (isSPACE(*s)) s++;
- if (*s == ':') { /* It's a label. */
- yylval.pval = savepv(tokenbuf);
- s++;
- CLINE;
- TOKEN(LABEL);
- }
- }
- else if (expect == XOPERATOR) {
- if (bufptr == SvPVX(linestr)) {
+ if (expect == XOPERATOR) {
+ if (bufptr == linestart) {
curcop->cop_line--;
warn(warn_nosemi);
curcop->cop_line++;
}
else
- no_op("Bare word",s);
+ no_op("Bareword",s);
}
/* Look for a subroutine with this name in current package. */
@@ -2396,7 +2640,7 @@ yylex()
/* (But it's an indir obj regardless for sort.) */
if ((last_lop_op == OP_SORT ||
- (!immediate_paren && (!gv || !GvCV(gv))) ) &&
+ (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
(last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){
expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR;
goto bareword;
@@ -2409,6 +2653,13 @@ yylex()
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;
+ }
+ }
nextval[nexttoke].opval = yylval.opval;
expect = XOPERATOR;
force_next(WORD);
@@ -2418,7 +2669,7 @@ yylex()
/* If followed by var or block, call it a method (unless sub) */
- if ((*s == '$' || *s == '{') && (!gv || !GvCV(gv))) {
+ if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
last_lop = oldbufptr;
last_lop_op = OP_METHOD;
PREBLOCK(METHOD);
@@ -2431,20 +2682,23 @@ yylex()
/* Not a method, so call it a subroutine (if defined) */
- if (gv && GvCV(gv)) {
- CV* cv = GvCV(gv);
- if (*s == '(') {
- nextval[nexttoke].opval = yylval.opval;
- expect = XTERM;
- force_next(WORD);
- yylval.ival = 0;
- TOKEN('&');
- }
+ if (gv && GvCVu(gv)) {
+ CV* cv;
if (lastchar == '-')
warn("Ambiguous use of -%s resolved as -&%s()",
tokenbuf, tokenbuf);
last_lop = oldbufptr;
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));
@@ -2470,6 +2724,7 @@ yylex()
if (hints & HINT_STRICT_SUBS &&
lastchar != '-' &&
strnNE(s,"->",2) &&
+ last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */
last_lop_op != OP_ACCEPT &&
last_lop_op != OP_PIPE_OP &&
last_lop_op != OP_SOCKPAIR)
@@ -2499,15 +2754,22 @@ yylex()
TOKEN(WORD);
}
+ case KEY___FILE__:
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ newSVsv(GvSV(curcop->cop_filegv)));
+ TERM(THING);
+
case KEY___LINE__:
- case KEY___FILE__: {
- if (tokenbuf[2] == 'L')
- (void)sprintf(tokenbuf,"%ld",(long)curcop->cop_line);
- else
- strcpy(tokenbuf, SvPVX(GvSV(curcop->cop_filegv)));
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ newSVpvf("%ld", (long)curcop->cop_line));
+ TERM(THING);
+
+ case KEY___PACKAGE__:
+ yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ (curstash
+ ? newSVsv(curstname)
+ : &sv_undef));
TERM(THING);
- }
case KEY___DATA__:
case KEY___END__: {
@@ -2515,25 +2777,25 @@ yylex()
/*SUPPRESS 560*/
if (rsfp && (!in_eval || tokenbuf[2] == 'D')) {
- char dname[256];
char *pname = "main";
if (tokenbuf[2] == 'D')
pname = HvNAME(curstash ? curstash : defstash);
- sprintf(dname,"%s::DATA", pname);
- gv = gv_fetchpv(dname,TRUE, SVt_PVIO);
+ gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
GvMULTI_on(gv);
if (!GvIO(gv))
GvIOp(gv) = newIO();
IoIFP(GvIOp(gv)) = rsfp;
#if defined(HAS_FCNTL) && defined(F_SETFD)
{
- int fd = fileno(rsfp);
+ int fd = PerlIO_fileno(rsfp);
fcntl(fd,F_SETFD,fd >= 3);
}
#endif
+ /* Mark this internal pseudo-handle as clean */
+ IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
if (preprocess)
IoTYPE(GvIOp(gv)) = '|';
- else if ((FILE*)rsfp == stdin)
+ else if ((PerlIO*)rsfp == PerlIO_stdin())
IoTYPE(GvIOp(gv)) = '-';
else
IoTYPE(GvIOp(gv)) = '<';
@@ -2556,7 +2818,7 @@ yylex()
if (*s == ':' && s[1] == ':') {
s += 2;
d = s;
- s = scan_word(s, tokenbuf, FALSE, &len);
+ s = scan_word(s, tokenbuf, sizeof tokenbuf, FALSE, &len);
tmp = keyword(tokenbuf, len);
if (tmp < 0)
tmp = -tmp;
@@ -2724,10 +2986,16 @@ yylex()
case KEY_for:
case KEY_foreach:
yylval.ival = curcop->cop_line;
- while (s < bufend && isSPACE(*s))
- s++;
- if (isIDFIRST(*s))
- croak("Missing $ on loop variable");
+ s = skipspace(s);
+ if (isIDFIRST(*s)) {
+ char *p = s;
+ if ((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:
@@ -2786,10 +3054,10 @@ yylex()
FUN0(OP_GPWENT);
case KEY_getpwnam:
- FUN1(OP_GPWNAM);
+ UNI(OP_GPWNAM);
case KEY_getpwuid:
- FUN1(OP_GPWUID);
+ UNI(OP_GPWUID);
case KEY_getpeername:
UNI(OP_GETPEERNAME);
@@ -2831,10 +3099,10 @@ yylex()
FUN0(OP_GGRENT);
case KEY_getgrnam:
- FUN1(OP_GGRNAM);
+ UNI(OP_GGRNAM);
case KEY_getgrgid:
- FUN1(OP_GGRGID);
+ UNI(OP_GGRGID);
case KEY_getlogin:
FUN0(OP_GETLOGIN);
@@ -2879,7 +3147,6 @@ yylex()
UNI(OP_LCFIRST);
case KEY_local:
- yylval.ival = 0;
OPERATOR(LOCAL);
case KEY_length:
@@ -2930,8 +3197,7 @@ yylex()
case KEY_my:
in_my = TRUE;
- yylval.ival = 1;
- OPERATOR(LOCAL);
+ OPERATOR(MY);
case KEY_next:
s = force_word(s,WORD,TRUE,FALSE,FALSE);
@@ -2944,6 +3210,7 @@ yylex()
if (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);
@@ -3019,6 +3286,19 @@ yylex()
s = scan_str(s);
if (!s)
missingterm((char*)0);
+ if (dowarn && SvLEN(lex_stuff)) {
+ d = SvPV_force(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(')');
nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff));
lex_stuff = Nullsv;
@@ -3059,7 +3339,7 @@ yylex()
*tokenbuf = '\0';
s = force_word(s,WORD,TRUE,TRUE,FALSE);
if (isIDFIRST(*tokenbuf))
- gv_stashpv(tokenbuf, TRUE);
+ gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
else if (*s == '<')
yyerror("<> should be quotes");
UNI(OP_REQUIRE);
@@ -3150,16 +3430,16 @@ yylex()
LOP(OP_SETPRIORITY,XTERM);
case KEY_sethostent:
- FUN1(OP_SHOSTENT);
+ UNI(OP_SHOSTENT);
case KEY_setnetent:
- FUN1(OP_SNETENT);
+ UNI(OP_SNETENT);
case KEY_setservent:
- FUN1(OP_SSERVENT);
+ UNI(OP_SSERVENT);
case KEY_setprotoent:
- FUN1(OP_SPROTOENT);
+ UNI(OP_SPROTOENT);
case KEY_setpwent:
FUN0(OP_SPWENT);
@@ -3243,9 +3523,9 @@ yylex()
s = skipspace(s);
if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
- char tmpbuf[128];
+ char tmpbuf[sizeof tokenbuf];
expect = XBLOCK;
- d = scan_word(s, tmpbuf, TRUE, &len);
+ d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
if (strchr(tmpbuf, ':'))
sv_setpv(subname, tmpbuf);
else {
@@ -3270,6 +3550,8 @@ yylex()
/* Look for a prototype */
if (*s == '(') {
+ char *p;
+
s = scan_str(s);
if (!s) {
if (lex_stuff)
@@ -3277,6 +3559,16 @@ yylex()
lex_stuff = Nullsv;
croak("Prototype not terminated");
}
+ /* strip spaces */
+ d = SvPVX(lex_stuff);
+ tmp = 0;
+ for (p = d; *p; ++p) {
+ if (!isSPACE(*p))
+ d[tmp++] = *p;
+ }
+ d[tmp] = '\0';
+ SvCUR(lex_stuff) = tmp;
+
nexttoke++;
nextval[1] = nextval[0];
nexttype[1] = nexttype[0];
@@ -3309,6 +3601,9 @@ yylex()
case KEY_sysopen:
LOP(OP_SYSOPEN,XTERM);
+ case KEY_sysseek:
+ LOP(OP_SYSSEEK,XTERM);
+
case KEY_sysread:
LOP(OP_SYSREAD,XTERM);
@@ -3383,7 +3678,18 @@ yylex()
case KEY_use:
if (expect != XSTATE)
yyerror("\"use\" not allowed in expression");
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = skipspace(s);
+ if(isDIGIT(*s)) {
+ s = force_version(s);
+ if(*s == ';' || (s = skipspace(s), *s == ';')) {
+ nextval[nexttoke].opval = Nullop;
+ force_next(WORD);
+ }
+ }
+ else {
+ s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_version(s);
+ }
yylval.ival = 1;
OPERATOR(USE);
@@ -3440,8 +3746,9 @@ I32 len;
switch (*d) {
case '_':
if (d[1] == '_') {
- if (strEQ(d,"__LINE__")) return -KEY___LINE__;
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__;
}
@@ -3668,7 +3975,7 @@ I32 len;
case 4:
if (strEQ(d,"grep")) return KEY_grep;
if (strEQ(d,"goto")) return KEY_goto;
- if (strEQ(d,"glob")) return -KEY_glob;
+ if (strEQ(d,"glob")) return KEY_glob;
break;
case 6:
if (strEQ(d,"gmtime")) return -KEY_gmtime;
@@ -3947,10 +4254,11 @@ I32 len;
if (strEQ(d,"system")) return -KEY_system;
break;
case 7:
- if (strEQ(d,"sysopen")) return -KEY_sysopen;
- if (strEQ(d,"sysread")) return -KEY_sysread;
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;
@@ -4062,7 +4370,7 @@ char *what;
}
if (*w)
for (; *w && isSPACE(*w); w++) ;
- if (!*w || !strchr(";|})]oa!=", *w)) /* an advisory hack only... */
+ if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
warn("%s (...) interpreted as function",name);
}
while (s < bufend && isSPACE(*s))
@@ -4090,14 +4398,18 @@ char *what;
}
static char *
-scan_word(s, dest, allow_package, slp)
+scan_word(s, dest, destlen, allow_package, slp)
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])) {
@@ -4118,13 +4430,15 @@ STRLEN *slp;
}
static char *
-scan_ident(s,send,dest,ck_uni)
+scan_ident(s, send, dest, destlen, ck_uni)
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++;
@@ -4133,12 +4447,18 @@ I32 ck_uni;
if (isSPACE(*s))
s = skipspace(s);
d = dest;
+ e = d + destlen - 3; /* two-character token, ending NUL */
if (isDIGIT(*s)) {
- while (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])) {
@@ -4162,8 +4482,13 @@ I32 ck_uni;
return s;
}
if (*s == '$' && s[1] &&
- (isALPHA(s[1]) || strchr("$_{", s[1]) || strnEQ(s+1,"::",2)) )
- return s;
+ (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
+ {
+ if (isDIGIT(s[1]) && lex_state == LEX_INTERPNORMAL)
+ deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
+ else
+ return s;
+ }
if (*s == '{') {
bracket = s;
s++;
@@ -4174,20 +4499,26 @@ I32 ck_uni;
*d = *s++;
d[1] = '\0';
if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
- *d = *s++ ^ 64;
+ *d = toCTRL(*s);
+ s++;
}
if (bracket) {
if (isSPACE(s[-1])) {
- while (s < send && (*s == ' ' || *s == '\t')) s++;
- *d = *s;
+ while (s < send) {
+ char ch = *s++;
+ if (ch != ' ' && ch != '\t') {
+ *d = ch;
+ break;
+ }
+ }
}
- if (isALPHA(*d) || *d == '_') {
+ if (isIDFIRST(*d)) {
d++;
while (isALNUM(*s) || *s == ':')
*d++ = *s++;
*d = '\0';
while (s < send && (*s == ' ' || *s == '\t')) s++;
- if ((*s == '[' || *s == '{')) {
+ if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
if (dowarn && keyword(dest, d - dest)) {
char *brack = *s == '[' ? "[...]" : "{...}";
warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
@@ -4205,7 +4536,7 @@ I32 ck_uni;
lex_state = LEX_INTERPEND;
if (funny == '#')
funny = '@';
- if (dowarn &&
+ if (dowarn && 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);
@@ -4224,12 +4555,12 @@ void pmflag(pmfl,ch)
U16* pmfl;
int ch;
{
- if (ch == 'i') {
- sawi = TRUE;
+ 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')
@@ -4254,14 +4585,14 @@ char *start;
lex_stuff = Nullsv;
croak("Search pattern not terminated");
}
+
pm = (PMOP*)newPMOP(OP_MATCH, 0);
if (multi_open == '?')
pm->op_pmflags |= PMf_ONCE;
-
- while (*s && strchr("iogmsx", *s))
+ while (*s && strchr("iogcmsx", *s))
pmflag(&pm->op_pmflags,*s++);
-
pm->op_pmpermflags = pm->op_pmflags;
+
lex_op = (OP*)pm;
yylval.ival = OP_MATCH;
return s;
@@ -4273,6 +4604,7 @@ char *start;
{
register char *s;
register PMOP *pm;
+ I32 first_start;
I32 es = 0;
yylval.ival = OP_NULL;
@@ -4289,6 +4621,7 @@ char *start;
if (s[-1] == multi_open)
s--;
+ first_start = multi_start;
s = scan_str(s);
if (!s) {
if (lex_stuff)
@@ -4299,9 +4632,10 @@ char *start;
lex_repl = Nullsv;
croak("Substitution replacement not terminated");
}
+ multi_start = first_start; /* so whole substitution is taken together */
pm = (PMOP*)newPMOP(OP_SUBST, 0);
- while (*s && strchr("iogmsex", *s)) {
+ while (*s && strchr("iogcmsex", *s)) {
if (*s == 'e') {
s++;
es++;
@@ -4339,8 +4673,6 @@ register PMOP *pm;
) {
if (!(pm->op_pmregexp->reganch & ROPT_ANCH))
pm->op_pmflags |= PMf_SCANFIRST;
- else if (pm->op_pmflags & PMf_FOLD)
- return;
pm->op_pmshort = SvREFCNT_inc(pm->op_pmregexp->regstart);
pm->op_pmslen = SvCUR(pm->op_pmshort);
}
@@ -4358,9 +4690,11 @@ register PMOP *pm;
return;
}
}
- if (!pm->op_pmshort || /* promote the better string */
- ((pm->op_pmflags & PMf_SCANFIRST) &&
- (SvCUR(pm->op_pmshort) < SvCUR(pm->op_pmregexp->regmust)) )){
+ /* promote the better string */
+ if ((!pm->op_pmshort &&
+ !(pm->op_pmregexp->reganch & ROPT_ANCH_GPOS)) ||
+ ((pm->op_pmflags & PMf_SCANFIRST) &&
+ (SvCUR(pm->op_pmshort) < SvCUR(pm->op_pmregexp->regmust)))) {
SvREFCNT_dec(pm->op_pmshort); /* ok if null */
pm->op_pmshort = pm->op_pmregexp->regmust;
pm->op_pmslen = SvCUR(pm->op_pmshort);
@@ -4434,20 +4768,23 @@ register char *s;
SV *tmpstr;
char term;
register char *d;
+ register char *e;
char *peek;
+ int outer = (rsfp && !lex_inwhat);
s += 2;
d = tokenbuf;
- if (!rsfp)
+ e = tokenbuf + sizeof tokenbuf - 1;
+ if (!outer)
*d++ = '\n';
for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
if (*peek && strchr("`'\"",*peek)) {
s = peek;
term = *s++;
- s = cpytill(d,s,bufend,term,&len);
+ s = delimcpy(d, e, s, bufend, term, &len);
+ d += len;
if (s < bufend)
s++;
- d += len;
}
else {
if (*s == '\\')
@@ -4456,14 +4793,18 @@ register char *s;
term = '"';
if (!isALNUM(*s))
deprecate("bare << to mean <<\"\"");
- while (isALNUM(*s))
- *d++ = *s++;
- } /* assuming tokenbuf won't clobber */
+ for (; isALNUM(*s); s++) {
+ if (d < e)
+ *d++ = *s;
+ }
+ }
+ if (d >= tokenbuf + sizeof tokenbuf - 1)
+ croak("Delimiter for here document is too long");
*d++ = '\n';
*d = '\0';
len = d - tokenbuf;
d = "\n";
- if (rsfp || !(d=ninstr(s,bufend,d,d+1)))
+ if (outer || !(d=ninstr(s,bufend,d,d+1)))
herewas = newSVpv(s,bufend-s);
else
s--, herewas = newSVpv(s,d-s);
@@ -4484,10 +4825,10 @@ register char *s;
multi_start = curcop->cop_line;
multi_open = multi_close = '<';
term = *tokenbuf;
- if (!rsfp) {
+ if (!outer) {
d = s;
while (s < bufend &&
- (*s != term || bcmp(s,tokenbuf,len) != 0) ) {
+ (*s != term || memNE(s,tokenbuf,len)) ) {
if (*s++ == '\n')
curcop->cop_line++;
}
@@ -4499,19 +4840,19 @@ register char *s;
s += len - 1;
sv_catpvn(herewas,s,bufend-s);
sv_setsv(linestr,herewas);
- oldoldbufptr = oldbufptr = bufptr = s = SvPVX(linestr);
+ oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr);
bufend = SvPVX(linestr) + SvCUR(linestr);
}
else
sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
while (s >= bufend) { /* multiple line string? */
- if (!rsfp ||
- !(oldoldbufptr = oldbufptr = s = filter_gets(linestr, rsfp))) {
+ if (!outer ||
+ !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
curcop->cop_line = multi_start;
missingterm(tokenbuf);
}
curcop->cop_line++;
- if (perldb && curstash != debstash) {
+ if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(88,0);
sv_upgrade(sv, SVt_PVMG);
@@ -4520,7 +4861,7 @@ register char *s;
(I32)curcop->cop_line,sv);
}
bufend = SvPVX(linestr) + SvCUR(linestr);
- if (*s == term && bcmp(s,tokenbuf,len) == 0) {
+ if (*s == term && memEQ(s,tokenbuf,len)) {
s = bufend - 1;
*s = ' ';
sv_catsv(linestr,herewas);
@@ -4549,15 +4890,17 @@ char *start;
{
register char *s = start;
register char *d;
+ register char *e;
I32 len;
d = tokenbuf;
- s = cpytill(d, s+1, bufend, '>', &len);
- if (s < bufend)
- s++;
- else
+ e = tokenbuf + sizeof tokenbuf;
+ s = delimcpy(d, e, s + 1, bufend, '>', &len);
+ if (len >= sizeof tokenbuf)
+ croak("Excessively long <> operator");
+ if (s >= bufend)
croak("Unterminated <> operator");
-
+ s++;
if (*d == '$' && d[1]) d++;
while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
d++;
@@ -4646,13 +4989,13 @@ char *start;
for (; s < bufend; s++,to++) {
if (*s == '\n' && !rsfp)
curcop->cop_line++;
- if (*s == '\\' && s+1 < bufend && term != '\\') {
- if (s[1] == term)
+ if (*s == '\\' && s+1 < bufend) {
+ if ((s[1] == multi_open) || (s[1] == multi_close))
s++;
else
*to++ = *s++;
}
- else if (*s == term && --brackets <= 0)
+ else if (*s == multi_close && --brackets <= 0)
break;
else if (*s == multi_open)
brackets++;
@@ -4665,13 +5008,13 @@ char *start;
if (s < bufend) break; /* string ends on this line? */
if (!rsfp ||
- !(oldoldbufptr = oldbufptr = s = filter_gets(linestr, rsfp))) {
+ !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
sv_free(sv);
curcop->cop_line = multi_start;
return Nullch;
}
curcop->cop_line++;
- if (perldb && curstash != debstash) {
+ if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(88,0);
sv_upgrade(sv, SVt_PVMG);
@@ -4700,19 +5043,22 @@ char *start;
{
register char *s = start;
register char *d;
- I32 tryi32;
+ register char *e;
+ I32 tryiv;
double value;
SV *sv;
I32 floatit;
char *lastub = 0;
+ static char number_too_long[] = "Number too long";
switch (*s) {
default:
croak("panic: scan_num");
case '0':
{
- U32 i;
+ UV u;
I32 shift;
+ bool overflowed = FALSE;
if (s[1] == 'x') {
shift = 4;
@@ -4722,8 +5068,10 @@ char *start;
goto decimal;
else
shift = 3;
- i = 0;
+ u = 0;
for (;;) {
+ UV n, b;
+
switch (*s) {
default:
goto out;
@@ -4736,31 +5084,34 @@ char *start;
/* FALL THROUGH */
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7':
- i <<= shift;
- i += *s++ & 15;
- break;
+ b = *s++ & 15;
+ goto digit;
case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
if (shift != 4)
goto out;
- i <<= 4;
- i += (*s++ & 7) + 9;
+ b = (*s++ & 7) + 9;
+ digit:
+ n = u << shift;
+ if (!overflowed && (n >> shift) != u) {
+ warn("Integer overflow in %s number",
+ (shift == 4) ? "hex" : "octal");
+ overflowed = TRUE;
+ }
+ u = n | b;
break;
}
}
out:
sv = NEWSV(92,0);
- tryi32 = i;
- if (tryi32 == i && tryi32 >= 0)
- sv_setiv(sv,tryi32);
- else
- sv_setnv(sv,(double)i);
+ sv_setuv(sv, u);
}
break;
case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9': case '.':
decimal:
d = tokenbuf;
+ e = tokenbuf + sizeof tokenbuf - 6; /* room for various punctuation */
floatit = FALSE;
while (isDIGIT(*s) || *s == '_') {
if (*s == '_') {
@@ -4768,19 +5119,22 @@ char *start;
warn("Misplaced _ in number");
lastub = ++s;
}
- else
+ else {
+ if (d >= e)
+ croak(number_too_long);
*d++ = *s++;
+ }
}
if (dowarn && lastub && s - lastub != 3)
warn("Misplaced _ in number");
if (*s == '.' && s[1] != '.') {
floatit = TRUE;
*d++ = *s++;
- while (isDIGIT(*s) || *s == '_') {
- if (*s == '_')
- s++;
- else
- *d++ = *s++;
+ for (; isDIGIT(*s) || *s == '_'; s++) {
+ if (d >= e)
+ croak(number_too_long);
+ if (*s != '_')
+ *d++ = *s;
}
}
if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
@@ -4789,17 +5143,21 @@ char *start;
*d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */
if (*s == '+' || *s == '-')
*d++ = *s++;
- while (isDIGIT(*s))
+ while (isDIGIT(*s)) {
+ if (d >= e)
+ croak(number_too_long);
*d++ = *s++;
+ }
}
*d = '\0';
sv = NEWSV(92,0);
+ SET_NUMERIC_STANDARD();
value = atof(tokenbuf);
- tryi32 = I_32(value);
- if (!floatit && (double)tryi32 == value)
- sv_setiv(sv,tryi32);
+ tryiv = I_V(value);
+ if (!floatit && (double)tryiv == value)
+ sv_setiv(sv, tryiv);
else
- sv_setnv(sv,value);
+ sv_setnv(sv, value);
break;
}
@@ -4844,8 +5202,8 @@ register char *s;
}
s = eol;
if (rsfp) {
- s = filter_gets(linestr, rsfp);
- oldoldbufptr = oldbufptr = bufptr = SvPVX(linestr);
+ s = filter_gets(linestr, rsfp, 0);
+ oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr);
bufend = bufptr + SvCUR(linestr);
if (!s) {
s = bufptr;
@@ -4887,10 +5245,12 @@ set_csh()
#endif
}
-int
-start_subparse()
+I32
+start_subparse(is_format, flags)
+I32 is_format;
+U32 flags;
{
- int oldsavestack_ix = savestack_ix;
+ I32 oldsavestack_ix = savestack_ix;
CV* outsidecv = compcv;
AV* comppadlist;
@@ -4899,18 +5259,19 @@ start_subparse()
}
save_I32(&subline);
save_item(subname);
- SAVEINT(padix);
+ SAVEI32(padix);
SAVESPTR(curpad);
SAVESPTR(comppad);
SAVESPTR(comppad_name);
SAVESPTR(compcv);
- SAVEINT(comppad_name_fill);
- SAVEINT(min_intro_pending);
- SAVEINT(max_intro_pending);
- SAVEINT(pad_reset_pending);
+ SAVEI32(comppad_name_fill);
+ SAVEI32(min_intro_pending);
+ SAVEI32(max_intro_pending);
+ SAVEI32(pad_reset_pending);
compcv = (CV*)NEWSV(1104,0);
- sv_upgrade((SV *)compcv, SVt_PVCV);
+ sv_upgrade((SV *)compcv, is_format ? SVt_PVFM : SVt_PVCV);
+ CvFLAGS(compcv) |= flags;
comppad = newAV();
comppad_name = newAV();
@@ -4947,55 +5308,69 @@ int
yyerror(s)
char *s;
{
- char tmpbuf[258];
- char *tname = tmpbuf;
-
- if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
+ char *where = NULL;
+ char *context = NULL;
+ int contlen = -1;
+ SV *msg;
+
+ if (!yychar || (yychar == ';' && !rsfp))
+ where = "at EOF";
+ else if (bufptr > oldoldbufptr && bufptr - oldoldbufptr < 200 &&
oldoldbufptr != oldbufptr && oldbufptr != bufptr) {
while (isSPACE(*oldoldbufptr))
oldoldbufptr++;
- sprintf(tname,"near \"%.*s\"",bufptr - oldoldbufptr, oldoldbufptr);
+ context = oldoldbufptr;
+ contlen = bufptr - oldoldbufptr;
}
else if (bufptr > oldbufptr && bufptr - oldbufptr < 200 &&
oldbufptr != bufptr) {
while (isSPACE(*oldbufptr))
oldbufptr++;
- sprintf(tname,"near \"%.*s\"",bufptr - oldbufptr, oldbufptr);
+ context = oldbufptr;
+ contlen = bufptr - oldbufptr;
}
else if (yychar > 255)
- tname = "next token ???";
- else if (!yychar || (yychar == ';' && !rsfp))
- (void)strcpy(tname,"at EOF");
+ where = "next token ???";
else if ((yychar & 127) == 127) {
if (lex_state == LEX_NORMAL ||
(lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL))
- (void)strcpy(tname,"at end of line");
+ where = "at end of line";
else if (lex_inpat)
- (void)strcpy(tname,"within pattern");
+ 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
- (void)strcpy(tname,"within string");
+ sv_catpvf(where_sv, "\\%03o", yychar & 255);
+ where = SvPVX(where_sv);
}
- else if (yychar < 32)
- (void)sprintf(tname,"next char ^%c",yychar+64);
+ msg = sv_2mortal(newSVpv(s, 0));
+ sv_catpvf(msg, " at %_ line %ld, ",
+ GvSV(curcop->cop_filegv), (long)curcop->cop_line);
+ if (context)
+ sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
else
- (void)sprintf(tname,"next char %c",yychar);
- (void)sprintf(buf, "%s at %s line %d, %s\n",
- s,SvPVX(GvSV(curcop->cop_filegv)),curcop->cop_line,tname);
- if (curcop->cop_line == multi_end && multi_start < multi_end) {
- sprintf(buf+strlen(buf),
- " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
- multi_open,multi_close,(long)multi_start);
+ sv_catpvf(msg, "%s\n", where);
+ if (multi_start < multi_end && (U32)(curcop->cop_line - multi_end) <= 1) {
+ sv_catpvf(msg,
+ " (Might be a runaway multi-line %c%c string starting on line %ld)\n",
+ (int)multi_open,(int)multi_close,(long)multi_start);
multi_end = 0;
}
if (in_eval & 2)
- warn("%s",buf);
+ warn("%_", msg);
else if (in_eval)
- sv_catpv(GvSV(errgv),buf);
+ sv_catsv(GvSV(errgv), msg);
else
- fputs(buf,stderr);
+ PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
if (++error_count >= 10)
- croak("%s has too many errors.\n",
- SvPVX(GvSV(curcop->cop_filegv)));
+ croak("%_ has too many errors.\n", GvSV(curcop->cop_filegv));
in_my = 0;
return 0;
}
diff --git a/gnu/usr.bin/perl/universal.c b/gnu/usr.bin/perl/universal.c
new file mode 100644
index 00000000000..d6689f8acf9
--- /dev/null
+++ b/gnu/usr.bin/perl/universal.c
@@ -0,0 +1,213 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.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(stash, name, len, level)
+HV *stash;
+char *name;
+int len;
+int level;
+{
+ AV* av;
+ GV* gv;
+ GV** gvp;
+ HV* hv = Nullhv;
+
+ if (!stash)
+ return &sv_undef;
+
+ if(strEQ(HvNAME(stash), name))
+ return &sv_yes;
+
+ if (level > 100)
+ croak("Recursive inheritance detected");
+
+ gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
+
+ if (gvp && (gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv))) {
+ SV* sv;
+ SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
+ if (svp && (sv = *svp) != (SV*)&sv_undef)
+ return sv;
+ }
+
+ gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
+
+ if (gvp && (gv = *gvp) != (GV*)&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);
+ I32 items = AvFILL(av) + 1;
+ while (items--) {
+ SV* sv = *svp++;
+ HV* basestash = gv_stashsv(sv, FALSE);
+ if (!basestash) {
+ if (dowarn)
+ warn("Can't locate package %s for @%s::ISA",
+ SvPVX(sv), HvNAME(stash));
+ continue;
+ }
+ if(&sv_yes == isa_lookup(basestash, name, len, level + 1)) {
+ (void)hv_store(hv,name,len,&sv_yes,0);
+ return &sv_yes;
+ }
+ }
+ (void)hv_store(hv,name,len,&sv_no,0);
+ }
+ }
+
+ return boolSV(strEQ(name, "UNIVERSAL"));
+}
+
+bool
+sv_derived_from(sv, name)
+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) == &sv_yes)
+ ? TRUE
+ : FALSE ;
+
+}
+
+
+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),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),na);
+ rv = &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*)&sv_undef && (sv = GvSV(gv))) {
+ SV *nsv = sv_newmortal();
+ sv_setsv(nsv, sv);
+ sv = nsv;
+ undef = Nullch;
+ }
+ else {
+ sv = (SV*)&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),na), undef ? undef : SvPV(sv,na));
+
+ ST(0) = sv;
+
+ XSRETURN(1);
+}
+
+void
+boot_core_UNIVERSAL()
+{
+ 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/gnu/usr.bin/perl/unixish.h b/gnu/usr.bin/perl/unixish.h
index 2f5f44bfacf..a13e2bd86a5 100644
--- a/gnu/usr.bin/perl/unixish.h
+++ b/gnu/usr.bin/perl/unixish.h
@@ -9,44 +9,77 @@
* This symbol, if defined, indicates that the ioctl() routine is
* available to set I/O characteristics
*/
-#define HAS_IOCTL /**/
+#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 /**/
+#define HAS_UTIME / **/
/* HAS_GROUP
* This symbol, if defined, indicates that the getgrnam(),
* getgrgid(), and getgrent() routines are available to
* get group entries.
*/
-#define HAS_GROUP /**/
+#define HAS_GROUP / **/
/* HAS_PASSWD
* This symbol, if defined, indicates that the getpwnam(),
* getpwuid(), and getpwent() routines are available to
* get password entries.
*/
-#define HAS_PASSWD /**/
+#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
+
+/* 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 /**/
+/* #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 /**/
+/* #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>
@@ -60,11 +93,6 @@
#endif
#define ABORT() kill(getpid(),SIGABRT);
-#define BIT_BUCKET "/dev/null"
-#define PERL_SYS_INIT(c,v)
-#define PERL_SYS_TERM()
-#define dXSUB_SYS int dummy
-
/*
* 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
@@ -76,6 +104,21 @@
#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)
+#else
+# define PERL_SYS_INIT(c,v)
+#endif
+#endif
-#define my_getenv(var) getenv(var)
+#ifndef PERL_SYS_TERM
+#define PERL_SYS_TERM()
+#endif
+
+#define BIT_BUCKET "/dev/null"
+#define dXSUB_SYS
diff --git a/gnu/usr.bin/perl/util.c b/gnu/usr.bin/perl/util.c
index a11d98fe612..819ab4ec347 100644
--- a/gnu/usr.bin/perl/util.c
+++ b/gnu/usr.bin/perl/util.c
@@ -1,6 +1,6 @@
/* util.c
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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.
@@ -19,20 +19,19 @@
#include <signal.h>
#endif
-/* Omit this -- it causes too much grief on mixed systems.
+#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
-#ifdef I_LIMITS /* Needed for cast_xxx() functions below. */
-# include <limits.h>
-#endif
-
/* Put this after #includes because fork and vfork prototypes may
conflict.
*/
@@ -47,52 +46,53 @@
# include <sys/file.h>
#endif
+#ifdef I_SYS_WAIT
+# include <sys/wait.h>
+#endif
+
#define FLUSH
#ifdef LEAKTEST
static void xstat _((void));
#endif
-#ifndef safemalloc
+#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.
*/
-char *
+Malloc_t
safemalloc(size)
-#ifdef MSDOS
-unsigned long size;
-#else
MEM_SIZE size;
-#endif /* MSDOS */
{
- char *ptr;
-#ifdef MSDOS
+ Malloc_t ptr;
+#ifdef HAS_64K_LIMIT
if (size > 0xffff) {
- fprintf(stderr, "Allocation too large: %lx\n", size) FLUSH;
+ PerlIO_printf(PerlIO_stderr(), "Allocation too large: %lx\n", size) FLUSH;
my_exit(1);
}
-#endif /* MSDOS */
+#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
if ((long)size < 0)
croak("panic: malloc");
#endif
ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
- DEBUG_m(fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
#else
- DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
#endif
if (ptr != Nullch)
return ptr;
else if (nomemok)
return Nullch;
else {
- fputs(no_mem,stderr) FLUSH;
+ PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
my_exit(1);
}
/*NOTREACHED*/
@@ -100,26 +100,23 @@ MEM_SIZE size;
/* paranoid version of realloc */
-char *
+Malloc_t
saferealloc(where,size)
-char *where;
-#ifndef MSDOS
+Malloc_t where;
MEM_SIZE size;
-#else
-unsigned long size;
-#endif /* MSDOS */
{
- char *ptr;
+ Malloc_t ptr;
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE)
- char *realloc();
+ Malloc_t realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
-#ifdef MSDOS
- if (size > 0xffff) {
- fprintf(stderr, "Reallocation too large: %lx\n", size) FLUSH;
- my_exit(1);
- }
-#endif /* MSDOS */
+#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 (!where)
croak("Null realloc");
#ifdef DEBUGGING
@@ -130,13 +127,13 @@ unsigned long size;
#if !(defined(I286) || defined(atarist))
DEBUG_m( {
- fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++);
- fprintf(stderr,"0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
+ PerlIO_printf(Perl_debug_log, "0x%x: (%05d) rfree\n",where,an++);
+ PerlIO_printf(Perl_debug_log, "0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
} )
#else
DEBUG_m( {
- fprintf(stderr,"0x%lx: (%05d) rfree\n",where,an++);
- fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
+ PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) rfree\n",where,an++);
+ PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
} )
#endif
@@ -145,7 +142,7 @@ unsigned long size;
else if (nomemok)
return Nullch;
else {
- fputs(no_mem,stderr) FLUSH;
+ PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
my_exit(1);
}
/*NOTREACHED*/
@@ -153,14 +150,14 @@ unsigned long size;
/* safe version of free */
-void
+Free_t
safefree(where)
-char *where;
+Malloc_t where;
{
#if !(defined(I286) || defined(atarist))
- DEBUG_m( fprintf(stderr,"0x%x: (%05d) free\n",where,an++));
+ DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%x: (%05d) free\n",where,an++));
#else
- DEBUG_m( fprintf(stderr,"0x%lx: (%05d) free\n",where,an++));
+ DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",where,an++));
#endif
if (where) {
/*SUPPRESS 701*/
@@ -168,18 +165,58 @@ char *where;
}
}
-#endif /* !safemalloc */
+/* safe version of calloc */
+
+Malloc_t
+safecalloc(count, size)
+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 = 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,an++,(long)count,(long)size));
+#else
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
+#endif
+ if (ptr != Nullch) {
+ memset((void*)ptr, 0, size);
+ return ptr;
+ }
+ else if (nomemok)
+ return Nullch;
+ else {
+ PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
+ my_exit(1);
+ }
+ /*NOTREACHED*/
+}
+
+#endif /* !MYMALLOC */
#ifdef LEAKTEST
#define ALIGN sizeof(long)
-char *
+Malloc_t
safexmalloc(x,size)
I32 x;
MEM_SIZE size;
{
- register char *where;
+ register Malloc_t where;
where = safemalloc(size + ALIGN);
xcount[x]++;
@@ -188,18 +225,18 @@ MEM_SIZE size;
return where + ALIGN;
}
-char *
+Malloc_t
safexrealloc(where,size)
-char *where;
+Malloc_t where;
MEM_SIZE size;
{
- register char *new = saferealloc(where - ALIGN, size + ALIGN);
+ register Malloc_t new = saferealloc(where - ALIGN, size + ALIGN);
return new + ALIGN;
}
void
safexfree(where)
-char *where;
+Malloc_t where;
{
I32 x;
@@ -211,6 +248,22 @@ char *where;
safefree(where);
}
+Malloc_t
+safexcalloc(x,count,size)
+I32 x;
+MEM_SIZE count;
+MEM_SIZE size;
+{
+ register Malloc_t where;
+
+ where = safexmalloc(x, size * count + ALIGN);
+ xcount[x]++;
+ memset((void*)where + ALIGN, 0, size * count);
+ where[0] = x % 100;
+ where[1] = x / 100;
+ return where + ALIGN;
+}
+
static void
xstat()
{
@@ -218,7 +271,7 @@ xstat()
for (i = 0; i < MAXXCOUNT; i++) {
if (xcount[i] > lastxcount[i]) {
- fprintf(stderr,"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]);
+ PerlIO_printf(PerlIO_stderr(),"%2d %2d\t%ld\n", i / 100, i % 100, xcount[i]);
lastxcount[i] = xcount[i];
}
}
@@ -229,28 +282,34 @@ xstat()
/* copy a string up to some (non-backslashed) delimiter, if any */
char *
-cpytill(to,from,fromend,delim,retlen)
+delimcpy(to, toend, from, fromend, delim, retlen)
register char *to;
+register char *toend;
register char *from;
register char *fromend;
register int delim;
I32 *retlen;
{
- char *origto = to;
-
- for (; from < fromend; from++,to++) {
+ register I32 tolen;
+ for (tolen = 0; from < fromend; from++, tolen++) {
if (*from == '\\') {
if (from[1] == delim)
from++;
- else if (from[1] == '\\')
- *to++ = *from++;
+ else {
+ if (to < toend)
+ *to++ = *from;
+ tolen++;
+ from++;
+ }
}
else if (*from == delim)
break;
- *to = *from;
+ if (to < toend)
+ *to++ = *from;
}
- *to = '\0';
- *retlen = to - origto;
+ if (to < toend)
+ *to = '\0';
+ *retlen = tolen;
return from;
}
@@ -353,9 +412,137 @@ char *lend;
return Nullch;
}
-/* Initialize locale (and the fold[] array).*/
+/*
+ * Set up for a new ctype locale.
+ */
+void
+perl_new_ctype(newctype)
+ 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(newcoll)
+ char *newcoll;
+{
+#ifdef USE_LOCALE_COLLATE
+
+ if (! newcoll) {
+ if (collation_name) {
+ ++collation_ix;
+ Safefree(collation_name);
+ collation_name = NULL;
+ collation_standard = TRUE;
+ collxfrm_base = 0;
+ collxfrm_mult = 2;
+ }
+ return;
+ }
+
+ if (! collation_name || strNE(collation_name, newcoll)) {
+ ++collation_ix;
+ Safefree(collation_name);
+ collation_name = savepv(newcoll);
+ 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");
+ collxfrm_base = (fa > mult) ? (fa - mult) : 0;
+ collxfrm_mult = mult;
+ }
+ }
+
+#endif /* USE_LOCALE_COLLATE */
+}
+
+/*
+ * Set up for a new numeric locale.
+ */
+void
+perl_new_numeric(newnum)
+ char *newnum;
+{
+#ifdef USE_LOCALE_NUMERIC
+
+ if (! newnum) {
+ if (numeric_name) {
+ Safefree(numeric_name);
+ numeric_name = NULL;
+ numeric_standard = TRUE;
+ numeric_local = TRUE;
+ }
+ return;
+ }
+
+ if (! numeric_name || strNE(numeric_name, newnum)) {
+ Safefree(numeric_name);
+ numeric_name = savepv(newnum);
+ numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
+ numeric_local = TRUE;
+ }
+
+#endif /* USE_LOCALE_NUMERIC */
+}
+
+void
+perl_set_numeric_standard()
+{
+#ifdef USE_LOCALE_NUMERIC
+
+ if (! numeric_standard) {
+ setlocale(LC_NUMERIC, "C");
+ numeric_standard = TRUE;
+ numeric_local = FALSE;
+ }
+
+#endif /* USE_LOCALE_NUMERIC */
+}
+
+void
+perl_set_numeric_local()
+{
+#ifdef USE_LOCALE_NUMERIC
+
+ if (! numeric_local) {
+ setlocale(LC_NUMERIC, numeric_name);
+ numeric_standard = FALSE;
+ numeric_local = TRUE;
+ }
+
+#endif /* USE_LOCALE_NUMERIC */
+}
+
+
+/*
+ * Initialize locale awareness.
+ */
int
-perl_init_i18nl14n(printwarn)
+perl_init_i18nl10n(printwarn)
int printwarn;
{
int ok = 1;
@@ -364,41 +551,298 @@ perl_init_i18nl14n(printwarn)
* 0 = fallback to C locale,
* -1 = fallback to C locale failed
*/
-#if defined(HAS_SETLOCALE) && defined(LC_CTYPE)
- char * lang = getenv("LANG");
- char * lc_all = getenv("LC_ALL");
- char * lc_ctype = getenv("LC_CTYPE");
- int i;
- if (setlocale(LC_CTYPE, "") == NULL && (lc_all || lc_ctype || lang)) {
- if (printwarn) {
- fprintf(stderr, "warning: setlocale(LC_CTYPE, \"\") failed.\n");
- fprintf(stderr,
- "warning: LC_ALL = \"%s\", LC_CTYPE = \"%s\", LANG = \"%s\",\n",
- lc_all ? lc_all : "(null)",
- lc_ctype ? lc_ctype : "(null)",
- lang ? lang : "(null)"
- );
- fprintf(stderr, "warning: falling back to the \"C\" locale.\n");
+#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 = getenv("LC_ALL");
+ char *lang = 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 || getenv("LC_CTYPE")))
+ ? "" : Nullch)))
+ setlocale_failure = TRUE;
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ if (! (curcoll = setlocale(LC_COLLATE,
+ (!done && (lang || getenv("LC_COLLATE")))
+ ? "" : Nullch)))
+ setlocale_failure = TRUE;
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ if (! (curnum = setlocale(LC_NUMERIC,
+ (!done && (lang || 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 = 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");
}
- ok = 0;
- if (setlocale(LC_CTYPE, "C") == NULL)
+
+#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;
- }
+ }
- for (i = 0; i < 256; i++) {
- if (isUPPER(i)) fold[i] = toLOWER(i);
- else if (isLOWER(i)) fold[i] = toUPPER(i);
- else fold[i] = i;
+#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 */
}
-#endif
+
+#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(printwarn)
+ 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(s, len, xlen)
+ const char *s;
+ STRLEN len;
+ STRLEN *xlen;
+{
+ char *xbuf;
+ STRLEN xalloc, xin, xout;
+
+ /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
+ /* the +1 is for the terminating NUL. */
+
+ xalloc = sizeof(collation_ix) + collxfrm_base + (collxfrm_mult * len) + 1;
+ New(171, xbuf, xalloc, char);
+ if (! xbuf)
+ goto bad;
+
+ *(U32*)xbuf = collation_ix;
+ xout = sizeof(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(collation_ix);
+ return xbuf;
+
+ bad:
+ Safefree(xbuf);
+ *xlen = 0;
+ return NULL;
+}
+
+#endif /* USE_LOCALE_COLLATE */
+
void
-fbm_compile(sv, iflag)
+fbm_compile(sv)
SV *sv;
-I32 iflag;
{
register unsigned char *s;
register unsigned char *table;
@@ -418,52 +862,24 @@ I32 iflag;
i = 0;
while (s >= (unsigned char*)(SvPVX(sv)))
{
- if (table[*s] == len) {
-#ifndef pdp11
- if (iflag)
- table[*s] = table[fold[*s]] = i;
-#else
- if (iflag) {
- I32 j;
- j = fold[*s];
- table[j] = i;
- table[*s] = i;
- }
-#endif /* pdp11 */
- else
- table[*s] = i;
- }
+ if (table[*s] == len)
+ table[*s] = i;
s--,i++;
}
sv_upgrade(sv, SVt_PVBM);
- sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
+ sv_magic(sv, Nullsv, 'B', Nullch, 0); /* deep magic */
SvVALID_on(sv);
s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
- if (iflag) {
- register U32 tmp, foldtmp;
- SvCASEFOLD_on(sv);
- for (i = 0; i < len; i++) {
- tmp=freq[s[i]];
- foldtmp=freq[fold[s[i]]];
- if (tmp < frequency && foldtmp < frequency) {
- rarest = i;
- /* choose most frequent among the two */
- frequency = (tmp > foldtmp) ? tmp : foldtmp;
- }
- }
- }
- else {
- for (i = 0; i < len; i++) {
- if (freq[s[i]] < frequency) {
- rarest = i;
- frequency = freq[s[i]];
- }
+ 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(fprintf(stderr,"rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
}
char *
@@ -493,91 +909,50 @@ SV *littlestr;
if (littlelen > bigend - big)
return Nullch;
little = (unsigned char*)SvPVX(littlestr);
- if (SvCASEFOLD(littlestr)) { /* oops, fake it */
- big = bigend - littlelen; /* just start near end */
- if (bigend[-1] == '\n' && little[littlelen-1] != '\n')
- big--;
- }
- else {
- s = bigend - littlelen;
- if (*s == *little && bcmp((char*)s,(char*)little,littlelen)==0)
- return (char*)s; /* how sweet it is */
- else if (bigend[-1] == '\n' && little[littlelen-1] != '\n'
- && s > big) {
- s--;
- if (*s == *little && bcmp((char*)s,(char*)little,littlelen)==0)
- return (char*)s;
- }
- return Nullch;
+ s = bigend - littlelen;
+ if (*s == *little && memEQ((char*)s,(char*)little,littlelen))
+ return (char*)s; /* how sweet it is */
+ else if (bigend[-1] == '\n' && little[littlelen-1] != '\n'
+ && s > big) {
+ s--;
+ if (*s == *little && memEQ((char*)s,(char*)little,littlelen))
+ return (char*)s;
}
+ return Nullch;
}
table = (unsigned char*)(SvPVX(littlestr) + littlelen + 1);
if (--littlelen >= bigend - big)
return Nullch;
s = big + littlelen;
oldlittle = little = table - 2;
- if (SvCASEFOLD(littlestr)) { /* case insensitive? */
- if (s < bigend) {
- top1:
- /*SUPPRESS 560*/
- if (tmp = table[*s]) {
+ if (s < bigend) {
+ top2:
+ /*SUPPRESS 560*/
+ if (tmp = table[*s]) {
#ifdef POINTERRIGOR
- if (bigend - s > tmp) {
- s += tmp;
- goto top1;
- }
+ if (bigend - s > tmp) {
+ s += tmp;
+ goto top2;
+ }
#else
- if ((s += tmp) < bigend)
- goto top1;
+ if ((s += tmp) < bigend)
+ goto top2;
#endif
- return Nullch;
- }
- else {
- tmp = littlelen; /* less expensive than calling strncmp() */
- olds = s;
- while (tmp--) {
- if (*--s == *--little || fold[*s] == *little)
- continue;
- s = olds + 1; /* here we pay the price for failure */
- little = oldlittle;
- if (s < bigend) /* fake up continue to outer loop */
- goto top1;
- return Nullch;
- }
- return (char *)s;
- }
+ return Nullch;
}
- }
- else {
- 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)
+ else {
+ tmp = littlelen; /* less expensive than calling strncmp() */
+ olds = s;
+ while (tmp--) {
+ if (*--s == *--little)
+ continue;
+ s = olds + 1; /* here we pay the price for failure */
+ little = oldlittle;
+ if (s < bigend) /* fake up continue to outer loop */
goto top2;
-#endif
return Nullch;
}
- else {
- tmp = littlelen; /* less expensive than calling strncmp() */
- olds = s;
- while (tmp--) {
- if (*--s == *--little)
- continue;
- 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;
- }
- return (char *)s;
- }
+ return (char *)s;
}
}
return Nullch;
@@ -610,96 +985,66 @@ SV *littlestr;
return Nullch;
}
#ifdef POINTERRIGOR
- if (SvCASEFOLD(littlestr)) { /* case insignificant? */
- do {
- if (big[pos-previous] != first && big[pos-previous] != fold[first])
- continue;
- for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
- if (x >= bigend)
- return Nullch;
- if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
- s--;
- break;
- }
- }
- if (s == littleend)
- return (char *)(big+pos-previous);
- } while (
- pos += screamnext[pos] /* does this goof up anywhere? */
- );
- }
- else {
- do {
- if (big[pos-previous] != first)
- continue;
- for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
- if (x >= bigend)
- return Nullch;
- if (*s++ != *x++) {
- s--;
- break;
- }
+ do {
+ if (big[pos-previous] != first)
+ continue;
+ for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
+ if (x >= bigend)
+ return Nullch;
+ if (*s++ != *x++) {
+ s--;
+ break;
}
- if (s == littleend)
- return (char *)(big+pos-previous);
- } while ( pos += screamnext[pos] );
- }
+ }
+ if (s == littleend)
+ return (char *)(big+pos-previous);
+ } while ( pos += screamnext[pos] );
#else /* !POINTERRIGOR */
big -= previous;
- if (SvCASEFOLD(littlestr)) { /* case insignificant? */
- do {
- if (big[pos] != first && big[pos] != fold[first])
- continue;
- for (x=big+pos+1,s=little; s < littleend; /**/ ) {
- if (x >= bigend)
- return Nullch;
- if (*s++ != *x++ && fold[*(s-1)] != *(x-1)) {
- s--;
- break;
- }
- }
- if (s == littleend)
- return (char *)(big+pos);
- } while (
- pos += screamnext[pos] /* does this goof up anywhere? */
- );
- }
- else {
- do {
- if (big[pos] != first)
- continue;
- for (x=big+pos+1,s=little; s < littleend; /**/ ) {
- if (x >= bigend)
- return Nullch;
- if (*s++ != *x++) {
- s--;
- break;
- }
+ do {
+ if (big[pos] != first)
+ continue;
+ for (x=big+pos+1,s=little; s < littleend; /**/ ) {
+ if (x >= bigend)
+ return Nullch;
+ if (*s++ != *x++) {
+ s--;
+ break;
}
- if (s == littleend)
- return (char *)(big+pos);
- } while (
- pos += screamnext[pos]
- );
- }
+ }
+ if (s == littleend)
+ return (char *)(big+pos);
+ } while ( pos += screamnext[pos] );
#endif /* POINTERRIGOR */
return Nullch;
}
I32
-ibcmp(a,b,len)
-register U8 *a;
-register U8 *b;
+ibcmp(s1, s2, len)
+char *s1, *s2;
register I32 len;
{
+ register U8 *a = (U8 *)s1;
+ register U8 *b = (U8 *)s2;
while (len--) {
- if (*a == *b) {
- a++,b++;
- continue;
- }
- if (fold[*a++] == *b++)
- continue;
- return 1;
+ if (*a != *b && *a != fold[*b])
+ return 1;
+ a++,b++;
+ }
+ return 0;
+}
+
+I32
+ibcmp_locale(s1, s2, len)
+char *s1, *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;
}
@@ -732,226 +1077,150 @@ register I32 len;
return newaddr;
}
-#if !defined(I_STDARG) && !defined(I_VARARGS)
+/* the SV for form() and mess() is not kept in an arena */
-/*
- * Fallback on the old hackers way of doing varargs
- */
+static SV *
+mess_alloc()
+{
+ 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;
+}
-/*VARARGS1*/
+#ifdef I_STDARG
char *
-mess(pat,a1,a2,a3,a4)
-char *pat;
-long a1, a2, a3, a4;
+form(const char* pat, ...)
+#else
+/*VARARGS0*/
+char *
+form(pat, va_alist)
+ const char *pat;
+ va_dcl
+#endif
{
- char *s;
- char *s_start;
- I32 usermess = strEQ(pat,"%s");
- SV *tmpstr;
+ va_list args;
+#ifdef I_STDARG
+ va_start(args, pat);
+#else
+ va_start(args);
+#endif
+ if (!mess_sv)
+ mess_sv = mess_alloc();
+ sv_vsetpvfn(mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
+ va_end(args);
+ return SvPVX(mess_sv);
+}
- s = s_start = buf;
- if (usermess) {
- tmpstr = sv_newmortal();
- sv_setpv(tmpstr, (char*)a1);
- *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
- }
- else {
- (void)sprintf(s,pat,a1,a2,a3,a4);
- s += strlen(s);
- }
+char *
+mess(pat, args)
+ const char *pat;
+ va_list *args;
+{
+ SV *sv;
+ static char dgd[] = " during global destruction.\n";
- if (s[-1] != '\n') {
+ if (!mess_sv)
+ mess_sv = mess_alloc();
+ sv = mess_sv;
+ sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
+ if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
if (dirty)
- strcpy(s, " during global destruction.\n");
+ sv_catpv(sv, dgd);
else {
- if (curcop->cop_line) {
- (void)sprintf(s," at %s line %ld",
- SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
- s += strlen(s);
- }
- if (GvIO(last_in_gv) &&
- IoLINES(GvIOp(last_in_gv)) ) {
- (void)sprintf(s,", <%s> %s %ld",
- last_in_gv == argvgv ? "" : GvENAME(last_in_gv),
- strEQ(rs,"\n") ? "line" : "chunk",
- (long)IoLINES(GvIOp(last_in_gv)));
- s += strlen(s);
+ if (curcop->cop_line)
+ sv_catpvf(sv, " at %_ line %ld",
+ GvSV(curcop->cop_filegv), (long)curcop->cop_line);
+ if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
+ bool line_mode = (RsSIMPLE(rs) &&
+ SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
+ sv_catpvf(sv, ", <%s> %s %ld",
+ last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
+ line_mode ? "line" : "chunk",
+ (long)IoLINES(GvIOp(last_in_gv)));
}
- (void)strcpy(s,".\n");
- s += 2;
+ sv_catpv(sv, ".\n");
}
- if (usermess)
- sv_catpv(tmpstr,buf+1);
- }
-
- if (s - s_start >= sizeof(buf)) { /* Ooops! */
- if (usermess)
- fputs(SvPVX(tmpstr), stderr);
- else
- fputs(buf, stderr);
- fputs("panic: message overflow - memory corrupted!\n",stderr);
- my_exit(1);
}
- if (usermess)
- return SvPVX(tmpstr);
- else
- return buf;
+ return SvPVX(sv);
}
-/*VARARGS1*/
-void croak(pat,a1,a2,a3,a4)
-char *pat;
-long a1, a2, a3, a4;
-{
- char *tmps;
- char *message;
- HV *stash;
- GV *gv;
- CV *cv;
-
- message = mess(pat,a1,a2,a3,a4);
- if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
- dSP;
-
- PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
- PUTBACK;
- perl_call_sv((SV*)cv, G_DISCARD);
- }
- if (in_eval) {
- restartop = die_where(message);
- Siglongjmp(top_env, 3);
- }
- fputs(message,stderr);
- (void)Fflush(stderr);
- if (e_tmpname) {
- if (e_fp) {
- fclose(e_fp);
- e_fp = Nullfp;
- }
- (void)UNLINK(e_tmpname);
- Safefree(e_tmpname);
- e_tmpname = Nullch;
- }
- statusvalue = SHIFTSTATUS(statusvalue);
-#ifdef VMS
- my_exit((U32)vaxc$errno?vaxc$errno:errno?errno:statusvalue?statusvalue:SS$_ABORT);
+#ifdef I_STDARG
+OP *
+die(const char* pat, ...)
#else
- my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
+/*VARARGS0*/
+OP *
+die(pat, va_alist)
+ const char *pat;
+ va_dcl
#endif
-}
-
-/*VARARGS1*/
-void warn(pat,a1,a2,a3,a4)
-char *pat;
-long a1, a2, a3, a4;
{
+ va_list args;
char *message;
- SV *sv;
+ I32 oldrunlevel = runlevel;
+ int was_in_eval = in_eval;
HV *stash;
GV *gv;
CV *cv;
- message = mess(pat,a1,a2,a3,a4);
- if (warnhook && (cv = sv_2cv(warnhook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
- dSP;
-
- PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
- PUTBACK;
- perl_call_sv((SV*)cv, G_DISCARD);
+ /* We have to switch back to mainstack or die_where may try to pop
+ * the eval block from the wrong stack if die is being called from a
+ * signal handler. - dkindred@cs.cmu.edu */
+ if (curstack != mainstack) {
+ dSP;
+ SWITCHSTACK(curstack, mainstack);
}
- else {
- fputs(message,stderr);
-#ifdef LEAKTEST
- DEBUG_L(xstat());
-#endif
- (void)Fflush(stderr);
- }
-}
-
-#else /* !defined(I_STDARG) && !defined(I_VARARGS) */
#ifdef I_STDARG
-char *
-mess(char *pat, va_list *args)
-#else
-/*VARARGS0*/
-char *
-mess(pat, args)
- char *pat;
- va_list *args;
-#endif
-{
- char *s;
- char *s_start;
- SV *tmpstr;
- I32 usermess;
-#ifndef HAS_VPRINTF
-#ifdef USE_CHAR_VSPRINTF
- char *vsprintf();
+ va_start(args, pat);
#else
- I32 vsprintf();
-#endif
+ va_start(args);
#endif
+ message = mess(pat, &args);
+ va_end(args);
- s = s_start = buf;
- usermess = strEQ(pat, "%s");
- if (usermess) {
- tmpstr = sv_newmortal();
- sv_setpv(tmpstr, va_arg(*args, char *));
- *s++ = SvPVX(tmpstr)[SvCUR(tmpstr)-1];
- }
- else {
- (void) vsprintf(s,pat,*args);
- s += strlen(s);
- }
- va_end(*args);
-
- if (s[-1] != '\n') {
- if (dirty)
- strcpy(s, " during global destruction.\n");
- else {
- if (curcop->cop_line) {
- (void)sprintf(s," at %s line %ld",
- SvPVX(GvSV(curcop->cop_filegv)), (long)curcop->cop_line);
- s += strlen(s);
- }
- if (GvIO(last_in_gv) && IoLINES(GvIOp(last_in_gv))) {
- bool line_mode = (RsSIMPLE(rs) &&
- SvLEN(rs) == 1 && *SvPVX(rs) == '\n');
- (void)sprintf(s,", <%s> %s %ld",
- last_in_gv == argvgv ? "" : GvNAME(last_in_gv),
- line_mode ? "line" : "chunk",
- (long)IoLINES(GvIOp(last_in_gv)));
- s += strlen(s);
- }
- (void)strcpy(s,".\n");
- s += 2;
+ if (diehook) {
+ /* sv_2cv might call croak() */
+ SV *olddiehook = diehook;
+ ENTER;
+ SAVESPTR(diehook);
+ 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);
+
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
}
- if (usermess)
- sv_catpv(tmpstr,buf+1);
}
- if (s - s_start >= sizeof(buf)) { /* Ooops! */
- if (usermess)
- fputs(SvPVX(tmpstr), stderr);
- else
- fputs(buf, stderr);
- fputs("panic: message overflow - memory corrupted!\n",stderr);
- my_exit(1);
- }
- if (usermess)
- return SvPVX(tmpstr);
- else
- return buf;
+ restartop = die_where(message);
+ if ((!restartop && was_in_eval) || oldrunlevel > 1)
+ JMPENV_JUMP(3);
+ return restartop;
}
#ifdef I_STDARG
void
-croak(char* pat, ...)
+croak(const char* pat, ...)
#else
/*VARARGS0*/
void
@@ -973,45 +1242,47 @@ croak(pat, va_alist)
#endif
message = mess(pat, &args);
va_end(args);
- if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
- dSP;
-
- PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
- PUTBACK;
- perl_call_sv((SV*)cv, G_DISCARD);
+ if (diehook) {
+ /* sv_2cv might call croak() */
+ SV *olddiehook = diehook;
+ ENTER;
+ SAVESPTR(diehook);
+ 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);
+
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
+ }
}
if (in_eval) {
restartop = die_where(message);
- Siglongjmp(top_env, 3);
- }
- fputs(message,stderr);
- (void)Fflush(stderr);
- if (e_tmpname) {
- if (e_fp) {
- fclose(e_fp);
- e_fp = Nullfp;
- }
- (void)UNLINK(e_tmpname);
- Safefree(e_tmpname);
- e_tmpname = Nullch;
+ JMPENV_JUMP(3);
}
- statusvalue = SHIFTSTATUS(statusvalue);
-#ifdef VMS
- my_exit((U32)(vaxc$errno?vaxc$errno:(statusvalue?statusvalue:44)));
-#else
- my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
-#endif
+ PerlIO_puts(PerlIO_stderr(),message);
+ (void)PerlIO_flush(PerlIO_stderr());
+ my_failure_exit();
}
void
#ifdef I_STDARG
-warn(char* pat,...)
+warn(const char* pat,...)
#else
/*VARARGS0*/
warn(pat,va_alist)
- char *pat;
+ const char *pat;
va_dcl
#endif
{
@@ -1029,26 +1300,41 @@ warn(pat,va_alist)
message = mess(pat, &args);
va_end(args);
- if (warnhook && (cv = sv_2cv(warnhook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
- dSP;
-
- PUSHMARK(sp);
- EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
- PUTBACK;
- perl_call_sv((SV*)cv, G_DISCARD);
+ if (warnhook) {
+ /* sv_2cv might call warn() */
+ SV *oldwarnhook = warnhook;
+ ENTER;
+ SAVESPTR(warnhook);
+ 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);
+
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
+ return;
+ }
}
- else {
- fputs(message,stderr);
+ PerlIO_puts(PerlIO_stderr(),message);
#ifdef LEAKTEST
- DEBUG_L(xstat());
+ DEBUG_L(xstat());
#endif
- (void)Fflush(stderr);
- }
+ (void)PerlIO_flush(PerlIO_stderr());
}
-#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
#ifndef VMS /* VMS' my_setenv() is in VMS.c */
+#ifndef WIN32
void
my_setenv(nam,val)
char *nam, *val;
@@ -1069,6 +1355,7 @@ char *nam, *val;
environ = tmpenv; /* tell exec where it is now */
}
if (!val) {
+ Safefree(environ[i]);
while (environ[i]) {
environ[i] = environ[i+1];
i++;
@@ -1095,6 +1382,74 @@ char *nam, *val;
#endif /* MSDOS */
}
+#else /* if WIN32 */
+
+void
+my_setenv(nam,val)
+char *nam, *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)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(nam)
char *nam;
@@ -1102,11 +1457,18 @@ char *nam;
register I32 i, len = strlen(nam);
for (i = 0; environ[i]; i++) {
- if (strnEQ(environ[i],nam,len) && environ[i][len] == '=')
+ 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
@@ -1144,6 +1506,21 @@ register I32 len;
}
#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)
@@ -1158,22 +1535,24 @@ register I32 len;
}
#endif
-#ifndef HAS_MEMCMP
+#if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
I32
my_memcmp(s1,s2,len)
-register unsigned char *s1;
-register unsigned char *s2;
+char *s1;
+char *s2;
register I32 len;
{
+ register U8 *a = (U8 *)s1;
+ register U8 *b = (U8 *)s2;
register I32 tmp;
while (len--) {
- if (tmp = *s1++ - *s2++)
+ if (tmp = *a++ - *b++)
return tmp;
}
return 0;
}
-#endif /* HAS_MEMCMP */
+#endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
#if defined(I_STDARG) || defined(I_VARARGS)
#ifndef HAS_VPRINTF
@@ -1184,7 +1563,9 @@ char *
int
#endif
vsprintf(dest, pat, args)
-char *dest, *pat, *args;
+char *dest;
+const char *pat;
+char *args;
{
FILE fakebuf;
@@ -1203,14 +1584,6 @@ char *dest, *pat, *args;
#endif
}
-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 /* HAS_VPRINTF */
#endif /* I_VARARGS || I_STDARGS */
@@ -1364,9 +1737,9 @@ VTOH(vtohs,short)
VTOH(vtohl,long)
#endif
-#if !defined(DOSISH) && !defined(VMS) /* VMS' my_popen() is in
- VMS.c, same with OS/2. */
-FILE *
+ /* VMS' my_popen() is in VMS.c, same with OS/2. */
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
+PerlIO *
my_popen(cmd,mode)
char *cmd;
char *mode;
@@ -1377,15 +1750,18 @@ char *mode;
SV *sv;
I32 doexec = strNE(cmd,"-");
+#ifdef OS2
+ if (doexec) {
+ return my_syspopen(cmd,mode);
+ }
+#endif
if (pipe(p) < 0)
return Nullfp;
this = (*mode == 'w');
that = !this;
- if (tainting) {
- if (doexec) {
- taint_env();
- taint_proper("Insecure %s%s", "EXEC");
- }
+ if (doexec && tainting) {
+ taint_env();
+ taint_proper("Insecure %s%s", "EXEC");
}
while ((pid = (doexec?vfork():fork())) < 0) {
if (errno != EAGAIN) {
@@ -1421,7 +1797,7 @@ char *mode;
}
/*SUPPRESS 560*/
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
- sv_setiv(GvSV(tmpgv),(I32)getpid());
+ sv_setiv(GvSV(tmpgv), (IV)getpid());
forkprocess = 0;
hv_clear(pidstatus); /* we have no children */
return Nullfp;
@@ -1439,17 +1815,19 @@ char *mode;
(void)SvUPGRADE(sv,SVt_IV);
SvIVX(sv) = pid;
forkprocess = pid;
- return fdopen(p[this], mode);
+ return PerlIO_fdopen(p[this], mode);
}
#else
-#if defined(atarist)
+#if defined(atarist) || defined(DJGPP)
FILE *popen();
-FILE *
+PerlIO *
my_popen(cmd,mode)
char *cmd;
char *mode;
{
- return popen(cmd, mode);
+ /* Needs work for PerlIO ! */
+ /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
+ return popen(PerlIO_exportFILE(cmd, 0), mode);
}
#endif
@@ -1462,12 +1840,12 @@ char *s;
int fd;
struct stat tmpstatbuf;
- fprintf(stderr,"%s", s);
+ PerlIO_printf(PerlIO_stderr(),"%s", s);
for (fd = 0; fd < 32; fd++) {
if (Fstat(fd,&tmpstatbuf) >= 0)
- fprintf(stderr," %d",fd);
+ PerlIO_printf(PerlIO_stderr()," %d",fd);
}
- fprintf(stderr,"\n");
+ PerlIO_printf(PerlIO_stderr(),"\n");
}
#endif
@@ -1483,15 +1861,23 @@ int newfd;
close(newfd);
return fcntl(oldfd, F_DUPFD, newfd);
#else
- int fdtmp[256];
+#define DUP2_MAX_FDS 256
+ int fdtmp[DUP2_MAX_FDS];
I32 fdx = 0;
int fd;
if (oldfd == newfd)
return oldfd;
close(newfd);
- while ((fd = dup(oldfd)) != newfd && fd >= 0) /* good enough for low fd's */
+ /* good enough for low fd's... */
+ while ((fd = dup(oldfd)) != newfd && fd >= 0) {
+ if (fdx >= DUP2_MAX_FDS) {
+ close(fd);
+ fd = -1;
+ break;
+ }
fdtmp[fdx++] = fd;
+ }
while (fdx > 0)
close(fdtmp[--fdx]);
return fd;
@@ -1499,34 +1885,167 @@ int newfd;
}
#endif
-#if !defined(DOSISH) && !defined(VMS) /* VMS' my_popen() is in VMS.c */
+
+#ifdef HAS_SIGACTION
+
+Sighandler_t
+rsignal(signo, handler)
+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
+ if (sigaction(signo, &act, &oact) == -1)
+ return SIG_ERR;
+ else
+ return oact.sa_handler;
+}
+
+Sighandler_t
+rsignal_state(signo)
+int signo;
+{
+ struct sigaction oact;
+
+ if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
+ return SIG_ERR;
+ else
+ return oact.sa_handler;
+}
+
+int
+rsignal_save(signo, handler, 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
+ return sigaction(signo, &act, save);
+}
+
+int
+rsignal_restore(signo, save)
+int signo;
+Sigsave_t *save;
+{
+ return sigaction(signo, save, (struct sigaction *)NULL);
+}
+
+#else /* !HAS_SIGACTION */
+
+Sighandler_t
+rsignal(signo, handler)
+int signo;
+Sighandler_t handler;
+{
+ return signal(signo, handler);
+}
+
+static int sig_trapped;
+
+static
+Signal_t
+sig_trap(signo)
+int signo;
+{
+ sig_trapped++;
+}
+
+Sighandler_t
+rsignal_state(signo)
+int signo;
+{
+ Sighandler_t oldsig;
+
+ sig_trapped = 0;
+ oldsig = signal(signo, sig_trap);
+ signal(signo, oldsig);
+ if (sig_trapped)
+ kill(getpid(), signo);
+ return oldsig;
+}
+
+int
+rsignal_save(signo, handler, save)
+int signo;
+Sighandler_t handler;
+Sigsave_t *save;
+{
+ *save = signal(signo, handler);
+ return (*save == SIG_ERR) ? -1 : 0;
+}
+
+int
+rsignal_restore(signo, save)
+int signo;
+Sigsave_t *save;
+{
+ return (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(ptr)
-FILE *ptr;
+PerlIO *ptr;
{
- Signal_t (*hstat)(), (*istat)(), (*qstat)();
+ Sigsave_t hstat, istat, qstat;
int status;
SV **svp;
int pid;
+ bool close_failed;
+ int saved_errno;
+#ifdef VMS
+ int saved_vaxc_errno;
+#endif
- svp = av_fetch(fdpid,fileno(ptr),TRUE);
+ svp = av_fetch(fdpid,PerlIO_fileno(ptr),TRUE);
pid = (int)SvIVX(*svp);
SvREFCNT_dec(*svp);
*svp = &sv_undef;
- fclose(ptr);
+#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 UTS
if(kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */
#endif
- hstat = signal(SIGHUP, SIG_IGN);
- istat = signal(SIGINT, SIG_IGN);
- qstat = signal(SIGQUIT, SIG_IGN);
+ rsignal_save(SIGHUP, SIG_IGN, &hstat);
+ rsignal_save(SIGINT, SIG_IGN, &istat);
+ rsignal_save(SIGQUIT, SIG_IGN, &qstat);
do {
pid = wait4pid(pid, &status, 0);
} while (pid == -1 && errno == EINTR);
- signal(SIGHUP, hstat);
- signal(SIGINT, istat);
- signal(SIGQUIT, qstat);
- return(pid < 0 ? pid : status);
+ rsignal_restore(SIGHUP, &hstat);
+ rsignal_restore(SIGINT, &istat);
+ rsignal_restore(SIGQUIT, &qstat);
+ if (close_failed) {
+ SETERRNO(saved_errno, saved_vaxc_errno);
+ return -1;
+ }
+ return(pid < 0 ? pid : status == 0 ? 0 : (errno = 0, status));
}
#endif /* !DOSISH */
@@ -1539,7 +2058,7 @@ int flags;
{
SV *sv;
SV** svp;
- char spid[16];
+ char spid[TYPE_CHARS(int)];
if (!pid)
return -1;
@@ -1566,11 +2085,17 @@ int flags;
}
}
#ifdef HAS_WAITPID
+# ifdef HAS_WAITPID_RUNTIME
+ if (!HAS_WAITPID_RUNTIME)
+ goto hard_way;
+# endif
return waitpid(pid,statusp,flags);
-#else
-#ifdef HAS_WAIT4
+#endif
+#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
-#else
+#endif
+#if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
+ hard_way:
{
I32 result;
if (flags)
@@ -1584,7 +2109,6 @@ int flags;
return result;
}
#endif
-#endif
}
#endif /* !DOSISH */
@@ -1595,7 +2119,7 @@ int pid;
int status;
{
register SV *sv;
- char spid[16];
+ char spid[TYPE_CHARS(int)];
sprintf(spid, "%d", pid);
sv = *hv_fetch(pidstatus,spid,strlen(spid),TRUE);
@@ -1604,13 +2128,23 @@ int status;
return;
}
-#if defined(atarist) || defined(OS2)
+#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)
-FILE *ptr;
+#endif
+PerlIO *ptr;
{
- return pclose(ptr);
+ /* Needs work for PerlIO ! */
+ FILE *f = PerlIO_findFILE(ptr);
+ I32 result = pclose(f);
+ PerlIO_releaseFILE(ptr,f);
+ return result;
}
#endif
@@ -1660,29 +2194,6 @@ double f;
#ifndef CASTI32
-/* Look for MAX and MIN integral values. If we can't find them,
- we'll use 32-bit two's complement defaults.
-*/
-#ifndef LONG_MAX
-# ifdef MAXLONG /* Often used in <values.h> */
-# define LONG_MAX MAXLONG
-# else
-# define LONG_MAX 2147483647L
-# endif
-#endif
-
-#ifndef LONG_MIN
-# define LONG_MIN (-LONG_MAX - 1)
-#endif
-
-#ifndef ULONG_MAX
-# ifdef MAXULONG
-# define LONG_MAX MAXULONG
-# else
-# define ULONG_MAX 4294967295L
-# endif
-#endif
-
/* 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
@@ -1693,18 +2204,24 @@ double f;
ccflags.
--Andy Dougherty <doughera@lafcol.lafayette.edu>
*/
-#ifndef MY_ULONG_MAX
-# define MY_ULONG_MAX ((UV)LONG_MAX * (UV)2 + (UV)1)
+
+/* 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 >= LONG_MAX)
- return (I32) LONG_MAX;
- if (f <= LONG_MIN)
- return (I32) LONG_MIN;
+ if (f >= I32_MAX)
+ return (I32) I32_MAX;
+ if (f <= I32_MIN)
+ return (I32) I32_MIN;
return (I32) f;
}
@@ -1712,10 +2229,10 @@ IV
cast_iv(f)
double f;
{
- if (f >= LONG_MAX)
- return (IV) LONG_MAX;
- if (f <= LONG_MIN)
- return (IV) LONG_MIN;
+ if (f >= IV_MAX)
+ return (IV) IV_MAX;
+ if (f <= IV_MIN)
+ return (IV) IV_MIN;
return (IV) f;
}
@@ -1723,8 +2240,8 @@ UV
cast_uv(f)
double f;
{
- if (f >= MY_ULONG_MAX)
- return (UV) MY_ULONG_MAX;
+ if (f >= MY_UV_MAX)
+ return (UV) MY_UV_MAX;
return (UV) f;
}
@@ -1740,10 +2257,7 @@ char *b;
char *fb = strrchr(b,'/');
struct stat tmpstatbuf1;
struct stat tmpstatbuf2;
-#ifndef MAXPATHLEN
-#define MAXPATHLEN 1024
-#endif
- char tmpbuf[MAXPATHLEN+1];
+ SV *tmpsv = sv_newmortal();
if (fa)
fa++;
@@ -1756,34 +2270,39 @@ char *b;
if (strNE(a,b))
return FALSE;
if (fa == a)
- strcpy(tmpbuf,".");
+ sv_setpv(tmpsv, ".");
else
- strncpy(tmpbuf, a, fa - a);
- if (Stat(tmpbuf, &tmpstatbuf1) < 0)
+ sv_setpvn(tmpsv, a, fa - a);
+ if (Stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
return FALSE;
if (fb == b)
- strcpy(tmpbuf,".");
+ sv_setpv(tmpsv, ".");
else
- strncpy(tmpbuf, b, fb - b);
- if (Stat(tmpbuf, &tmpstatbuf2) < 0)
+ sv_setpvn(tmpsv, b, fb - b);
+ if (Stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
return FALSE;
return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
}
#endif /* !HAS_RENAME */
-unsigned long
+UV
scan_oct(start, len, retlen)
char *start;
I32 len;
I32 *retlen;
{
register char *s = start;
- register unsigned long retval = 0;
+ register UV retval = 0;
+ bool overflowed = FALSE;
while (len && *s >= '0' && *s <= '7') {
- retval <<= 3;
- retval |= *s++ - '0';
+ register UV n = retval << 3;
+ if (!overflowed && (n >> 3) != retval) {
+ warn("Integer overflow in octal number");
+ overflowed = TRUE;
+ }
+ retval = n | (*s++ - '0');
len--;
}
if (dowarn && len && (*s == '8' || *s == '9'))
@@ -1792,21 +2311,40 @@ I32 *retlen;
return retval;
}
-unsigned long
+UV
scan_hex(start, len, retlen)
char *start;
I32 len;
I32 *retlen;
{
register char *s = start;
- register unsigned long retval = 0;
+ register UV retval = 0;
+ bool overflowed = FALSE;
char *tmp;
while (len-- && *s && (tmp = strchr(hexdigit, *s))) {
- retval <<= 4;
- retval |= (tmp - hexdigit) & 15;
+ register UV n = retval << 4;
+ if (!overflowed && (n >> 4) != retval) {
+ warn("Integer overflow in hex number");
+ overflowed = TRUE;
+ }
+ retval = n | (tmp - hexdigit) & 15;
s++;
}
*retlen = s - start;
return retval;
}
+
+
+#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()
+{
+ return HUGE_VAL;
+}
+#endif
diff --git a/gnu/usr.bin/perl/util.h b/gnu/usr.bin/perl/util.h
index df518467342..7dcf9ceab51 100644
--- a/gnu/usr.bin/perl/util.h
+++ b/gnu/usr.bin/perl/util.h
@@ -1,6 +1,6 @@
/* util.h
*
- * Copyright (c) 1991-1994, Larry Wall
+ * 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/gnu/usr.bin/perl/utils/Makefile b/gnu/usr.bin/perl/utils/Makefile
index 33947c87f18..3c343c82b70 100644
--- a/gnu/usr.bin/perl/utils/Makefile
+++ b/gnu/usr.bin/perl/utils/Makefile
@@ -4,16 +4,28 @@ PERL = ../miniperl
# 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
-
-pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL
-plextract = c2ph h2ph h2xs perlbug perldoc pl2pm
+pl = c2ph.PL h2ph.PL h2xs.PL perlbug.PL perldoc.PL pl2pm.PL splain.PL
+plextract = c2ph h2ph h2xs perlbug perldoc pl2pm splain
all: $(plextract)
$(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
+
clean:
realclean:
diff --git a/gnu/usr.bin/perl/utils/c2ph.PL b/gnu/usr.bin/perl/utils/c2ph.PL
index 219af029331..e732d4d52ae 100644
--- a/gnu/usr.bin/perl/utils/c2ph.PL
+++ b/gnu/usr.bin/perl/utils/c2ph.PL
@@ -12,10 +12,9 @@ use File::Basename qw(&basename &dirname);
# 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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
@@ -25,9 +24,9 @@ print "Extracting $file (with variable substitutions)\n";
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
- eval 'exec perl -S \$0 "\$@"'
- if 0;
+$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.
@@ -46,7 +45,7 @@ print OUT <<'!NO!SUBS!';
=head1 NAME
-c2ph,pstruct - Dump C structures as generated from 'cc -g -S' stabs
+c2ph, pstruct - Dump C structures as generated from C<cc -g -S> stabs
=head1 SYNOPSIS
@@ -95,44 +94,44 @@ 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.
+ 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
@@ -140,10 +139,10 @@ 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 -g option on native BSD compilers and GCC
+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 -\?, and a long usage message
+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.
@@ -193,7 +192,7 @@ them in terms of packages and functions. Consider the following program:
As you see, the name of the package is the name of the structure. Regular
-fields are just their own names. Plus the follwoing accessor functions are
+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
@@ -251,7 +250,7 @@ compiler and gcc.
Anyway, here it is. Should run on perl v4 or greater. Maybe less.
---tom
+ --tom
=cut
@@ -1252,7 +1251,7 @@ main() {
EOF
for $type (@intrinsics) {
- next if !type || $type eq 'void' || $type =~ /complex/; # sun stuff
+ next if !$type || $type eq 'void' || $type =~ /complex/; # sun stuff
print <<"EOF";
printf(mask,sizeof($type), "$type");
EOF
diff --git a/gnu/usr.bin/perl/utils/h2ph.PL b/gnu/usr.bin/perl/utils/h2ph.PL
index 80d8375c9da..1b469daab83 100644
--- a/gnu/usr.bin/perl/utils/h2ph.PL
+++ b/gnu/usr.bin/perl/utils/h2ph.PL
@@ -1,8 +1,4 @@
#!/usr/local/bin/perl
-# $OpenBSD$
-#
-# This is slightly hacked up in order to support DESTDIR.
-#
use Config;
use File::Basename qw(&basename &dirname);
@@ -17,10 +13,9 @@ use File::Basename qw(&basename &dirname);
# 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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
@@ -30,37 +25,32 @@ print "Extracting $file (with variable substitutions)\n";
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
- eval 'exec perl -S \$0 "\$@"'
- if 0;
-
-'di ';
-'ds 00 \"';
-'ig 00 ';
-
-\$perlincl = "$Config{archlibexp}";
-
+$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!';
-$destdir = $ENV{"DESTDIR"};
-if ($destdir ne '') {
- chdir "$destdir/usr/include" || die "Can't cd $destdir/usr/include";
- # whack $perlincl
- $perlincl = "$destdir/$perlincl";
-} else {
- chdir '/usr/include' || die "Can't cd /usr/include";
-}
+use Config;
+use File::Path qw(mkpath);
+
+my $Exit = 0;
+
+my $Dest_dir = (@ARGV && $ARGV[0] =~ s/^-d//)
+ ? shift || shift
+ : $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
+ FILE key_t caddr_t
END
@isatype{@isatype} = (1) x @isatype;
@@ -69,6 +59,10 @@ $inif = 0;
@ARGV = ('-') unless @ARGV;
foreach $file (@ARGV) {
+ # Recover from header files with unbalanced cpp directives
+ $t = '';
+ $tab = 0;
+
if ($file eq '-') {
open(IN, "-");
open(OUT, ">-");
@@ -78,12 +72,10 @@ foreach $file (@ARGV) {
print "$file -> $outfile\n";
if ($file =~ m|^(.*)/|) {
$dir = $1;
- if (!-d "$perlincl/$dir") {
- mkdir("$perlincl/$dir",0777);
- }
+ mkpath "$Dest_dir/$dir";
}
- open(IN,"$file") || ((warn "Can't open $file: $!\n"),next);
- open(OUT,">$perlincl/$outfile") || die "Can't create $outfile: $!\n";
+ 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;
@@ -108,7 +100,9 @@ foreach $file (@ARGV) {
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;
@@ -117,28 +111,28 @@ foreach $file (@ARGV) {
$args = "local($args) = \@_;\n$t ";
}
s/^\s+//;
- do expr();
+ expr();
$new =~ s/(["\\])/\\$1/g;
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g;
print OUT $t,
- "eval 'sub $name {\n$t ${args}eval \"$new\";\n$t}';\n";
+ "eval 'sub $name $proto\{\n$t ${args}eval \"$new\";\n$t}' unless defined(\&$name);\n";
}
else {
- print OUT "sub $name {\n ${args}eval \"$new\";\n}\n";
+ print OUT "unless defined(\&$name) {\nsub $name $proto\{\n ${args}eval \"$new\";\n}\n}\n";
}
%curargs = ();
}
else {
s/^\s+//;
- do expr();
+ expr();
$new = 1 if $new eq '';
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g;
- print OUT $t,"eval 'sub $name {",$new,";}';\n";
+ print OUT $t,"eval 'sub $name () {",$new,";}' unless defined(\&$name);\n";
}
else {
- print OUT $t,"sub $name {",$new,";}\n";
+ print OUT $t,"unless(defined(\&$name)) {\nsub $name () {",$new,";}\n}\n";
}
}
}
@@ -159,7 +153,7 @@ foreach $file (@ARGV) {
elsif (s/^if\s+//) {
$new = '';
$inif = 1;
- do expr();
+ expr();
$inif = 0;
print OUT $t,"if ($new) {\n";
$tab += 4;
@@ -168,7 +162,7 @@ foreach $file (@ARGV) {
elsif (s/^elif\s+//) {
$new = '';
$inif = 1;
- do expr();
+ expr();
$inif = 0;
$tab -= 4;
$t = "\t" x ($tab / 8) . ' ' x ($tab % 8);
@@ -193,11 +187,14 @@ foreach $file (@ARGV) {
print OUT "1;\n";
}
+exit $Exit;
+
sub expr {
while ($_ ne '') {
+ s/^\&//; # hack for things that take the address of
s/^(\s+)// && do {$new .= ' '; next;};
s/^(0x[0-9a-fA-F]+)// && do {$new .= $1; next;};
- s/^(\d+)[LlUu]*// && do {$new .= $1; next;};
+ s/^(\d+)\s*[LlUu]*// && do {$new .= $1; next;};
s/^("(\\"|[^"])*")// && do {$new .= $1; next;};
s/^'((\\"|[^"])*)'// && do {
if ($curargs{$1}) {
@@ -208,10 +205,31 @@ sub expr {
}
next;
};
- s/^sizeof\s*\(([^)]+)\)/{$1}/ && do {
- $new .= '$sizeof';
- 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;
+ };
s/^([_a-zA-Z]\w*)// && do {
$id = $1;
if ($id eq 'struct') {
@@ -219,7 +237,7 @@ sub expr {
$id .= ' ' . $1;
$isatype{$id} = 1;
}
- elsif ($id eq 'unsigned') {
+ elsif ($id eq 'unsigned' || $id eq 'long') {
s/^\s+(\w+)//;
$id .= ' ' . $1;
$isatype{$id} = 1;
@@ -249,8 +267,8 @@ sub expr {
else {
if ($inif && $new !~ /defined\s*\($/) {
$new .= '(defined(&' . $id . ') ? &' . $id . ' : 0)';
- }
- elsif (/^\[/) {
+ }
+ elsif (/^\[/) {
$new .= ' $' . $id;
}
else {
@@ -263,56 +281,67 @@ sub expr {
}
}
##############################################################################
+__END__
+
+=head1 NAME
+
+h2ph - convert .h C header files to .ph Perl header files
+
+=head1 SYNOPSIS
+
+B<h2ph [headerfiles]>
+
+=head1 DESCRIPTION
- # These next few lines are legal in both Perl and nroff.
-
-.00 ; # finish .ig
-
-'di \" finish diversion--previous line must be blank
-.nr nl 0-1 \" fake up transition to first page again
-.nr % 0 \" start at page 1
-'; __END__ ############# From here on it's a standard manual page ############
-.TH H2PH 1 "August 8, 1990"
-.AT 3
-.SH NAME
-h2ph \- convert .h C header files to .ph Perl header files
-.SH SYNOPSIS
-.B h2ph [headerfiles]
-.SH DESCRIPTION
-.I h2ph
+I<h2ph>
converts any C header files specified to the corresponding Perl header file
format.
It is most easily run while in /usr/include:
-.nf
cd /usr/include; h2ph * sys/*
-.fi
+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.
-.SH ENVIRONMENT
+
+=head1 ENVIRONMENT
+
No environment variables are used.
-.SH FILES
-/usr/include/*.h
-.br
-/usr/include/sys/*.h
-.br
+
+=head1 FILES
+
+ /usr/include/*.h
+ /usr/include/sys/*.h
+
etc.
-.SH AUTHOR
+
+=head1 AUTHOR
+
Larry Wall
-.SH "SEE ALSO"
+
+=head1 SEE ALSO
+
perl(1)
-.SH DIAGNOSTICS
+
+=head1 DIAGNOSTICS
+
The usual warnings if it can't read or write the files involved.
-.SH BUGS
+
+=head1 BUGS
+
Doesn't construct the %sizeof array for you.
-.PP
+
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.
-.PP
+
It's only intended as a rough tool.
You may need to dicker with the files produced.
-.ex
+
+=cut
+
!NO!SUBS!
close OUT or die "Can't close $file: $!";
diff --git a/gnu/usr.bin/perl/utils/h2xs.PL b/gnu/usr.bin/perl/utils/h2xs.PL
index f9868dc37f0..b736e410ead 100644
--- a/gnu/usr.bin/perl/utils/h2xs.PL
+++ b/gnu/usr.bin/perl/utils/h2xs.PL
@@ -12,10 +12,9 @@ use File::Basename qw(&basename &dirname);
# 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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
@@ -25,9 +24,9 @@ print "Extracting $file (with variable substitutions)\n";
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
- eval 'exec perl -S \$0 "\$@"'
- if 0;
+$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.
@@ -40,7 +39,7 @@ h2xs - convert .h C header files to Perl extensions
=head1 SYNOPSIS
-B<h2xs> [B<-AOPXcf>] [B<-v> version] [B<-n> module_name] [headerfile [extra_libraries]]
+B<h2xs> [B<-AOPXcdf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [headerfile [extra_libraries]]
B<h2xs> B<-h>
@@ -72,6 +71,11 @@ in the extra-libraries argument.
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.
@@ -80,11 +84,20 @@ Allows a pre-existing extension directory to be overwritten.
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
@@ -98,15 +111,34 @@ Print the usage, help and version for this h2xs and exit.
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>
+=item B<-x>
-Omit the XS portion. Used to generate templates for a module which is not
-XS-based.
+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
@@ -138,6 +170,26 @@ XS-based.
# 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
@@ -153,28 +205,33 @@ L<perl>, L<perlxstut>, L<ExtUtils::MakeMaker>, and L<AutoLoader>.
=head1 DIAGNOSTICS
-The usual warnings if it can't read or write the files involved.
+The usual warnings if it cannot read or write the files involved.
=cut
-my( $H2XS_VERSION ) = '$Revision: 1.16 $' =~ /\$Revision:\s+([^\s]+)/;
+my( $H2XS_VERSION ) = ' $Revision: 1.18 $ ' =~ /\$Revision:\s+([^\s]+)/;
my $TEMPLATE_VERSION = '0.01';
use Getopt::Std;
sub usage{
warn "@_\n" if @_;
- die "h2xs [-AOPXcfh] [-v version] [-n module_name] [headerfile [extra_libraries]]
+ die "h2xs [-AOPXcdfh] [-v version] [-n module_name] [-p prefix] [-s subs] [headerfile [extra_libraries]]
version: $H2XS_VERSION
- -f Force creation of the extension even if the C header does not exist.
- -n Specify a name to use for the extension (recommended).
- -c Omit the constant() function and specialised AUTOLOAD from the XS file.
-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.
- -v Specify a version number for this extension.
+ -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.
@@ -182,7 +239,7 @@ extra_libraries
}
-getopts("AOPXcfhv:n:") || usage;
+getopts("AF:OPXcdfhn:p:s:v:x") || usage;
usage if $opt_h;
@@ -190,6 +247,7 @@ if( $opt_v ){
$TEMPLATE_VERSION = $opt_v;
}
$opt_c = 1 if $opt_A;
+%const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
$path_h = shift;
$extralibs = "@ARGV";
@@ -204,22 +262,53 @@ if( $path_h ){
warn "Nesting of headerfile ignored with -n\n";
}
$path_h .= ".h" unless $path_h =~ /\.h$/;
- $path_h = "/usr/include/$path_h" unless $path_h =~ m#^[./]#;
- 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 not (currently) processed.
- open(CH, "<$path_h") || die "Can't open $path_h: $!\n";
- while (<CH>) {
- if (/^#[ \t]*define\s+(\w+)\b\s*[^("]/) {
+ $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 not (currently) processed.
+ 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;
}
- close(CH);
- @const_names = sort keys %const_names;
}
@@ -262,9 +351,36 @@ if( $nested ){
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 $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');
+ $fdecls = $c->get('fdecls');
+ }
}
+
open(PM, ">$modfname.pm") || die "Can't create $ext$modpname/$modfname.pm: $!\n";
$" = "\n\t";
@@ -279,7 +395,7 @@ 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);
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
END
}
else{
@@ -287,7 +403,7 @@ else{
# will want Carp.
print PM <<'END';
use Carp;
-use vars qw($VERSION @ISA @EXPORT $AUTOLOAD);
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
END
}
@@ -302,7 +418,7 @@ END
# require autoloader if XS is disabled.
# if XS is enabled, require autoloader unless autoloading is disabled.
-if( $opt_X || (! $opt_A) ){
+if( ($opt_X && (! $opt_A)) || (!$opt_X) ) {
print PM <<"END";
require AutoLoader;
END
@@ -402,6 +518,25 @@ 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!
#
@@ -421,7 +556,7 @@ $pod = <<"END" unless $opt_P;
#unedited.
#
#Blah blah blah.
-#
+#$const_doc$fdecl_doc
#=head1 AUTHOR
#
#$author, $email
@@ -457,6 +592,7 @@ END
if( $path_h ){
my($h) = $path_h;
$h =~ s#^/usr/include/##;
+ if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
print XS <<"END";
#include <$h>
@@ -498,10 +634,12 @@ foreach $letter (@AZ, @az, @under) {
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 $name
- return $name;
+#ifdef $macro
+ return $macro;
#else
goto not_there;
#endif
@@ -524,13 +662,32 @@ not_there:
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
+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;
@@ -542,7 +699,113 @@ constant(name,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";
@@ -609,7 +872,17 @@ if (!@files) {
unless ($@) { @files = readdir(D); closedir(D); }
}
if (!@files) { @files = map {chomp && $_} `ls`; }
-print MANI join("\n",@files);
+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!
diff --git a/gnu/usr.bin/perl/utils/perlbug.PL b/gnu/usr.bin/perl/utils/perlbug.PL
index 7a74c9fffdb..724df6b449b 100644
--- a/gnu/usr.bin/perl/utils/perlbug.PL
+++ b/gnu/usr.bin/perl/utils/perlbug.PL
@@ -9,25 +9,64 @@ use File::Basename qw(&basename &dirname);
# %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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+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\t'", @patches) . "'";
+my @patch_tags = map { my $p=$_; $p=~s/\s.*//; $p } @patches;
+my $patch_tags = join " ", map { "+$_" } @patch_tags;
+$patch_tags .= " " if $patch_tags;
+
+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 perl -S \$0 "\$@"'
- if 0;
+$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.
@@ -50,7 +89,7 @@ use strict;
sub paraprint;
-my($Version) = "1.13";
+my($Version) = "1.20";
# 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.
@@ -64,19 +103,35 @@ my($Version) = "1.13";
# clearer and add $ENV{REPLYTO}.
# Changed in 1.13 to hopefully make it more difficult to accidentally
# send mail
-
-# TODO: Allow the user to re-name the file on mail failure, and
+# 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
+
+# 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, $cc, $address, $perlbug, $testaddress, $filename,
+my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename,
$subject, $from, $verbose, $ed,
- $fh, $me, $Is_VMS, $msg, $body, $andcc );
+ $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) {
paraprint <<EOF;
Please use perlbug interactively. If you want to
@@ -85,10 +140,10 @@ EOF
die "\n";
}
-if($::opt_d or !-t STDOUT) { Dump(*STDOUT); exit; }
+if(!-t STDOUT) { Dump(*STDOUT); exit; }
Query();
-Edit();
+Edit() unless $usefile;
NowWhat();
Send();
@@ -98,9 +153,10 @@ sub Init {
# -------- Setup --------
+ $Is_MSWin32 = $^O eq 'MSWin32';
$Is_VMS = $^O eq 'VMS';
- getopts("dhva:s:b:f:r:e:SCc:t");
+ getopts("dhva:s:b:f:r:e:SCc:to:");
# This comment is needed to notify metaconfig that we are
@@ -111,6 +167,7 @@ sub Init {
# perlbug address
$perlbug = 'perlbug@perl.com';
+
# Test address
$testaddress = 'perlbug-test@perl.com';
@@ -118,13 +175,6 @@ sub Init {
# Target address
$address = $::opt_a || ($::opt_t ? $testaddress : $perlbug);
- # 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.)
- $cc = ($::opt_C ? "" : (
- $::opt_c || $::Config{perladmin} || $::Config{cf_email} || $::Config{cf_by}
- ));
-
# Users address, used in message and in Reply-To header
$from = $::opt_r || "";
@@ -134,6 +184,9 @@ sub Init {
# Subject of bug-report message
$subject = $::opt_s || "";
+ # Send a file
+ $usefile = ($::opt_f || 0);
+
# File to send as report
$file = $::opt_f || "";
@@ -141,13 +194,56 @@ sub Init {
$body = $::opt_b || "";
# Editor
- $ed = ($::opt_f ? "file" : (
- $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} ||
- ($Is_VMS ? "edit/tpu" : "vi")
- ));
+ $ed = ( $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} ||
+ ($Is_VMS ? "edit/tpu" : $Is_MSWin32 ? "notepad" : "vi")
+ );
+
+ # 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\" does 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\".
+EOF
+ exit();
+ };
+ # force these options
+ $::opt_S = 1; # don't prompt for send
+ $::opt_C = 1; # don't send a copy to the local admin
+ $::opt_s = 1;
+ $subject = "OK: perl $] ${patch_tags}on"
+ ." $::Config{'archname'} $::Config{'osvers'} $subject";
+ $::opt_b = 1;
+ $body = "Perl reported to build OK on this system.\n";
+ $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 = getpwuid($<);
+ $me = ( $Is_MSWin32
+ ? $ENV{'USERNAME'}
+ : ( $^O eq 'os2'
+ ? $ENV{'USER'} || $ENV{'LOGNAME'}
+ : eval { getpwuid($<) }) ); # May be missing
}
@@ -155,21 +251,30 @@ sub Init {
sub Query {
# Explain what perlbug is
-
+ if ( ! $ok ) {
paraprint <<EOF;
-This program allows you to create a bug report,
-which will be sent as an e-mail message to $address
-once you have filled in the report.
+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
if(! $subject) {
paraprint <<EOF;
First of all, please provide a subject for the
-message. It should be as a concise description of
-the bug as is possible.
+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: ";
@@ -197,19 +302,18 @@ EOF
if($::HaveUtil) {
$domain = Mail::Util::maildomain();
- } elsif ($Is_VMS) {
+ } elsif ($Is_MSWin32) {
+ $domain = $ENV{'USERDOMAIN'};
+ } else {
require Sys::Hostname;
$domain = Sys::Hostname::hostname();
- } else {
- $domain = `hostname`.".".`domainname`;
- $domain =~ s/[\r\n]+//g;
}
my($guess);
if( !$domain) {
$guess = "";
- } elsif ($Is_VMS && !$::Config{'d_has_sockets'}) {
+ } elsif ($Is_VMS && !$::Config{'d_socket'}) {
$guess = "$domain\:\:$me";
} else {
$guess = "$me\@$domain" if $domain;
@@ -220,6 +324,7 @@ EOF
$guess = $ENV{"REPLY-TO"} if defined($ENV{'REPLY-TO'});
if( $guess ) {
+ if ( ! $ok ) {
paraprint <<EOF;
@@ -227,6 +332,7 @@ 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;
@@ -235,12 +341,20 @@ your full internet e-mail address here.
EOF
}
- print "Your address [$guess]: ";
-
- $from = <>;
- chop $from;
-
- if($from eq "") { $from = $guess }
+
+ if ( $ok && $guess ne '' ) {
+ # use it
+ $from = $guess;
+ }
+ else {
+ # verify it
+ print "Your address [$guess]: ";
+
+ $from = <>;
+ chop $from;
+
+ if($from eq "") { $from = $guess }
+ }
}
@@ -283,7 +397,8 @@ EOF
$andcc = " and $cc" if $cc;
-
+editor:
+
# Prompt for editor, if no override is given
if(! $::opt_e and ! $::opt_f and ! $::opt_b) {
paraprint <<EOF;
@@ -291,9 +406,16 @@ EOF
Now you need to supply the bug report. Try to make
the report concise but descriptive. Include any
-relevant detail. Some information about your local
+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.
+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
@@ -309,8 +431,11 @@ EOF
my($entry) =scalar(<>);
chop $entry;
-
- if($entry ne "") {
+
+ $usefile = 0;
+ if($entry eq "file") {
+ $usefile = 1;
+ } elsif($entry ne "") {
$ed = $entry;
}
}
@@ -319,8 +444,10 @@ EOF
# Generate scratch file to edit report in
{
- my($dir) = $Is_VMS ? 'sys$scratch:' : '/tmp/';
+ 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";
}
@@ -328,10 +455,10 @@ EOF
# Prompt for file to read report from, if needed
- if( $ed eq "file" and ! $file) {
+ if( $usefile and ! $file) {
+filename:
paraprint <<EOF;
-
What is the name of the file that contains your report?
EOF
@@ -341,9 +468,24 @@ EOF
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;
+ }
+
if(!-f $entry or !-r $entry) {
- print "\n\nUnable to read from `$entry'.\nExiting.\n";
- exit;
+ 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;
@@ -354,36 +496,60 @@ EOF
open(REP,">$filename");
+ my $reptype = $ok ? "success" : "bug";
+
print REP <<EOF;
-This is a bug report for perl from $from,
+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($file) {
- open(F,"<$file") or die "Unable to read report file: $!\n";
+ } elsif($usefile) {
+ open(F,"<$file") or die "Unable to read report file from `$file': $!\n";
while(<F>) {
print REP $_
}
close(F);
} else {
- print REP "[Please enter your report here]\n";
+ 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 Dump {
local(*OUT) = @_;
- print OUT <<EOF;
-
+ 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
@@ -394,6 +560,34 @@ EOF
print OUT Config::myconfig;
+ if (@patches) {
+ print OUT join "\n\t", "Locally applied patches:", @patches;
+ print OUT "\n";
+ };
+
+ print OUT <<EOF;
+
+---
+\@INC for perl $]:
+EOF
+ for my $i (@INC) {
+ print OUT "\t$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);
@@ -407,11 +601,28 @@ EOF
sub Edit {
# Edit the report
+
+ if($usefile) {
+ $usefile = 0;
+ 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;
+
+ if($entry ne "") {
+ $ed = $entry;
+ }
+ }
-tryagain:
- if(!$file and !$body) {
- my($sts) = system("$ed $filename");
- if( $Is_VMS ? !($sts & 1) : $sts ) {
+tryagain:
+ if(!$usefile and !$body) {
+ my $sts = system("$ed $filename");
+ if($sts) {
#print "\nUnable to run editor!\n";
paraprint <<EOF;
@@ -438,6 +649,43 @@ EOF
}
}
}
+
+ return if $ok;
+ # 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 Cancel {
+ 1 while unlink($filename); # remove all versions under VMS
+ print "\nCancelling.\n";
+ exit(0);
}
sub NowWhat {
@@ -493,15 +741,22 @@ Please type \"yes\" if you are: ";
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();
#system("$ed $filename");
} elsif( $action =~ /^[qc]/i ) { # <C>ancel, <Q>uit
- 1 while unlink($filename); # remove all versions under VMS
- print "\nCancelling.\n";
- exit(0);
+ Cancel();
} elsif( $action =~ /^s/ ) {
paraprint <<EOF;
@@ -533,6 +788,7 @@ sub Send {
$fh->close;
+ print "\nMessage sent.\n";
} else {
if ($Is_VMS) {
if ( ($address =~ /@/ and $address !~ /^\w+%"/) or
@@ -546,7 +802,7 @@ sub Send {
}
$subject =~ s/"/""/g; $address =~ s/"/""/g; $cc =~ s/"/""/g;
my($sts) = system(qq[mail/Subject="$subject" $filename. "$address","$cc"]);
- if (!($sts & 1)) { die "Can't spawn off mail\n\t(leaving bug report in $filename): $sts\n;" }
+ if ($sts) { die "Can't spawn off mail\n\t(leaving bug report in $filename): $sts\n;" }
} else {
my($sendmail) = "";
@@ -554,19 +810,31 @@ sub Send {
{
$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" and die "\n" if $sendmail eq "";
+ 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 inconveniencence.
+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");
+ open(SENDMAIL,"|$sendmail -t") || die "'|$sendmail -t' failed: $|";
print SENDMAIL "To: $address\n";
print SENDMAIL "Subject: $subject\n";
print SENDMAIL "Cc: $cc\n" if $cc;
@@ -576,12 +844,14 @@ EOF
while(<REP>) { print SENDMAIL $_ }
close(REP);
- close(SENDMAIL);
+ if (close(SENDMAIL)) {
+ print "\nMessage sent.\n";
+ } else {
+ warn "\nSendmail returned status '",$?>>8,"'\n";
+ }
}
}
-
- print "\nMessage sent.\n";
1 while unlink($filename); # remove all versions under VMS
@@ -596,7 +866,7 @@ be needed.
Usage:
$0 [-v] [-a address] [-s subject] [-b body | -f file ]
- [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t]
+ [-r returnaddress] [-e editor] [-c adminaddress | -C] [-S] [-t] [-h]
Simplest usage: run "$0", and follow the prompts.
@@ -620,6 +890,11 @@ Options:
-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 then don't use -ok.
+ -okay As -ok but allow report from old builds.
+ -h Print this help message.
EOF
}
@@ -640,8 +915,233 @@ 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<file> ]> 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> ]>
+
+=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<-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<-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>) and
+Mike Guy (E<lt>mjtg@cam.a.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 ':';
+
diff --git a/gnu/usr.bin/perl/utils/perldoc.PL b/gnu/usr.bin/perl/utils/perldoc.PL
index e53d542cb93..d223a9aaf90 100644
--- a/gnu/usr.bin/perl/utils/perldoc.PL
+++ b/gnu/usr.bin/perl/utils/perldoc.PL
@@ -12,10 +12,9 @@ use File::Basename qw(&basename &dirname);
# 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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
@@ -25,16 +24,17 @@ print "Extracting $file (with variable substitutions)\n";
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
- eval 'exec perl -S \$0 "\$@"'
- if 0;
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
+
+\@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!';
- eval 'exec perl -S $0 "$@"'
- if 0;
#
# Perldoc revision #1 -- look up a piece of documentation in .pod format that
@@ -45,8 +45,11 @@ print OUT <<'!NO!SUBS!';
# the perl manuals, though it too is written in perl.
if(@ARGV<1) {
+ $me = $0; # Editing $0 is unportable
+ $me =~ s,.*/,,;
die <<EOF;
-Usage: $0 [-h] [-v] [-t] [-u] [-m] PageName|ModuleName|ProgramName
+Usage: $me [-h] [-v] [-t] [-u] [-m] [-l] PageName|ModuleName|ProgramName
+ $me -f PerlFunc
We suggest you use "perldoc perldoc" to get aquainted
with the system.
@@ -54,23 +57,41 @@ EOF
}
use Getopt::Std;
+use Config '%Config';
+
+@global_found = ();
+$global_target = "";
+
$Is_VMS = $^O eq 'VMS';
+$Is_MSWin32 = $^O eq 'MSWin32';
sub usage{
- warn "@_\n" if @_;
+ warn "@_\n" if @_;
+ # Erase evidence of previous errors (if any), so exit status is simple.
+ $! = 0;
die <<EOF;
-perldoc [-h] [-v] [-u] PageName|ModuleName|ProgramName...
- -h Display this help message.
- -t Display pod using pod2text instead of pod2man and nroff.
+perldoc [options] PageName|ModuleName|ProgramName...
+perldoc [options] -f BuiltinFunction
+
+Options:
+ -h Display this help message
+ -t Display pod using pod2text instead of pod2man and nroff
+ (-t is the default on win32)
-u Display unformatted pod text
-m Display modules file in its entirety
- -v Verbosely describe what's going on.
+ -l Display the modules file name
+ -v Verbosely describe what's going on
+
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'.
Any switches in the PERLDOC environment variable will be used before the
command line arguments.
@@ -83,51 +104,83 @@ use Text::ParseWords;
unshift(@ARGV,shellwords($ENV{"PERLDOC"}));
-getopts("mhtuv") || usage;
+getopts("mhtluvf:") || usage;
usage if $opt_h || $opt_h; # avoid -w warning
-usage("only one of -t, -u, or -m") if $opt_t + $opt_u + $opt_m > 1;
+if ($opt_t + $opt_u + $opt_m + $opt_l > 1) {
+ usage("only one of -t, -u, -m or -l")
+} elsif ($Is_MSWin32) {
+ $opt_t = 1 unless $opt_t + $opt_u + $opt_m + $opt_l;
+}
if ($opt_t) { require Pod::Text; import Pod::Text; }
-@pages = @ARGV;
+if ($opt_f) {
+ @pages = ("perlfunc");
+} 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) = @_;
- local($_);
- open(TEST,"<$file");
- while(<TEST>) {
- if(/^=head/) {
- close(TEST);
- return 1;
- }
+ 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;
+ }
+ close(TEST);
+ return 0;
}
- sub minus_f_nocase {
+sub minus_f_nocase {
my($file) = @_;
+ # on a case-forgiving file system we can simply use -f $file
+ if ($Is_VMS or $Is_MSWin32 or $^O eq 'os2') {
+ return $file if -f $file and -r _;
+ warn "Ignored $file: unreadable\n" unless -r _;
+ return '';
+ }
local *DIR;
local($")="/";
my(@p,$p,$cip);
foreach $p (split(/\//, $file)){
- if ($Is_VMS and not scalar @p) {
- # VMS filesystems don't begin at '/'
- push(@p,$p);
- next;
- }
- if (-d ("@p/$p")){
+ my $try = "@p/$p";
+ stat $try;
+ if (-d _){
push @p, $p;
- } elsif (-f ("@p/$p")) {
- return "@p/$p";
+ if ( $p eq $global_target) {
+ $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)) {
- $cip =~ s/\.dir$// if $Is_VMS;
if (lc $cip eq $lcp){
$found++;
last;
@@ -136,44 +189,64 @@ sub containspod {
closedir DIR;
return "" unless $found;
push @p, $cip;
- return "@p" if -f "@p";
+ return "@p" if -f "@p" and -r _;
+ warn "Ignored $file: unreadable\n" if -f _;
}
}
return; # is not a file
- }
+}
- sub searchfor {
- my($recurse,$s,@dirs) = @_;
- $s =~ s!::!/!g;
- $s = VMS::Filespec::unixify($s) if $Is_VMS;
- printf STDERR "looking for $s in @dirs\n" if $opt_v;
- my $ret;
- my $i;
- my $dir;
- for ($i=0;$i<@dirs;$i++) {
- $dir = $dirs[$i];
- ($dir = VMS::Filespec::unixpath($dir)) =~ s!/$!! if $Is_VMS;
- if (( $ret = minus_f_nocase "$dir/$s.pod")
- or ( $ret = minus_f_nocase "$dir/$s.pm" and containspod($ret))
- or ( $ret = minus_f_nocase "$dir/$s" and containspod($ret))
- or ( $Is_VMS and
- $ret = minus_f_nocase "$dir/$s.com" and containspod($ret))
- or ( $ret = minus_f_nocase "$dir/pod/$s.pod")
- or ( $ret = minus_f_nocase "$dir/pod/$s" and containspod($ret)))
- { return $ret; }
-
- if($recurse) {
- opendir(D,$dir);
- my(@newdirs) = grep(-d,map("$dir/$_",grep(!/^\.\.?$/,readdir(D))));
- closedir(D);
- @newdirs = map((s/.dir$//,$_)[1],@newdirs) if $Is_VMS;
- next unless @newdirs;
- print STDERR "Also looking in @newdirs\n" if $opt_v;
- push(@dirs,@newdirs);
- }
- }
- return ();
- }
+
+sub check_file {
+ my($file) = @_;
+ return minus_f_nocase($file) && containspod($file) ? $file : "";
+}
+
+
+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 $^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 ();
+}
foreach (@pages) {
@@ -188,7 +261,8 @@ foreach (@pages) {
push(@searchdirs,$trn);
}
} else {
- push(@searchdirs, grep(-d, split(':', $ENV{'PATH'})));
+ push(@searchdirs, grep(-d, split($Config{path_sep},
+ $ENV{'PATH'})));
}
@files= searchfor(0,$_,@searchdirs);
}
@@ -199,12 +273,24 @@ foreach (@pages) {
@searchdirs = grep(!/^\.$/,@INC);
-
@files= searchfor(1,$_,@searchdirs);
if( @files ) {
print STDERR "Loosely found as @files\n" if $opt_v;
} else {
- print STDERR "No documentation found for '$_'\n";
+ print STDERR "No documentation found for \"$_\".\n";
+ if (@global_found) {
+ print STDERR "However, try\n";
+ my $dir = $file = "";
+ for $dir (@global_found) {
+ opendir(DIR, $dir) or die "$!";
+ while ($file = readdir(DIR)) {
+ next if ($file =~ /^\./);
+ $file =~ s/\.(pm|pod)$//;
+ print STDERR "\tperldoc $_\::$file\n";
+ }
+ closedir DIR;
+ }
+ }
}
}
push(@found,@files);
@@ -214,28 +300,78 @@ if(!@found) {
exit ($Is_VMS ? 98962 : 1);
}
-if( ! -t STDOUT ) { $opt_f = 1 }
+if ($opt_l) {
+ print join("\n", @found), "\n";
+ exit;
+}
-unless($Is_VMS) {
- $tmp = "/tmp/perldoc1.$$";
- $goodresult = 0;
- @pagers = qw( more less pg view cat );
- unshift(@pagers,$ENV{PAGER}) if $ENV{PAGER};
-} else {
+if( ! -t STDOUT ) { $no_tty = 1 }
+
+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_'.$$;
- @pagers = qw( most more less type/page );
- unshift(@pagers,$ENV{PERLDOC_PAGER}) if $ENV{PERLDOC_PAGER};
- $goodresult = 1;
+ push @pagers, qw( most more less type/page );
+} else {
+ if ($^O eq 'os2') {
+ require POSIX;
+ $tmp = POSIX::tmpnam();
+ } 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 $pager (@pagers) {
- my($sts) = system("$pager @found");
- exit 0 if ($Is_VMS ? ($sts & 1) : !$sts);
- }
- exit $Is_VMS ? $sts : 1;
+ foreach $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);
+ } else {
+ print @pod;
+ }
+ } else {
+ die "No documentation for perl function `$opt_f' found\n";
+ }
+ exit;
+}
+
foreach (@found) {
if($opt_t) {
@@ -243,12 +379,14 @@ foreach (@found) {
Pod::Text::pod2text($_,*TMP);
close(TMP);
} elsif(not $opt_u) {
- open(TMP,">>$tmp");
- $rslt = `pod2man $_ | nroff -man`;
- if ($Is_VMS) { $err = !($? % 2) || $rslt =~ /IVVERB/; }
- else { $err = $?; }
- print TMP $rslt unless $err;
- close TMP;
+ my $cmd = "pod2man --lax $_ | nroff -man";
+ $cmd .= " | col -x" if $^O =~ /hpux/;
+ $rslt = `$cmd`;
+ unless(($err = $?)) {
+ open(TMP,">>$tmp");
+ print TMP $rslt;
+ close TMP;
+ }
}
if( $opt_u or $err or -z $tmp) {
@@ -265,15 +403,13 @@ foreach (@found) {
}
}
-if( $opt_f ) {
+if( $no_tty ) {
open(TMP,"<$tmp");
print while <TMP>;
close(TMP);
} else {
foreach $pager (@pagers) {
- $sts = system("$pager $tmp");
- last if $Is_VMS && ($sts & 1);
- last unless $sts;
+ system("$pager $tmp") or last;
}
}
@@ -289,14 +425,17 @@ perldoc - Look up Perl documentation in pod format.
=head1 SYNOPSIS
-B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] PageName|ModuleName|ProgramName
+B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] [B<-m>] [B<-l>] PageName|ModuleName|ProgramName
+
+B<perldoc> B<-f> BuiltinFunction
=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 pod2man | nroff -man | $PAGER. This is primarily used for the
-documentation for the perl library modules.
+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.
@@ -329,6 +468,15 @@ 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> 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<PageName|ModuleName|ProgramName>
The item you want to look up. Nested modules (such as C<File::Basename>)
@@ -355,13 +503,12 @@ Kenneth Albanowski <kjahds@kjahds.com>
Minor updates by Andy Dougherty <doughera@lafcol.lafayette.edu>
-=head1 SEE ALSO
-
-=head1 DIAGNOSTICS
-
=cut
#
+# 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
diff --git a/gnu/usr.bin/perl/utils/pl2pm.PL b/gnu/usr.bin/perl/utils/pl2pm.PL
index e8277bb673d..55a8d2ea353 100644
--- a/gnu/usr.bin/perl/utils/pl2pm.PL
+++ b/gnu/usr.bin/perl/utils/pl2pm.PL
@@ -12,10 +12,9 @@ use File::Basename qw(&basename &dirname);
# 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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
@@ -25,9 +24,9 @@ print "Extracting $file (with variable substitutions)\n";
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
- eval 'exec perl -S \$0 "\$@"'
- if 0;
+$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.
@@ -56,7 +55,7 @@ It's just a first step, but it's usually a good first step.
=head1 AUTHOR
-Larry Wall <lwall@sems.com>
+Larry Wall <larry@wall.org>
=cut
diff --git a/gnu/usr.bin/perl/utils/splain.PL b/gnu/usr.bin/perl/utils/splain.PL
new file mode 100644
index 00000000000..75b5e2f3f61
--- /dev/null
+++ b/gnu/usr.bin/perl/utils/splain.PL
@@ -0,0 +1,46 @@
+#!/usr/local/bin/perl
+
+use Config;
+use File::Basename qw(&basename &dirname);
+
+# 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.
+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 ':';
diff --git a/gnu/usr.bin/perl/vms/Makefile b/gnu/usr.bin/perl/vms/Makefile
deleted file mode 100644
index 99c5236bf73..00000000000
--- a/gnu/usr.bin/perl/vms/Makefile
+++ /dev/null
@@ -1,1374 +0,0 @@
-#> This file produced from Descrip.MMS by mms2make.pl
-#> Lines beginning with "#>" were commented out during the
-#> conversion process. For more information, see mms2make.pl
-#>
-# Makefile for perl5 on VMS
-# Last revised 22-Mar-1996 by Charles Bailey bailey@genetics.upenn.edu
-#
-#
-# tidy -- purge files generated by executing this file
-# clean -- remove all intermediate (e.g. object files, C files generated
-# during build) files generated by executing this file,
-# but leave `installable' files (images, library) intact
-# realclean -- remove all files generated by executing this file
-# cleansrc -- `realclean' + purge *.c,*.h,Makefile
-# crtl.opt -- compiler-specific linker options file (made automatically)
-#
-
-#### Start of system configuration section. ####
-
-
-# File type to use for object files
-# File type to use for object libraries
-# File type to use for executable images
-# File type to use for object files
-O = .obj
-# File type to use for object libraries
-OLB = .olb
-# File type to use for executable images
-E = .exe
-
-ARCH = VMS_VAX
-OBJVAL = $@
-
-.first:
- @ $$@[.vms]fndvers.com "" "" "[.vms]Makefile"
-
-# Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_003 #
-
-
-ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
-ARCHCORE = [.lib.$(ARCH).$(PERL_VERSION).CORE]
-ARCHAUTO = [.lib.$(ARCH).$(PERL_VERSION).auto]
-
-
-
-
-# -fno-builtin avoids bug in gcc up to version 2.6.2 which can destroy
-# data when memcpy() is called on large (>64 kB) blocks of memory
-# (fixed in gcc 2.6.3)
-XTRAOBJS =
-LIBS1 = $(XTRAOBJS)
-DBGSPECFLAGS = /Show=(Source,Include,Expansion)
-# Some versions of DECCRTL on AXP have a bug in chdir() which causes the change
-# to persist after the image exits, even when this was not requested, iff
-# SYSNAM is enabled. This is fixed in CSC Patch # AXPACRT04_061, but turning
-# off SYSNAM for the MM[SK] subprocess doesn't hurt anything, so we do it
-# just in case.
-.first:
- @ If f$$TrnLnm("Sys").eqs."" .and. f$$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS sys$$Library
- @ If f$$TrnLnm("Sys").eqs."" .and. f$$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include
-
-XTRACCFLAGS = /Include=[]/Object=$(O)
-XTRADEF =
-LIBS2 = sys$$Share:VAXCRTL/Shareable
-
-
-DBGCCFLAGS = /NoList
-DBGLINKFLAGS = /NoMap
-DBG =
-
-# N.B. the targets for $(SOCKC) and $(SOCKH) assume that the permanent
-# copies live in [.vms], and the `clean' target will delete copies of
-# these files in the current default directory.
-SOCKDEF =
-SOCKLIB =
-SOCKC =
-SOCKH =
-SOCKCLIS =
-SOCKHLIS =
-SOCKOBJ =
-SOCKPM =
-
-# C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger
-CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF))$(XTRACCFLAGS)$(DBGCCFLAGS)
-LINKFLAGS = $(DBGLINKFLAGS)
-
-MAKE = $(MMS)
-MAKEFILE = [.VMS]Makefile # this file
-NOOP = continue
-
-# Macros to invoke a copy of miniperl during the build. Targets which
-# are built using these macros should depend on $(MINIPERL_EXE)
-MINIPERL_EXE = sys$$Disk:[]miniperl$(E)
-MINIPERL = MCR $(MINIPERL_EXE) "-I[.lib]"
-XSUBPP = $(MINIPERL) [.lib.extutils]xsubpp -noprototypes
-# Macro to invoke a preexisting copy of Perl. This is used to regenerate
-# some header files when rebuilding Perl, but premade versions are provided
-# in the distribution, so it's OK if this doesn't work; it's here to make
-# life easier for those who modify Perl and rebuild it.
-INSTPERL = perl
-
-# Space-separated list of "static" extensions to build into perlshr (case counts).
-MYEXT = DynaLoader
-# object files for these extensions; the trailing comma is required if
-# there are any object files specified
-# These must be built separately, or you must add rules below to build them
-myextobj = [.ext.dynaloader]dl_vms$(O),
-EXT = $(MYEXT)
-extobj = $(myextobj)
-
-
-#### End of system configuration section. ####
-
-
-h1 = EXTERN.h, INTERN.h, XSUB.h, av.h, config.h, cop.h, cv.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, vmsish.h, util.h
-h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS)
-
-c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c
-c2 = perl.c, perly.c, pp.c, pp_hot.c, pp_ctl.c, pp_sys.c, regcomp.c, regexec.c
-c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, globals.c, vms.c $(SOCKCLIS)
-
-c = $(c1), $(c2), $(c3), miniperlmain.c, perlmain.c
-
-obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O)
-obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O)
-obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), globals$(O), vms$(O) $(SOCKOBJ)
-
-obj = $(obj1), $(obj2), $(obj3)
-
-ac1 = $(ARCHCORE)EXTERN.h $(ARCHCORE)INTERN.h $(ARCHCORE)XSUB.h $(ARCHCORE)av.h
-ac2 = $(ARCHCORE)config.h $(ARCHCORE)cop.h $(ARCHCORE)cv.h $(ARCHCORE)embed.h
-ac3 = $(ARCHCORE)form.h $(ARCHCORE)gv.h $(ARCHCORE)handy.h $(ARCHCORE)hv.h
-ac4 = $(ARCHCORE)keywords.h $(ARCHCORE)mg.h $(ARCHCORE)op.h $(ARCHCORE)opcode.h
-ac5 = $(ARCHCORE)patchlevel.h $(ARCHCORE)perl.h $(ARCHCORE)perly.h
-ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h
-ac7 = $(ARCHCORE)regexp.h $(ARCHCORE)scope.h $(ARCHCORE)sv.h $(ARCHCORE)util.h
-ac8 = $(ARCHCORE)vmsish.h $(ARCHCORE)$(DBG)libperl$(OLB) $(ARCHCORE)perlshr_attr.opt
-ac9 = $(ARCHCORE)$(DBG)perlshr_bld.opt
-acs =
-
-CRTL = []crtl.opt
-CRTLOPTS =,$(CRTL)/Options
-
-.suffixes:
-
-.suffixes: $(O) .c .xs
-
-.xs.c :
- $(XSUBPP) $< >$@
-
-
-.c$(O) :
- $(CC) $(CFLAGS) $<
-
-.xs$(O) :
- $(XSUBPP) $< >$(MMS$SOURCE_NAME).c
- $(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c
-
-
-all : base extras archcorefiles preplibrary perlpods
- @ $(NOOP)
-base : miniperl perl
- @ $(NOOP)
-extras : Fcntl FileHandle Safe libmods utils podxform
- @ $(NOOP)
-libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm
- @ $(NOOP)
-utils : [.lib.pod]perldoc [.lib.ExtUtils]Miniperl.pm [.utils]c2ph [.utils]h2ph [.utils]h2xs [.lib]perlbug
- @ $(NOOP)
-podxform : [.lib.pod]pod2text [.lib.pod]pod2html [.lib.pod]pod2latex [.lib.pod]pod2man
- @ $(NOOP)
-
-pod1 = [.lib.pod]perl.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod
-pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod
-pod3 = [.lib.pod]perlembed.pod [.lib.pod]perlform.pod [.lib.pod]perlfunc.pod [.lib.pod]perlguts.pod
-pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod
-pod5 = [.lib.pod]perlop.pod [.lib.pod]perlovl.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod
-pod6 = [.lib.pod]perlref.pod [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod
-pod7 = [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod [.lib.pod]perltie.pod [.lib.pod]perltoc.pod
-pod8 = [.lib.pod]perltrap.pod [.lib.pod]perlvar.pod [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod
-
-perlpods : $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) [.lib.pod]perlvms.pod
- @ $(NOOP)
-
-archcorefiles : $(ac1) $(ac2) $(ac3) $(ac4) $(ac5) $(ac6) $(ac7) $(ac8) $(ac9) $(acs) $(ARCHAUTO)time.stamp
- @ $(NOOP)
-
-miniperl : $(DBG)miniperl$(E)
- @ Continue
-miniperl_objs = miniperlmain$(O), $(obj)
-$(MINIPERL_EXE) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
- Link $(LINKFLAGS)/NoDebug/Exe=$@ miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
-$(DBG)miniperl$(E) : $(miniperl_objs), $(DBG)libperl$(OLB) $(CRTL)
- Link $(LINKFLAGS)/Exe=$@ miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
-
-$(DBG)libperl$(OLB) : $(obj)
- @ If f$$Search("$@").eqs."" Then Library/Object/Create $(MMS$TARGET)
- Library/Object/Replace $@ $(obj1)
- Library/Object/Replace $@ $(obj2)
- Library/Object/Replace $@ $(obj3)
-
-perlmain.c : miniperlmain.c $(MINIPERL_EXE) [.vms]writemain.pl
- $(MINIPERL) [.VMS]Writemain.pl "$(EXT)"
-
-perl : $(DBG)perl$(E)
- @ Continue
-$(DBG)perl$(E) : perlmain$(O), $(DBG)perlshr$(E), $(MINIPERL_EXE)
- @ $$@[.vms]genopt "PerlShr.Opt/Write" "|" "''f$$Environment("Default")'$(DBG)PerlShr$(E)/Share"
- Link $(LINKFLAGS)/Exe=$@ perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option
-
-$(DBG)perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts
- Link /NoTrace$(LINKFLAGS)/Share=$@ $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option
-
-# The following files are built in one go by gen_shrfls.pl:
-# perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP
-# perlshr_gbl*.mar, perlshr_gbl*$(O) - VAX only
-# The song and dance with gen_shrfls.opt accomodates DCL's 255 character
-# line length limit.
-# This is a backup target used only with older versions of the DECCRTL which
-# can't deal with pipes properly. See ReadMe.VMS for details.
-$(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $(MINIPERL_EXE) $(MAKEFILE) $(CRTL)
- @ $(MINIPERL) -e "print join('|',@ARGV),'|';" "$(CC)$(CFLAGS)" >gen_shrfls.opt
- @ $(MINIPERL) -e "print join('|',@ARGV);" "$(O)" "$(DBG)" "$(OLB)" "$(EXT)" "$(CRTL)" >>gen_shrfls.opt
- $(MINIPERL) [.vms]gen_shrfls.pl -f gen_shrfls.opt
- @ Delete/NoLog/NoConfirm gen_shrfls.opt;
- @ If f$$Search("$(DBG)perlshr_xtras.ts").nes."" Then Delete/NoLog/NoConfirm $(DBG)perlshr_xtras.ts;*
- @ Copy _NLA0: $(DBG)perlshr_xtras.ts
-
-$(ARCHDIR)config.pm : [.lib]config.pm
- Create/Directory $(ARCHDIR)
- Copy [.lib]config.pm $@
-
-# Once again, we accomodate DCL's 255 character buffer
-[.lib]config.pm : [.vms]config.vms [.vms]genconfig.pl $(MINIPERL_EXE)
- @ $(MINIPERL) -e "print join('|',@ARGV),'|';" "cc=$(CC)$(CFLAGS)" >genconfig.opt
- @ $(MINIPERL) -e "print join('|',@ARGV),'|';" "ldflags=$(LINKFLAGS)|obj_ext=$(O)|exe_ext=$(E)|lib_ext=$(OLB)" >>genconfig.opt
- $(MINIPERL) [.VMS]GenConfig.Pl -f genconfig.opt
- @ Delete/NoLog/NoConfirm genconfig.opt;
- $(MINIPERL) ConfigPM.
-
-[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(MINIPERL_EXE)
- $(XSUBPP) [.ext.dynaloader]dl_vms.xs >$@
-
-[.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c
- $(CC) $(CFLAGS) /Object=$@ [.ext.dynaloader]dl_vms.c
-
-[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm
- Copy/Log/NoConfirm [.ext.dynaloader]dynaloader.pm [.lib]DynaLoader.pm
- @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
- @ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]DynaLoader.pm
-
-Safe : [.lib]Safe.pm [.lib.auto.Safe]Safe$(E)
- @ $(NOOP)
-
-[.lib]Safe.pm : [.ext.Safe]Makefile
- @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
- @ Set Default [.ext.Safe]
- $(MMS)
- @ Set Default [--]
-
-[.lib.auto.Safe]Safe$(E) : [.ext.Safe]Makefile
- @ Set Default [.ext.Safe]
- $(MMS)
- @ Set Default [--]
-
-# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
-# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.Safe]Makefile : [.ext.Safe]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
- $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Safe]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
-
-FileHandle : [.lib]FileHandle.pm [.lib.auto.FileHandle]FileHandle$(E)
- @ $(NOOP)
-
-[.lib]FileHandle.pm : [.ext.FileHandle]Makefile
- @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
- @ Set Default [.ext.FileHandle]
- $(MMS)
- @ Set Default [--]
-
-[.lib.auto.FileHandle]FileHandle$(E) : [.ext.FileHandle]Makefile
- @ Set Default [.ext.FileHandle]
- $(MMS)
- @ Set Default [--]
-
-# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
-# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.FileHandle]Makefile : [.ext.FileHandle]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
- $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.FileHandle]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
-
-Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
- @ $(NOOP)
-
-[.lib]Fcntl.pm : [.ext.Fcntl]Makefile
- @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
- @ Set Default [.ext.Fcntl]
- $(MMS)
- @ Set Default [--]
-
-[.lib.auto.Fcntl]Fcntl$(E) : [.ext.Fcntl]Makefile
- @ Set Default [.ext.Fcntl]
- $(MMS)
- @ Set Default [--]
-
-# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
-# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.Fcntl]Makefile : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
- $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
-
-[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
- @ If f$$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
- Copy/Log/NoConfirm [.vms.ext]Filespec.pm $@
-
-[.lib.pod]perldoc : [.utils]perldoc.PL $(ARCHDIR)Config.pm
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- $(MINIPERL) [.utils]perldoc.PL
- Copy/Log [.utils]perldoc $@
-
-[.lib.ExtUtils]Miniperl.pm : Minimod.PL miniperlmain.c $(ARCHDIR)Config.pm
- $(MINIPERL) Minimod.PL >$@
-
-[.utils]c2ph : [.utils]c2ph.PL $(ARCHDIR)Config.pm
- $(MINIPERL) [.utils]c2ph.PL
-
-[.utils]h2ph : [.utils]h2ph.PL $(ARCHDIR)Config.pm
- $(MINIPERL) [.utils]h2ph.PL
-
-[.utils]h2xs : [.utils]h2xs.PL $(ARCHDIR)Config.pm
- $(MINIPERL) [.utils]h2xs.PL
-
-[.lib]perlbug : [.utils]perlbug.PL $(ARCHDIR)Config.pm
- $(MINIPERL) [.utils]perlbug.PL
- Rename/Log [.utils]perlbug $@
-
-[.utils]pl2pm : [.utils]pl2pm.PL $(ARCHDIR)Config.pm
- $(MINIPERL) [.utils]pl2pm.PL
-
-[.lib.pod]pod2html : [.pod]pod2html.PL $(ARCHDIR)Config.pm
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- $(MINIPERL) [.pod]pod2html.PL
- Rename/Log [.pod]pod2html $@
-
-[.lib.pod]pod2latex : [.pod]pod2latex.PL $(ARCHDIR)Config.pm
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- $(MINIPERL) [.pod]pod2latex.PL
- Rename/Log [.pod]pod2latex $@
-
-[.lib.pod]pod2man : [.pod]pod2man.PL $(ARCHDIR)Config.pm
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- $(MINIPERL) [.pod]pod2man.PL
- Rename/Log [.pod]pod2man $@
-
-[.lib.pod]pod2text : [.pod]pod2text.PL $(ARCHDIR)Config.pm
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- $(MINIPERL) [.pod]pod2text.PL
- Rename/Log [.pod]pod2text $@
-
-preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm $(SOCKPM)
- @ Write sys$$Output "Autosplitting Perl library . . ."
- @ Create/Directory [.lib.auto]
- @ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
-
-[.lib.pod]perl.pod : [.pod]perl.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perl.pod $@
-
-[.lib.pod]perlbook.pod : [.pod]perlbook.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlbook.pod $@
-
-[.lib.pod]perlbot.pod : [.pod]perlbot.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlbot.pod $@
-
-[.lib.pod]perlcall.pod : [.pod]perlcall.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlcall.pod $@
-
-[.lib.pod]perldata.pod : [.pod]perldata.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perldata.pod $@
-
-[.lib.pod]perldebug.pod : [.pod]perldebug.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perldebug.pod $@
-
-[.lib.pod]perldiag.pod : [.pod]perldiag.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perldiag.pod $@
-
-[.lib.pod]perldsc.pod : [.pod]perldsc.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perldsc.pod $@
-
-[.lib.pod]perlembed.pod : [.pod]perlembed.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlembed.pod $@
-
-[.lib.pod]perlform.pod : [.pod]perlform.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlform.pod $@
-
-[.lib.pod]perlfunc.pod : [.pod]perlfunc.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlfunc.pod $@
-
-[.lib.pod]perlguts.pod : [.pod]perlguts.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlguts.pod $@
-
-[.lib.pod]perlipc.pod : [.pod]perlipc.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlipc.pod $@
-
-[.lib.pod]perllol.pod : [.pod]perllol.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perllol.pod $@
-
-[.lib.pod]perlmod.pod : [.pod]perlmod.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlmod.pod $@
-
-[.lib.pod]perlobj.pod : [.pod]perlobj.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlobj.pod $@
-
-[.lib.pod]perlop.pod : [.pod]perlop.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlop.pod $@
-
-[.lib.pod]perlovl.pod : [.pod]perlovl.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlovl.pod $@
-
-[.lib.pod]perlpod.pod : [.pod]perlpod.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlpod.pod $@
-
-[.lib.pod]perlre.pod : [.pod]perlre.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlre.pod $@
-
-[.lib.pod]perlref.pod : [.pod]perlref.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlref.pod $@
-
-[.lib.pod]perlrun.pod : [.pod]perlrun.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlrun.pod $@
-
-[.lib.pod]perlsec.pod : [.pod]perlsec.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlsec.pod $@
-
-[.lib.pod]perlstyle.pod : [.pod]perlstyle.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlstyle.pod $@
-
-[.lib.pod]perlsub.pod : [.pod]perlsub.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlsub.pod $@
-
-[.lib.pod]perlsyn.pod : [.pod]perlsyn.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlsyn.pod $@
-
-[.lib.pod]perltie.pod : [.pod]perltie.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perltie.pod $@
-
-[.lib.pod]perltoc.pod : [.pod]perltoc.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perltoc.pod $@
-
-[.lib.pod]perltrap.pod : [.pod]perltrap.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perltrap.pod $@
-
-[.lib.pod]perlvar.pod : [.pod]perlvar.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlvar.pod $@
-
-[.lib.pod]perlxs.pod : [.pod]perlxs.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlxs.pod $@
-
-[.lib.pod]perlxstut.pod : [.pod]perlxstut.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.pod]perlxstut.pod $@
-
-[.lib.pod]perlvms.pod : [.vms]perlvms.pod
- @ If f$$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log [.vms]perlvms.pod $@
-
-printconfig :
- @ $$@[.vms]make_command $(MMS) $(MMSQUALIFIERS) $(MMSTARGETS)
- @ $$@[.vms]myconfig "$(CC)" "$(CFLAGS)" "$(LINKFLAGS)" "$(LIBS1)" "$(LIBS2)" "$(SOCKLIB)" "$(EXT)" "$(DBG)"
-
-
-# The following three header files are generated automatically
-# keywords.h : keywords.pl
-# opcode.h : opcode.pl
-# embed.h : embed.pl global.sym interp.sym
-# 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
-# MMS regen_headers
-regen_headers :
- $(INSTPERL) keywords.pl
- $(INSTPERL) opcode.pl
- $(INSTPERL) embed.pl
-
-# VMS uses modified perly.[ch] with tags for globaldefs if using DEC compiler
-perly.c : [.vms]perly_c.vms
- Copy/Log [.vms]perly_c.vms $@
-perly.h : [.vms]perly_h.vms
- Copy/Log [.vms]perly_h.vms $@
-
-# I now supply perly.c with the kits, so the following section is
-# commented out if you don't have byacc.
-# Altered for VMS by Charles Bailey bailey@genetics.upenn.edu
-# perly.c:
-# @ Write Sys$Output "Expect 80 shift/reduce and 62 reduce/reduce conflicts"
-# \$(BYACC) -d perly.y
-# Has to be done by hand or by POSIX shell under VMS
-# sh \$(shellflags) ./perly.fixer y.tab.c perly.c
-# rename y.tab.h perly.h
-# $(INSTPERL) [.vms]vms_yfix.pl perly.c perly.h [.vms]perly_c.vms [.vms]perly_h.vms
-
-perly$(O) : perly.c, perly.h, $(h)
- $(CC) $(CFLAGS) perly.c
-
-test : all
- - @[.VMS]Test.Com
-
-# CORE subset for MakeMaker, so we can build Perl without sources
-# Should move to VMS installperl when we get one
-$(ARCHCORE)EXTERN.h : EXTERN.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log EXTERN.h $@
-$(ARCHCORE)INTERN.h : INTERN.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log INTERN.h $@
-$(ARCHCORE)XSUB.h : XSUB.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log XSUB.h $@
-$(ARCHCORE)av.h : av.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log av.h $@
-$(ARCHCORE)config.h : config.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log config.h $@
-$(ARCHCORE)cop.h : cop.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log cop.h $@
-$(ARCHCORE)cv.h : cv.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log cv.h $@
-$(ARCHCORE)embed.h : embed.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log embed.h $@
-$(ARCHCORE)form.h : form.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log form.h $@
-$(ARCHCORE)gv.h : gv.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log gv.h $@
-$(ARCHCORE)handy.h : handy.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log handy.h $@
-$(ARCHCORE)hv.h : hv.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log hv.h $@
-$(ARCHCORE)keywords.h : keywords.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log keywords.h $@
-$(ARCHCORE)mg.h : mg.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log mg.h $@
-$(ARCHCORE)op.h : op.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log op.h $@
-$(ARCHCORE)opcode.h : opcode.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log opcode.h $@
-$(ARCHCORE)patchlevel.h : patchlevel.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log patchlevel.h $@
-$(ARCHCORE)perl.h : perl.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log perl.h $@
-$(ARCHCORE)perly.h : perly.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log perly.h $@
-$(ARCHCORE)pp.h : pp.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log pp.h $@
-$(ARCHCORE)proto.h : proto.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log proto.h $@
-$(ARCHCORE)regcomp.h : regcomp.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log regcomp.h $@
-$(ARCHCORE)regexp.h : regexp.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log regexp.h $@
-$(ARCHCORE)scope.h : scope.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log scope.h $@
-$(ARCHCORE)sv.h : sv.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log sv.h $@
-$(ARCHCORE)util.h : util.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log util.h $@
-$(ARCHCORE)vmsish.h : vmsish.h
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log vmsish.h $@
-$(ARCHCORE)$(DBG)libperl$(OLB) : $(DBG)libperl$(OLB) $(DBG)perlshr_xtras.ts
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log $(DBG)libperl$(OLB) $@
-$(ARCHCORE)perlshr_attr.opt : $(DBG)perlshr_xtras.ts
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log perlshr_attr.opt $@
-$(ARCHCORE)$(DBG)perlshr_bld.opt : $(DBG)perlshr_xtras.ts
- @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
- Copy/Log $(DBG)perlshr_bld.opt $@
-$(ARCHAUTO)time.stamp :
- @ If f$$Search("$(ARCHDIR)auto.dir").eqs."" Then Create/Directory $(ARCHAUTO)
- @ If f$$Search("$@").eqs."" Then Copy/NoConfirm _NLA0: $(MMS$TARGET)
-
-# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
-av$(O) : EXTERN.h
-av$(O) : av.c
-av$(O) : av.h
-av$(O) : config.h
-av$(O) : cop.h
-av$(O) : cv.h
-av$(O) : embed.h
-av$(O) : form.h
-av$(O) : gv.h
-av$(O) : handy.h
-av$(O) : hv.h
-av$(O) : mg.h
-av$(O) : op.h
-av$(O) : opcode.h
-av$(O) : perl.h
-av$(O) : perly.h
-av$(O) : pp.h
-av$(O) : proto.h
-av$(O) : regexp.h
-av$(O) : scope.h
-av$(O) : sv.h
-av$(O) : vmsish.h
-av$(O) : util.h
-scope$(O) : EXTERN.h
-scope$(O) : av.h
-scope$(O) : config.h
-scope$(O) : cop.h
-scope$(O) : cv.h
-scope$(O) : embed.h
-scope$(O) : form.h
-scope$(O) : gv.h
-scope$(O) : handy.h
-scope$(O) : hv.h
-scope$(O) : mg.h
-scope$(O) : op.h
-scope$(O) : opcode.h
-scope$(O) : perl.h
-scope$(O) : perly.h
-scope$(O) : pp.h
-scope$(O) : proto.h
-scope$(O) : regexp.h
-scope$(O) : scope.c
-scope$(O) : scope.h
-scope$(O) : sv.h
-scope$(O) : vmsish.h
-scope$(O) : util.h
-op$(O) : EXTERN.h
-op$(O) : av.h
-op$(O) : config.h
-op$(O) : cop.h
-op$(O) : cv.h
-op$(O) : embed.h
-op$(O) : form.h
-op$(O) : gv.h
-op$(O) : handy.h
-op$(O) : hv.h
-op$(O) : mg.h
-op$(O) : op.c
-op$(O) : op.h
-op$(O) : opcode.h
-op$(O) : perl.h
-op$(O) : perly.h
-op$(O) : pp.h
-op$(O) : proto.h
-op$(O) : regexp.h
-op$(O) : scope.h
-op$(O) : sv.h
-op$(O) : vmsish.h
-op$(O) : util.h
-doop$(O) : EXTERN.h
-doop$(O) : av.h
-doop$(O) : config.h
-doop$(O) : cop.h
-doop$(O) : cv.h
-doop$(O) : doop.c
-doop$(O) : embed.h
-doop$(O) : form.h
-doop$(O) : gv.h
-doop$(O) : handy.h
-doop$(O) : hv.h
-doop$(O) : mg.h
-doop$(O) : op.h
-doop$(O) : opcode.h
-doop$(O) : perl.h
-doop$(O) : perly.h
-doop$(O) : pp.h
-doop$(O) : proto.h
-doop$(O) : regexp.h
-doop$(O) : scope.h
-doop$(O) : sv.h
-doop$(O) : vmsish.h
-doop$(O) : util.h
-doio$(O) : EXTERN.h
-doio$(O) : av.h
-doio$(O) : config.h
-doio$(O) : cop.h
-doio$(O) : cv.h
-doio$(O) : doio.c
-doio$(O) : embed.h
-doio$(O) : form.h
-doio$(O) : gv.h
-doio$(O) : handy.h
-doio$(O) : hv.h
-doio$(O) : mg.h
-doio$(O) : op.h
-doio$(O) : opcode.h
-doio$(O) : perl.h
-doio$(O) : perly.h
-doio$(O) : pp.h
-doio$(O) : proto.h
-doio$(O) : regexp.h
-doio$(O) : scope.h
-doio$(O) : sv.h
-doio$(O) : vmsish.h
-doio$(O) : util.h
-dump$(O) : EXTERN.h
-dump$(O) : av.h
-dump$(O) : config.h
-dump$(O) : cop.h
-dump$(O) : cv.h
-dump$(O) : dump.c
-dump$(O) : embed.h
-dump$(O) : form.h
-dump$(O) : gv.h
-dump$(O) : handy.h
-dump$(O) : hv.h
-dump$(O) : mg.h
-dump$(O) : op.h
-dump$(O) : opcode.h
-dump$(O) : perl.h
-dump$(O) : perly.h
-dump$(O) : pp.h
-dump$(O) : proto.h
-dump$(O) : regexp.h
-dump$(O) : scope.h
-dump$(O) : sv.h
-dump$(O) : vmsish.h
-dump$(O) : util.h
-hv$(O) : EXTERN.h
-hv$(O) : av.h
-hv$(O) : config.h
-hv$(O) : cop.h
-hv$(O) : cv.h
-hv$(O) : embed.h
-hv$(O) : form.h
-hv$(O) : gv.h
-hv$(O) : handy.h
-hv$(O) : hv.c
-hv$(O) : hv.h
-hv$(O) : mg.h
-hv$(O) : op.h
-hv$(O) : opcode.h
-hv$(O) : perl.h
-hv$(O) : perly.h
-hv$(O) : pp.h
-hv$(O) : proto.h
-hv$(O) : regexp.h
-hv$(O) : scope.h
-hv$(O) : sv.h
-hv$(O) : vmsish.h
-hv$(O) : util.h
-mg$(O) : EXTERN.h
-mg$(O) : av.h
-mg$(O) : config.h
-mg$(O) : cop.h
-mg$(O) : cv.h
-mg$(O) : embed.h
-mg$(O) : form.h
-mg$(O) : gv.h
-mg$(O) : handy.h
-mg$(O) : hv.h
-mg$(O) : mg.c
-mg$(O) : mg.h
-mg$(O) : op.h
-mg$(O) : opcode.h
-mg$(O) : perl.h
-mg$(O) : perly.h
-mg$(O) : pp.h
-mg$(O) : proto.h
-mg$(O) : regexp.h
-mg$(O) : scope.h
-mg$(O) : sv.h
-mg$(O) : vmsish.h
-mg$(O) : util.h
-perl$(O) : EXTERN.h
-perl$(O) : av.h
-perl$(O) : config.h
-perl$(O) : cop.h
-perl$(O) : cv.h
-perl$(O) : embed.h
-perl$(O) : form.h
-perl$(O) : gv.h
-perl$(O) : handy.h
-perl$(O) : hv.h
-perl$(O) : mg.h
-perl$(O) : op.h
-perl$(O) : opcode.h
-perl$(O) : perl.c
-perl$(O) : perl.h
-perl$(O) : perly.h
-perl$(O) : pp.h
-perl$(O) : proto.h
-perl$(O) : regexp.h
-perl$(O) : scope.h
-perl$(O) : sv.h
-perl$(O) : vmsish.h
-perl$(O) : util.h
-perly$(O) : EXTERN.h
-perly$(O) : av.h
-perly$(O) : config.h
-perly$(O) : cop.h
-perly$(O) : cv.h
-perly$(O) : embed.h
-perly$(O) : form.h
-perly$(O) : gv.h
-perly$(O) : handy.h
-perly$(O) : hv.h
-perly$(O) : mg.h
-perly$(O) : op.h
-perly$(O) : opcode.h
-perly$(O) : perl.h
-perly$(O) : perly.h
-perly$(O) : perly.c
-perly$(O) : pp.h
-perly$(O) : proto.h
-perly$(O) : regexp.h
-perly$(O) : scope.h
-perly$(O) : sv.h
-perly$(O) : vmsish.h
-perly$(O) : util.h
-pp$(O) : EXTERN.h
-pp$(O) : av.h
-pp$(O) : config.h
-pp$(O) : cop.h
-pp$(O) : cv.h
-pp$(O) : embed.h
-pp$(O) : form.h
-pp$(O) : gv.h
-pp$(O) : handy.h
-pp$(O) : hv.h
-pp$(O) : mg.h
-pp$(O) : op.h
-pp$(O) : opcode.h
-pp$(O) : perl.h
-pp$(O) : perly.h
-pp$(O) : pp.c
-pp$(O) : pp.h
-pp$(O) : proto.h
-pp$(O) : regexp.h
-pp$(O) : scope.h
-pp$(O) : sv.h
-pp$(O) : vmsish.h
-pp$(O) : util.h
-pp_ctl$(O) : EXTERN.h
-pp_ctl$(O) : av.h
-pp_ctl$(O) : config.h
-pp_ctl$(O) : cop.h
-pp_ctl$(O) : cv.h
-pp_ctl$(O) : embed.h
-pp_ctl$(O) : form.h
-pp_ctl$(O) : gv.h
-pp_ctl$(O) : handy.h
-pp_ctl$(O) : hv.h
-pp_ctl$(O) : mg.h
-pp_ctl$(O) : op.h
-pp_ctl$(O) : opcode.h
-pp_ctl$(O) : perl.h
-pp_ctl$(O) : perly.h
-pp_ctl$(O) : pp_ctl.c
-pp_ctl$(O) : pp.h
-pp_ctl$(O) : proto.h
-pp_ctl$(O) : regexp.h
-pp_ctl$(O) : scope.h
-pp_ctl$(O) : sv.h
-pp_ctl$(O) : vmsish.h
-pp_ctl$(O) : util.h
-pp_hot$(O) : EXTERN.h
-pp_hot$(O) : av.h
-pp_hot$(O) : config.h
-pp_hot$(O) : cop.h
-pp_hot$(O) : cv.h
-pp_hot$(O) : embed.h
-pp_hot$(O) : form.h
-pp_hot$(O) : gv.h
-pp_hot$(O) : handy.h
-pp_hot$(O) : hv.h
-pp_hot$(O) : mg.h
-pp_hot$(O) : op.h
-pp_hot$(O) : opcode.h
-pp_hot$(O) : perl.h
-pp_hot$(O) : perly.h
-pp_hot$(O) : pp_hot.c
-pp_hot$(O) : pp.h
-pp_hot$(O) : proto.h
-pp_hot$(O) : regexp.h
-pp_hot$(O) : scope.h
-pp_hot$(O) : sv.h
-pp_hot$(O) : vmsish.h
-pp_hot$(O) : util.h
-pp_sys$(O) : EXTERN.h
-pp_sys$(O) : av.h
-pp_sys$(O) : config.h
-pp_sys$(O) : cop.h
-pp_sys$(O) : cv.h
-pp_sys$(O) : embed.h
-pp_sys$(O) : form.h
-pp_sys$(O) : gv.h
-pp_sys$(O) : handy.h
-pp_sys$(O) : hv.h
-pp_sys$(O) : mg.h
-pp_sys$(O) : op.h
-pp_sys$(O) : opcode.h
-pp_sys$(O) : perl.h
-pp_sys$(O) : perly.h
-pp_sys$(O) : pp_sys.c
-pp_sys$(O) : pp.h
-pp_sys$(O) : proto.h
-pp_sys$(O) : regexp.h
-pp_sys$(O) : scope.h
-pp_sys$(O) : sv.h
-pp_sys$(O) : vmsish.h
-pp_sys$(O) : util.h
-regcomp$(O) : EXTERN.h
-regcomp$(O) : INTERN.h
-regcomp$(O) : av.h
-regcomp$(O) : config.h
-regcomp$(O) : cop.h
-regcomp$(O) : cv.h
-regcomp$(O) : embed.h
-regcomp$(O) : form.h
-regcomp$(O) : gv.h
-regcomp$(O) : handy.h
-regcomp$(O) : hv.h
-regcomp$(O) : mg.h
-regcomp$(O) : op.h
-regcomp$(O) : opcode.h
-regcomp$(O) : perl.h
-regcomp$(O) : perly.h
-regcomp$(O) : pp.h
-regcomp$(O) : proto.h
-regcomp$(O) : regcomp.c
-regcomp$(O) : regcomp.h
-regcomp$(O) : regexp.h
-regcomp$(O) : scope.h
-regcomp$(O) : sv.h
-regcomp$(O) : vmsish.h
-regcomp$(O) : util.h
-regexec$(O) : EXTERN.h
-regexec$(O) : av.h
-regexec$(O) : config.h
-regexec$(O) : cop.h
-regexec$(O) : cv.h
-regexec$(O) : embed.h
-regexec$(O) : form.h
-regexec$(O) : gv.h
-regexec$(O) : handy.h
-regexec$(O) : hv.h
-regexec$(O) : mg.h
-regexec$(O) : op.h
-regexec$(O) : opcode.h
-regexec$(O) : perl.h
-regexec$(O) : perly.h
-regexec$(O) : pp.h
-regexec$(O) : proto.h
-regexec$(O) : regcomp.h
-regexec$(O) : regexec.c
-regexec$(O) : regexp.h
-regexec$(O) : scope.h
-regexec$(O) : sv.h
-regexec$(O) : vmsish.h
-regexec$(O) : util.h
-gv$(O) : EXTERN.h
-gv$(O) : av.h
-gv$(O) : config.h
-gv$(O) : cop.h
-gv$(O) : cv.h
-gv$(O) : embed.h
-gv$(O) : form.h
-gv$(O) : gv.c
-gv$(O) : gv.h
-gv$(O) : handy.h
-gv$(O) : hv.h
-gv$(O) : mg.h
-gv$(O) : op.h
-gv$(O) : opcode.h
-gv$(O) : perl.h
-gv$(O) : perly.h
-gv$(O) : pp.h
-gv$(O) : proto.h
-gv$(O) : regexp.h
-gv$(O) : scope.h
-gv$(O) : sv.h
-gv$(O) : vmsish.h
-gv$(O) : util.h
-sv$(O) : EXTERN.h
-sv$(O) : av.h
-sv$(O) : config.h
-sv$(O) : cop.h
-sv$(O) : cv.h
-sv$(O) : embed.h
-sv$(O) : form.h
-sv$(O) : gv.h
-sv$(O) : handy.h
-sv$(O) : hv.h
-sv$(O) : mg.h
-sv$(O) : op.h
-sv$(O) : opcode.h
-sv$(O) : perl.h
-sv$(O) : perly.h
-sv$(O) : pp.h
-sv$(O) : proto.h
-sv$(O) : regexp.h
-sv$(O) : scope.h
-sv$(O) : sv.c
-sv$(O) : sv.h
-sv$(O) : vmsish.h
-sv$(O) : util.h
-taint$(O) : EXTERN.h
-taint$(O) : av.h
-taint$(O) : config.h
-taint$(O) : cop.h
-taint$(O) : cv.h
-taint$(O) : embed.h
-taint$(O) : form.h
-taint$(O) : gv.h
-taint$(O) : handy.h
-taint$(O) : hv.h
-taint$(O) : mg.h
-taint$(O) : op.h
-taint$(O) : opcode.h
-taint$(O) : perl.h
-taint$(O) : perly.h
-taint$(O) : pp.h
-taint$(O) : proto.h
-taint$(O) : regexp.h
-taint$(O) : scope.h
-taint$(O) : sv.h
-taint$(O) : taint.c
-taint$(O) : vmsish.h
-taint$(O) : util.h
-toke$(O) : EXTERN.h
-toke$(O) : av.h
-toke$(O) : config.h
-toke$(O) : cop.h
-toke$(O) : cv.h
-toke$(O) : embed.h
-toke$(O) : form.h
-toke$(O) : gv.h
-toke$(O) : handy.h
-toke$(O) : hv.h
-toke$(O) : keywords.h
-toke$(O) : mg.h
-toke$(O) : op.h
-toke$(O) : opcode.h
-toke$(O) : perl.h
-toke$(O) : perly.h
-toke$(O) : pp.h
-toke$(O) : proto.h
-toke$(O) : regexp.h
-toke$(O) : scope.h
-toke$(O) : sv.h
-toke$(O) : toke.c
-toke$(O) : vmsish.h
-toke$(O) : util.h
-util$(O) : EXTERN.h
-util$(O) : av.h
-util$(O) : config.h
-util$(O) : cop.h
-util$(O) : cv.h
-util$(O) : embed.h
-util$(O) : form.h
-util$(O) : gv.h
-util$(O) : handy.h
-util$(O) : hv.h
-util$(O) : mg.h
-util$(O) : op.h
-util$(O) : opcode.h
-util$(O) : perl.h
-util$(O) : perly.h
-util$(O) : pp.h
-util$(O) : proto.h
-util$(O) : regexp.h
-util$(O) : scope.h
-util$(O) : sv.h
-util$(O) : vmsish.h
-util$(O) : util.c
-util$(O) : util.h
-deb$(O) : EXTERN.h
-deb$(O) : av.h
-deb$(O) : config.h
-deb$(O) : cop.h
-deb$(O) : cv.h
-deb$(O) : deb.c
-deb$(O) : embed.h
-deb$(O) : form.h
-deb$(O) : gv.h
-deb$(O) : handy.h
-deb$(O) : hv.h
-deb$(O) : mg.h
-deb$(O) : op.h
-deb$(O) : opcode.h
-deb$(O) : perl.h
-deb$(O) : perly.h
-deb$(O) : pp.h
-deb$(O) : proto.h
-deb$(O) : regexp.h
-deb$(O) : scope.h
-deb$(O) : sv.h
-deb$(O) : vmsish.h
-deb$(O) : util.h
-run$(O) : EXTERN.h
-run$(O) : av.h
-run$(O) : config.h
-run$(O) : cop.h
-run$(O) : cv.h
-run$(O) : embed.h
-run$(O) : form.h
-run$(O) : gv.h
-run$(O) : handy.h
-run$(O) : hv.h
-run$(O) : mg.h
-run$(O) : op.h
-run$(O) : opcode.h
-run$(O) : perl.h
-run$(O) : perly.h
-run$(O) : pp.h
-run$(O) : proto.h
-run$(O) : regexp.h
-run$(O) : run.c
-run$(O) : scope.h
-run$(O) : sv.h
-run$(O) : vmsish.h
-run$(O) : util.h
-vms$(O) : EXTERN.h
-vms$(O) : av.h
-vms$(O) : config.h
-vms$(O) : cop.h
-vms$(O) : cv.h
-vms$(O) : embed.h
-vms$(O) : form.h
-vms$(O) : gv.h
-vms$(O) : handy.h
-vms$(O) : hv.h
-vms$(O) : mg.h
-vms$(O) : op.h
-vms$(O) : opcode.h
-vms$(O) : perl.h
-vms$(O) : perly.h
-vms$(O) : pp.h
-vms$(O) : proto.h
-vms$(O) : regexp.h
-vms$(O) : vms.c
-vms$(O) : scope.h
-vms$(O) : sv.h
-vms$(O) : vmsish.h
-vms$(O) : util.h
-miniperlmain$(O) : EXTERN.h
-miniperlmain$(O) : av.h
-miniperlmain$(O) : config.h
-miniperlmain$(O) : cop.h
-miniperlmain$(O) : cv.h
-miniperlmain$(O) : embed.h
-miniperlmain$(O) : form.h
-miniperlmain$(O) : gv.h
-miniperlmain$(O) : handy.h
-miniperlmain$(O) : hv.h
-miniperlmain$(O) : mg.h
-miniperlmain$(O) : miniperlmain.c
-miniperlmain$(O) : op.h
-miniperlmain$(O) : opcode.h
-miniperlmain$(O) : perl.h
-miniperlmain$(O) : perly.h
-miniperlmain$(O) : pp.h
-miniperlmain$(O) : proto.h
-miniperlmain$(O) : regexp.h
-miniperlmain$(O) : scope.h
-miniperlmain$(O) : sv.h
-miniperlmain$(O) : vmsish.h
-miniperlmain$(O) : util.h
-perlmain$(O) : EXTERN.h
-perlmain$(O) : av.h
-perlmain$(O) : config.h
-perlmain$(O) : cop.h
-perlmain$(O) : cv.h
-perlmain$(O) : embed.h
-perlmain$(O) : form.h
-perlmain$(O) : gv.h
-perlmain$(O) : handy.h
-perlmain$(O) : hv.h
-perlmain$(O) : mg.h
-perlmain$(O) : op.h
-perlmain$(O) : opcode.h
-perlmain$(O) : perl.h
-perlmain$(O) : perly.h
-perlmain$(O) : perlmain.c
-perlmain$(O) : pp.h
-perlmain$(O) : proto.h
-perlmain$(O) : regexp.h
-perlmain$(O) : scope.h
-perlmain$(O) : sv.h
-perlmain$(O) : vmsish.h
-perlmain$(O) : util.h
-globals$(O) : INTERN.h
-globals$(O) : av.h
-globals$(O) : config.h
-globals$(O) : cop.h
-globals$(O) : cv.h
-globals$(O) : embed.h
-globals$(O) : form.h
-globals$(O) : gv.h
-globals$(O) : handy.h
-globals$(O) : hv.h
-globals$(O) : mg.h
-globals$(O) : op.h
-globals$(O) : opcode.h
-globals$(O) : perl.h
-globals$(O) : perly.h
-globals$(O) : globals.c
-globals$(O) : pp.h
-globals$(O) : proto.h
-globals$(O) : regexp.h
-globals$(O) : scope.h
-globals$(O) : sv.h
-globals$(O) : vmsish.h
-globals$(O) : util.h
-
-config.h : [.vms]config.vms
- Copy/Log/NoConfirm [.vms]config.vms []config.h
-
-vmsish.h : [.vms]vmsish.h
- Copy/Log/NoConfirm [.vms]vmsish.h []vmsish.h
-
-vms.c : [.vms]vms.c
- Copy/Log/Noconfirm [.vms]vms.c []
-
-$(CRTL) : $(MAKEFILE)
- @ $$@[.vms]genopt "$(CRTL)/Write" "|" "$(LIBS1)|$(LIBS2)|$(SOCKLIB)"
-
-
-cleanlis :
- - If f$$Search("*.Lis").nes."" Then Delete/NoConfirm/Log *.Lis;*
- - If f$$Search("*.CPP").nes."" Then Delete/NoConfirm/Log *.CPP;*
- - If f$$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;*
-
-tidy : cleanlis
- - If f$$Search("*.Opt;-1").nes."" Then Purge/NoConfirm/Log *.Opt
- - If f$$Search("*$(O);-1").nes."" Then Purge/NoConfirm/Log *$(O)
- - If f$$Search("*$(E);-1").nes."" Then Purge/NoConfirm/Log *$(E)
- - If f$$Search("Config.H;-1").nes."" Then Purge/NoConfirm/Log Config.H
- - If f$$Search("Config.SH;-1").nes."" Then Purge/NoConfirm/Log Config.SH
- - If f$$Search("perly.c;-1").nes."" Then Purge/NoConfirm/Log perly.c
- - If f$$Search("perly.h;-1").nes."" Then Purge/NoConfirm/Log perly.h
- - If f$$Search("VMSish.H;-1").nes."" Then Purge/NoConfirm/Log VMSish.H
- - If f$$Search("VMS.C;-1") .nes."" Then Purge/NoConfirm/Log VMS.C
- - If f$$Search("Perlmain.C;-1") .nes."" Then Purge/NoConfirm/Log Perlmain.C
- - If f$$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar
- - If f$$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O)
- - If f$$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C
- - If f$$Search("[.Ext.Safe...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.Safe]
- - If f$$Search("[.Ext.FileHandle...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.FileHandle]
- - If f$$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*.C
- - If f$$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*$(O)
- - If f$$Search("[.Lib.Auto...]*.al;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]*.al
- - If f$$Search("[.Lib.Auto...]autosplit.ix;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]autosplit.ix
- - If f$$Search("[.Lib]DynaLoader.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]DynaLoader.pm
- - If f$$Search("[.Lib]Socket.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Socket.pm
- - If f$$Search("[.Lib]Config.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Config.pm
- - If f$$Search("$(ARCHDIR)Config.pm;-1").nes."" Then Purge/NoConfirm/Log $(ARCHDIR)Config.pm
- - If f$$Search("[.Lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.*
- - If f$$Search("[.Lib.Pod]*.Pod;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Pod]*.Pod
- - If f$$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.*
- - If f$$Search("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*.
- - If f$$Search("[.lib.pod]*.;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.
-
-clean : tidy
- Set Default [.ext.Fcntl]
- - $(MMS) clean
- Set Default [--]
- Set Default [.ext.FileHandle]
- - $(MMS) clean
- Set Default [--]
- Set Default [.ext.Safe]
- - $(MMS) clean
- Set Default [--]
- - If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
- - If f$$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);*
- - If f$$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;*
- - If f$$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;*
- - If f$$Search(f$$Parse("sys$$Disk:[]","$(SOCKH)")).nes."" Then Delete/NoConfirm/Log $(SOCKH);*
- - If f$$Search(f$$Parse("sys$$Disk:[]","$(SOCKC)")).nes."" Then Delete/NoConfirm/Log $(SOCKC);*
- - If f$$Search("perly.c").nes."" Then Delete/NoConfirm/Log perly.c;*
- - If f$$Search("perly.h").nes."" Then Delete/NoConfirm/Log perly.h;*
- - If f$$Search("VMSish.H").nes."" Then Delete/NoConfirm/Log VMSish.H;*
- - If f$$Search("VMS.C") .nes."" Then Delete/NoConfirm/Log VMS.C;*
- - If f$$Search("Perlmain.C") .nes."" Then Delete/NoConfirm/Log Perlmain.C;*
- - If f$$Search("Perlshr_Gbl*.Mar") .nes."" Then Delete/NoConfirm/Log Perlshr_Gbl*.Mar;*
- - If f$$Search("*.TS").nes."" Then Delete/NoConfirm/Log *.TS;*
- - If f$$Search("[.Ext.DynaLoader]DL_VMS$(O)").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O);*
- - If f$$Search("[.Ext.DynaLoader]DL_VMS.C").nes."" Then Delete/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C;*
- - If f$$Search("[.Ext.Socket]Socket$(O)").nes."" Then Delete/NoConfirm/Log [.Ext.Socket]Socket$(O);*
- - If f$$Search("[.Ext.Socket]Socket.C").nes."" Then Delete/NoConfirm/Log [.Ext.Socket]Socket.C;*
- - If f$$Search("[.VMS.Ext...]*.C").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*.C;*
- - If f$$Search("[.VMS.Ext...]*$(O)").nes."" Then Delete/NoConfirm/Log [.VMS.Ext...]*$(O);*
-
-realclean : clean
- Set Default [.ext.Fcntl]
- - $(MMS) realclean
- Set Default [--]
- Set Default [.ext.FileHandle]
- - $(MMS) realclean
- Set Default [--]
- Set Default [.ext.Safe]
- - $(MMS) realclean
- Set Default [--]
- - If f$$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- - If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- - $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);"
- - If f$$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
- - If f$$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
- - If f$$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;*
- - If f$$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;*
- - If f$$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;*
- - If f$$Search("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*
- - If f$$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;*
- - If f$$Search("[.lib.pod]perldoc.").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.;*
- - If f$$Search("[.lib.pod]pod2*.").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.;*
- - If f$$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);*
-
-cleansrc : clean
- - If f$$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C
- - If f$$Search("*.H;-1").nes."" Then Purge/NoConfirm/Log *.H
- - If f$$Search("*.VMS;-1").nes."" Then Purge/NoConfirm/Log *.VMS
- - If f$$Search("[.VMS]$(MAKEFILE);-1").nes."" Then Purge/NoConfirm/Log [.VMS]$(MAKEFILE)
- - If f$$Search("[.VMS]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.C
- - If f$$Search("[.VMS]*.H;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.H
- - If f$$Search("[.VMS]*.Pl;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.Pl
- - If f$$Search("[.VMS]*.VMS;-1").nes."" Then Purge/NoConfirm/Log [.VMS]*.VMS
- - If f$$Search("[.VMS...]*.pm;-1").nes."" Then Purge/NoConfirm/Log [.VMS...]*.pm
- - If f$$Search("[.VMS...]*.xs;-1").nes."" Then Purge/NoConfirm/Log [.VMS...]*.xs
diff --git a/gnu/usr.bin/perl/vms/config.vms b/gnu/usr.bin/perl/vms/config.vms
index 203e479016a..d6453ba34a7 100644
--- a/gnu/usr.bin/perl/vms/config.vms
+++ b/gnu/usr.bin/perl/vms/config.vms
@@ -8,10 +8,10 @@
* GenConfig.pl when producing Config.pm.
*
* config.h for VMS
- * Version: 5.002_01
+ * Version: 5.004
*/
-/* Configuration time: 22-Mar-1996 14:45
+/* Configuration time: 19-Nov-1996 23:34
* Configured by: Charles Bailey bailey@genetics.upenn.edu
* Target system: VMS
*/
@@ -58,21 +58,40 @@
*/
#define OSNAME "VMS" /**/
-/* ARCHLIB_EXP:
+/* 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_EXP is the
- * same as PRIVLIB_EXP, it is not defined, since presumably the
- * program already searches PRIVLIB_EXP.
+ * 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.
*/
/* ==> NOTE <==
* This value is automatically updated by FndVers.Com
* when Perl is built. Please do not change it by hand; make
* any changes to FndVers.Com instead.
*/
-#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_003" /**/
+#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_004" /**/
+#define ARCHLIB ARCHLIB_EXP /*config-skip*/
+
+/* 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 "VMS_VAX" /**/
+
+/* BINCOMPAT3:
+ * This symbol, if defined, indicates that Perl 5.004 should be
+ * binary-compatible with Perl 5.003.
+ */
+#undef BINCOMPAT3
/* CPPSTDIN:
* This symbol contains the first part of the string which will invoke
@@ -93,19 +112,30 @@
* This symbol is defined if the bcmp() routine is available to
* compare blocks of memory.
*/
-#undef HAS_BCMP /**/
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define HAS_BCMP /**/
+#else
+#undef HAS_BCMP /*config-skip*/
+#endif
+#include <string.h> /* Check whether new DECC has #defined bcopy and bzero */
/* HAS_BCOPY:
* This symbol is defined if the bcopy() routine is available to
* copy blocks of memory.
*/
#undef HAS_BCOPY /**/
+#ifdef bcopy
+# define HAS_BCOPY /*config-skip*/
+#endif
/* HAS_BZERO:
* This symbol is defined if the bzero() routine is available to
* set a memory block to 0.
*/
#undef HAS_BZERO /**/
+#ifdef bzero
+# define HAS_BZERO /*config-skip*/
+#endif
/* CASTNEGFLOAT:
* This symbol is defined if the C compiler can cast negative
@@ -134,9 +164,6 @@
* trigger the necessary tests.
*/
#define HASCONST /**/
-#ifndef HASCONST
-#define const
-#endif
/* HAS_CRYPT:
* This symbol, if defined, indicates that the crypt routine is available
@@ -204,31 +231,44 @@
*/
#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".
+ */
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define HAS_GETTIMEOFDAY /**/
+#else
+#undef HAS_GETTIMEOFDAY /*config-skip*/
+#endif
+#ifdef HAS_GETTIMEOFDAY
+# define Timeval struct timeval /*config-skip*/
+#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.
*/
+/* 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.
+ */
#undef HAS_GETGROUPS /**/
+#undef HAS_SETGROUPS /**/
/* 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.
*/
-#undef HAS_UNAME /**/
-
-/* HAS_GETPGRP:
- * This symbol, if defined, indicates that the getpgrp routine is
- * available to get the current process group.
- */
-#undef HAS_GETPGRP /**/
-
-/* HAS_GETPGRP2:
- * This symbol, if defined, indicates that the getpgrp2() (as in DG/UX)
- * routine is available to get the current process group.
- */
-#undef HAS_GETPGRP2 /**/
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define HAS_UNAME /**/
+#else
+#undef HAS_UNAME /*config-skip*/
+#endif
/* HAS_GETPRIORITY:
* This symbol, if defined, indicates that the getpriority routine is
@@ -265,13 +305,21 @@
* This symbol, if defined, indicates that the mbstowcs routine is
* available to covert a multibyte string into a wide character string.
*/
-#undef HAS_MBSTOWCS /**/
+#ifdef __DECC
+# define HAS_MBSTOWCS /*config-skip*/
+#else
+# undef HAS_MBSTOWCS /*config-skip*/
+#endif
/* HAS_MBTOWC:
* This symbol, if defined, indicates that the mbtowc routine is available
* to covert a multibyte to a wide character.
*/
-#undef HAS_MBTOWC /**/
+#ifdef __DECC
+# define HAS_MBTOWC /*config-skip*/
+#else
+# undef HAS_MBTOWC /*config-skip*/
+#endif
/* HAS_MEMCMP:
* This symbol, if defined, indicates that the memcmp routine is available
@@ -381,23 +429,6 @@
*/
#undef HAS_SETEUID /**/
-/* HAS_SETLOCALE:
- * This symbol, if defined, indicates that the setlocale routine is
- * available to handle locale-specific ctype implementations.
- */
-#undef HAS_SETLOCALE /**/
-
-/* HAS_SETPGID:
- * This symbol, if defined, indicates that the setpgid routine is
- * available to set process group ID.
- */
-#undef HAS_SETPGID /**/
-
-/* HAS_SETPGRP2:
- * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
- * routine is available to set the current process group.
- */
-#undef HAS_SETPGRP2 /**/
/* HAS_SETPRIORITY:
* This symbol, if defined, indicates that the setpriority routine is
@@ -473,7 +504,11 @@
* This symbol, if defined, indicates that Vr4's sigaction() routine
* is available.
*/
-#undef HAS_SIGACTION /**/
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define HAS_SIGACTION /**/
+#else
+#undef HAS_SIGACTION /*config-skip*/
+#endif
/* USE_STAT_BLOCKS:
* This symbol is defined if this system has a stat structure declaring
@@ -497,36 +532,40 @@
* to determine the number of bytes in the buffer. USE_STDIO_BASE
* will never be defined unless USE_STDIO_PTR is.
*/
-/* VMS:
- * Regular FILE * are pretty close to meeting these criteria, but socket
- * I/O uses a summy FILE *, and Perl doesn't distinguish between socket
- * and non-socket filehandles.
+/* STDIO_PTR_LVALUE:
+ * This symbol is defined if the FILE_ptr macro can be used as an
+ * lvalue.
+ */
+/* STDIO_CNT_LVALUE:
+ * This symbol is defined if the FILE_cnt macro can be used as an
+ * lvalue.
*/
-#undef USE_STDIO_PTR /**/
-#undef USE_STDIO_BASE /**/
+#ifdef __DECC
+# define USE_STDIO_PTR /*config-skip*/
+# define USE_STDIO_BASE /*config-skip*/
+# define STDIO_PTR_LVALUE /*config-skip*/
+# define STDIO_CNT_LVALUE /*config-skip*/
+#else
+# undef USE_STDIO_PTR /*config-skip*/
+# undef USE_STDIO_BASE /*config-skip*/
+# undef STDIO_PTR_LVALUE /*config-skip*/
+# undef STDIO_CNT_LVALUE /*config-skip*/
+#endif
/* 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.
- */
-#undef FILE_ptr
-#undef STDIO_PTR_LVALUE
-#undef FILE_cnt
-#undef STDIO_CNT_LVALUE
+#ifdef USE_STDIO_PTR
+# define FILE_ptr(fp) ((*fp)->_ptr)
+# define FILE_cnt(fp) ((*fp)->_cnt)
+#endif
/* FILE_base:
* This macro is used to access the _base field (or equivalent) of the
@@ -539,8 +578,10 @@
* structure pointed to its argument. This macro will always be defined
* if USE_STDIO_BASE is defined.
*/
-#undef FILE_base
-#undef FILE_bufsiz
+#ifdef USE_STDIO_BASE
+# define FILE_base(fp) ((*fp)->_base)
+# define FILE_bufsiz(fp) ((*fp)->_cnt + (*fp)->_ptr - (*fp)->_base)
+#endif
/* USE_STRUCT_COPY:
* This symbol, if defined, indicates that this C compiler knows how
@@ -566,11 +607,7 @@
*/
#define HAS_STRERROR /**/
#undef HAS_SYS_ERRLIST /**/
-#ifdef HAS_STRERROR
-# define Strerror(e) strerror((e),vaxc$errno)
-#else
-#define Strerror(e) ((e)<0||(e)>=sys_nerr?"unknown":sys_errlist[e]) /**/ /* config-skip */
-#endif
+#define Strerror(e) strerror((e),vaxc$errno)
/* HAS_SYMLINK:
* This symbol, if defined, indicates that the symlink routine is available
@@ -601,7 +638,11 @@
* This symbol, if defined, indicates that the truncate routine is
* available to truncate files.
*/
-#undef HAS_TRUNCATE /**/
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define HAS_TRUNCATE /**/
+#else
+#undef HAS_TRUNCATE /*config-skip*/
+#endif
/* HAS_VFORK:
@@ -643,7 +684,11 @@
/* HAS_WAIT4:
* This symbol, if defined, indicates that wait4() exists.
*/
-#undef HAS_WAIT4 /**/
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define HAS_WAIT4 /**/
+#else
+#undef HAS_WAIT4 /*config-skip*/
+#endif
/* HAS_WAITPID:
* This symbol, if defined, indicates that the waitpid routine is
@@ -655,7 +700,11 @@
* This symbol, if defined, indicates that the wcstombs routine is
* available to convert wide character strings to multibyte strings.
*/
-#undef HAS_WCSTOMBS /**/
+#ifdef __DECC
+# define HAS_WCSTOMBS /*config-skip*/
+#else
+# undef HAS_WCSTOMBS /*config-skip*/
+#endif
/* I_DIRENT:
* This symbol, if defined, indicates to the C program that it should
@@ -688,7 +737,7 @@
* include <limits.h> to get definition of symbols like WORD_BIT or
* LONG_MAX, i.e. machine dependant limitations.
*/
-#undef I_LIMITS /**/
+#define I_LIMITS /**/
/* I_MEMORY:
* This symbol, if defined, indicates to the C program that it should
@@ -786,6 +835,12 @@
*/
#undef I_SYS_NDIR /**/
+/* I_SYS_RESOURCE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/resource.h>.
+ */
+#undef 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.
@@ -803,6 +858,12 @@
#undef I_DBM /**/
#undef I_RPCSVC_DBM /**/
+/* I_SFIO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sfio.h>.
+ */
+#undef I_SFIO /**/
+
/* I_SYS_STAT:
* This symbol, if defined, indicates to the C program that it should
* include <sys/stat.h>.
@@ -827,6 +888,12 @@
*/
#undef I_SYS_UN /**/
+/* I_SYS_WAIT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/wait.h>.
+ */
+#undef 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
@@ -919,7 +986,11 @@
* is defined, and 'int *' otherwise. This is only useful if you
* have select(), of course.
*/
-#define Select_fd_set_t int * /**/
+#if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000) && defined(DECCRTL_SOCKETS)
+#define Select_fd_set_t fd_set * /**/
+#else
+#define Select_fd_set_t int * /* config-skip */
+#endif
/* STDCHAR:
* This symbol is defined to be the type of char used in stdio.h.
@@ -942,7 +1013,12 @@
* 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 "/perl_root/000000" /**/
+#define BIN_EXP "/perl_root/000000" /**/
/* HAS_ALARM:
* This symbol, if defined, indicates that the alarm routine is
@@ -1052,13 +1128,21 @@
* This symbol, if defined, indicates that the mblen routine is available
* to find the number of bytes in a multibye character.
*/
-#undef HAS_MBLEN /**/
+#ifdef __DECC
+# define HAS_MBLEN /*config-skip*/
+#else
+# undef HAS_MBLEN /*config-skip*/
+#endif
/* HAS_MKTIME:
* This symbol, if defined, indicates that the mktime routine is
* available.
*/
-#undef HAS_MKTIME /**/
+#ifdef __DECC
+# define HAS_MKTIME /*config-skip*/
+#else
+# undef HAS_MKTIME /*config-skip*/
+#endif
/* HAS_NICE:
* This symbol, if defined, indicates that the nice routine is
@@ -1101,19 +1185,49 @@
* functions are available for string searching.
*/
#define HAS_STRCHR /**/
-#undef HAS_INDEX /**/
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define HAS_INDEX /**/
+#else
+#undef HAS_INDEX /*config-skip*/
+#endif
/* HAS_STRCOLL:
* This symbol, if defined, indicates that the strcoll routine is
* available to compare strings using collating information.
*/
-#undef HAS_STRCOLL /**/
+#ifdef __DECC
+# define HAS_STRCOLL /*config-skip*/
+#else
+# undef HAS_STRCOLL /*config-skip*/
+#endif
+
+/* 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 compare strings using collating information.
*/
-#undef HAS_STRXFRM /**/
+#ifdef __DECC
+# define HAS_STRXFRM /*config-skip*/
+#else
+# undef HAS_STRXFRM /*config-skip*/
+#endif
/* HAS_TCGETPGRP:
* This symbol, if defined, indicates that the tcgetpgrp routine is
@@ -1150,7 +1264,11 @@
* This symbol, if defined, indicates that the wctomb routine is available
* to covert a wide character to a multibyte.
*/
-#undef HAS_WCTOMB /**/
+#ifdef __DECC
+# define HAS_WCTOMB /*config-skip*/
+#else
+# undef HAS_WCTOMB /*config-skip*/
+#endif
/* Fpos_t:
* This symbol holds the type used to declare file positions in libc.
@@ -1191,23 +1309,21 @@
*/
#define I_MATH /**/
-/* I_LOCALE:
- * This symbol, if defined, indicates to the C program that it should
- * include <locale.h>.
- */
-#undef I_LOCALE /**/
-
-/* I_SYS_STAT:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/stat.h>.
- */
-#define I_SYS_STAT /**/
-
/* INTSIZE:
* This symbol contains the size of an 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 /**/
/* Off_t:
* This symbol holds the type used to declare offsets in the kernel.
@@ -1216,6 +1332,14 @@
*/
#define Off_t int /* <offset> type */
+/* 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.
+ */
+#undef I_VALUES /**/
+
/* Free_t:
* This variable contains the return type of free(). It is usually
* void, but occasionally int.
@@ -1231,6 +1355,14 @@
*/
#undef MYMALLOC /**/
+/* 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.
+ */
+#define SH_PATH "MCR" /**/
+
/* SIG_NAME:
* This symbol contains a list of signal names in order. This is intended
* to be used as a static array initialization, like this:
@@ -1243,9 +1375,17 @@
* corresponds to the 0 at the end of the sig_num list.
* See SIG_NUM and SIG_MAX.
*/
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE",\
+ "KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM",\
+ "ABRT","USR1","USR2","SPARE18","SPARE19","CHLD","CONT",\
+ "STOP","TSTP","TTIN","TTOU","DEBUG","SPARE27","SPARE28",\
+ "SPARE29","SPARE30","SPARE31","SPARE32","RTMIN","RTMAX",0 /**/
+#else
#define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","TRAP","IOT","EMT","FPE",\
"KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM",\
- "ABRT","USR1","USR2",0
+ "ABRT","USR1","USR2",0 /*config-skip*/
+#endif
/* SIG_NUM:
* This symbol contains a list of signal number, in the same order as the
@@ -1260,7 +1400,11 @@
* The last element is 0, corresponding to the 0 at the end of
* the sig_name list.
*/
-#define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,0 /**/
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,64,0 /**/
+#else
+#define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,6,16,17,0 /*config-skip*/
+#endif
/* Mode_t:
* This symbol holds the type used to declare file modes
@@ -1302,11 +1446,18 @@
* 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
-#define VAL_EAGAIN
-#define RD_NODATA
+#undef VAL_O_NONBLOCK
+#undef VAL_EAGAIN
+#undef RD_NODATA
#undef EOF_NONBLOCK
+/* OLDARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user has perl5.000 or perl5.001 architecture-dependent
+ * public library files for $package. For the most part, these
+ * files will work with 5.002 (and later), but that is not
+ * guaranteed.
+ */
/* OLDARCHLIB_EXP:
* This symbol contains the ~name expanded version of OLDARCHLIB, to be
* used in programs that are not prepared to deal with ~ expansion at
@@ -1318,21 +1469,46 @@
* any changes to FndVers.Com instead.
*/
#define OLDARCHLIB_EXP "/perl_root/lib/VMS_VAX" /**/
+#define OLDARCHLIB OLDARCHLIB_EXP /*config-skip*/
-/* PRIVLIB_EXP:
+/* 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_EXP "/perl_root/lib" /**/
+#define PRIVLIB PRIVLIB_EXP /*config-skip*/
+/* 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_EXP "/perl_root/lib/site_perl" /**/
+#define SITELIB SITELIB_EXP /*config-skip*/
+/* 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.
@@ -1343,14 +1519,7 @@
* any changes to FndVers.Com instead.
*/
#define SITEARCH_EXP "/perl_root/lib/site_perl/VMS_VAX" /**/
-
-/* SCRIPTDIR:
- * This symbol holds the name of the directory in which the user wants
- * to put publicly executable scripts for the package in question. It
- * is often a directory that is mounted across diverse architectures.
- * Programs must be prepared to deal with ~name expansion.
- */
-#define SCRIPTDIR "/perl_root/script" /**/
+#define SITEARCH SITEARCH_EXP /*config-skip*/
/* Size_t:
* This symbol holds the type used to declare length parameters
@@ -1377,15 +1546,6 @@
*/
#undef I_SYS_PARAM
-/* GNUC_ATTRIBUTE_CHECK:
- * This symbol indicates the C compiler can check for function attributes,
- * such as printf formats.
- */
-/* VMS: true for gcc, undef for VAXC/DECC. This is handled in Descrip.MMS
- * C. Bailey 26-Aug-1994
- */
-/*#define GNUC_ATTRIBUTE_CHECK /**/
-
/* VOID_CLOSEDIR:
* This symbol, if defined, indicates that the closedir() routine
* does not return a value.
@@ -1425,17 +1585,42 @@
#undef SETUID_SCRIPTS_ARE_SECURE_NOW /**/
#undef DOSUID /**/
+/* 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.
+ * VMS: SocketShr doesn't support this, so we let the Socket extension
+ * roll its own.
+ */
+#undef HAS_INET_ATON /**/
+
/* HAS_ISASCII:
* This manifest constant lets the C program know that the
* isascii is available.
*/
#define HAS_ISASCII /**/
+/* HAS_SETLOCALE:
+ * This symbol, if defined, indicates that the setlocale routine is
+ * available to handle locale-specific ctype implementations.
+ */
+/* I_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
/* HAS_LOCALECONV:
* This symbol, if defined, indicates that the localeconv routine is
* available for numeric and monetary formatting conventions.
*/
-#undef HAS_LOCALECONV /**/
+#ifdef __DECC
+# define I_LOCALE /*config-skip*/
+# define HAS_SETLOCALE /*config-skip*/
+# define HAS_LOCALECONV /*config-skip*/
+#else
+# undef I_LOCALE /*config-skip*/
+# undef HAS_SETLOCALE /*config-skip*/
+# undef HAS_LOCALECONV /*config-skip*/
+#endif
/* HAS_MKFIFO:
* This symbol, if defined, indicates that the mkfifo routine is
@@ -1453,8 +1638,13 @@
* to determine file-system related limits and options associated
* with a given open file descriptor.
*/
-#undef HAS_PATHCONF /**/
-#undef HAS_FPATHCONF /**/
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define HAS_PATHCONF /**/
+#define HAS_FPATHCONF /**/
+#else
+#undef HAS_PATHCONF /*config-skip*/
+#undef HAS_FPATHCONF /*config-skip*/
+#endif
/* HAS_SAFE_BCOPY:
* This symbol, if defined, indicates that the bcopy routine is available
@@ -1472,23 +1662,52 @@
*/
#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_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.
+ */
/* USE_BSDPGRP:
* This symbol, if defined, indicates that the BSD notion of process
* group is to be used. For instance, you have to say setpgrp(pid, pgrp)
* instead of the USG setpgrp().
*/
#undef HAS_SETPGRP /**/
+#undef USE_BSD_SETPGRP /**/
#undef USE_BSDPGRP /**/
+/* HAS_SETPGID:
+ * This symbol, if defined, indicates that the setpgid routine is
+ * available to set process group ID.
+ */
+#undef HAS_SETPGID /**/
+
+/* HAS_SETPGRP2:
+ * This symbol, if defined, indicates that the setpgrp2() (as in DG/UX)
+ * routine is available to set the current process group.
+ */
+#undef HAS_SETPGRP2 /**/
+
/* HAS_SYSCONF:
* This symbol, if defined, indicates that sysconf() is available
* to determine system related limits and options.
*/
-#undef HAS_SYSCONF /**/
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define HAS_SYSCONF /**/
+#else
+#undef HAS_SYSCONF /*config-skip*/
+#endif
/* Gconvert:
* This preprocessor macro is defined to convert a floating point
@@ -1507,6 +1726,36 @@
*/
#define Gconvert(x,n,t,b) my_gconvert(x,n,t,b)
+/* HAS_GETPGID:
+ * This symbol, if defined, indicates to the C program that
+ * the getpgid(pid) function is available to get the
+ * process group id.
+ */
+#undef 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.
+ */
+#undef HAS_GETPGRP /**/
+#undef 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.
+ */
+#undef HAS_GETPGRP2 /**/
+
+/* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+#undef USE_SFIO /**/
+
/* Sigjmp_buf:
* This is the buffer type to be used with Sigsetjmp and Siglongjmp.
*/
@@ -1518,7 +1767,11 @@
* This macro is used in the same way as siglongjmp(), but will invoke
* traditional longjmp() if siglongjmp isn't available.
*/
-#undef HAS_SIGSETJMP /**/
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#define HAS_SIGSETJMP /**/
+#else
+#undef HAS_SIGSETJMP /*config-skip*/
+#endif
#ifdef HAS_SIGSETJMP
#define Sigjmp_buf sigjmp_buf /* config-skip */
#define Sigsetjmp(buf,save_mask) sigsetjmp(buf,save_mask) /* config-skip */
@@ -1542,6 +1795,38 @@
*/
#define STARTPERL "" /**/
+/* Groups_t:
+ * This symbol holds the type used for the second argument to
+ * [gs]etgroups(). Usually, this is the same of gidtype, 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 setgroups.
+ */
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+#define Groups_t unsigned int /* config-skip */
+#endif
+
+/* DB_Prefix_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is u_int32_t.
+ */
+/* DB_Hash_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is size_t.
+ */
+#undef DB_Hash_t /**/
+#undef DB_Prefix_t /**/
+
+/* 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.
+ */
+#undef USE_PERLIO /**/
+
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
* compiler. What various bits mean:
@@ -1595,31 +1880,6 @@
*/
#undef I_NETINET_IN /**/ /* config-skip */
-/* Groups_t:
- * This symbol holds the type used for the second argument to
- * getgroups(). Usually, this is the same of gidtype, 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().
- */
-#ifdef HAS_GETGROUPS
-#define Groups_t unsigned int /* Type for 2nd arg to getgroups() */ /* config-skip */
-#endif
-
-/* DB_Prefix_t:
- * This symbol contains the type of the prefix structure element
- * in the <db.h> header file. In older versions of DB, it was
- * int, while in newer ones it is u_int32_t.
- */
-/* DB_Hash_t:
- * This symbol contains the type of the prefix structure element
- * in the <db.h> header file. In older versions of DB, it was
- * int, while in newer ones it is size_t.
- */
-#undef DB_Hash_t /**/
-#undef DB_Prefix_t /**/
-
/* I_NET_ERRNO:
* This symbol, if defined, indicates that <net/errno.h> exists and
* should be included.
diff --git a/gnu/usr.bin/perl/vms/descrip.mms b/gnu/usr.bin/perl/vms/descrip.mms
index 7e52f19cc97..7681f215863 100644
--- a/gnu/usr.bin/perl/vms/descrip.mms
+++ b/gnu/usr.bin/perl/vms/descrip.mms
@@ -1,5 +1,5 @@
# Descrip.MMS for perl5 on VMS
-# Last revised 22-Mar-1996 by Charles Bailey bailey@genetics.upenn.edu
+# Last revised 20-Mar-1997 by Charles Bailey bailey@genetics.upenn.edu
#
#: This file uses MMS syntax, and can be processed using DEC's MMS product,
#: or the free MMK clone (available by ftp at ftp.spc.edu). If you want to
@@ -24,7 +24,10 @@
#: To each of the above, add /Macro="__AXP__=1" if building on an AXP,
#: /Macro="__DEBUG__=1" to build a debug version
#: (i.e. VMS debugger, not perl -D), and
-#: /Macro="SOCKET=1" to include socket support.
+#: /Macro="SOCKETSHR_SOCKETS=1" to include
+#: SOCKETSHR socket support.
+#: /Macro="DECC_SOCKETS=1" to include UCX (or
+#: compatible) socket support
#
# tidy -- purge files generated by executing this file
# clean -- remove all intermediate (e.g. object files, C files generated
@@ -64,11 +67,27 @@ ARCH = VMS_VAX
OBJVAL = $(MMS$TARGET_NAME)$(O)
.endif
-.first
- @ @[.vms]fndvers.com "" "" "[.vms]descrip.mms"
-
# Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_003 #
+PERL_VERSION = 5_004 #
+
+.ifdef DECC_SOCKETS
+SOCKET=1
+.endif
+
+.ifdef SOCKETSHR_SOCKETS
+SOCKET=1
+.endif
+
+# If they defined SOCKET but didn't choose a stack, default to SOCKETSHR
+.ifdef DECC_SOCKETS
+.else
+.ifdef SOCKETSHR_SOCKETS
+.else
+.ifdef SOCKET
+SOCKETSHR_SOCKETS=1
+.endif
+.endif
+.endif
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
@@ -81,21 +100,27 @@ ARCHAUTO = [.lib.$(ARCH).$(PERL_VERSION).auto]
PIPES_BROKEN = 1
.endif
+.ifdef __DEBUG__
+NOX2P = 1
+.endif
#: >>>>>Compiler-specific options <<<<<
.ifdef GNUC
.first
+ @ @[.vms]fndvers.com "" "" "[.vms]descrip.mms"
@ If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]
CC = gcc
+PIPES_BROKEN = 1
# -fno-builtin avoids bug in gcc up to version 2.6.2 which can destroy
# data when memcpy() is called on large (>64 kB) blocks of memory
# (fixed in gcc 2.6.3)
-XTRACCFLAGS = /Obj=$(MMS$TARGET_NAME)$(O)/NoCase_Hack/Optimize=2/CC1="""""-fno-builtin"""""
+XTRACCFLAGS = /Obj=$(MMS$TARGET_NAME)$(O)/NoCase_Hack/Optimize=2
DBGSPECFLAGS =
XTRADEF = ,GNUC_ATTRIBUTE_CHECK
XTRAOBJS =
LIBS1 = GNU_CC:[000000]GCCLIB.OLB/Library
LIBS2 = Sys$Share:VAXCRTL/Shareable
+POSIX =
.else
XTRAOBJS =
LIBS1 = $(XTRAOBJS)
@@ -108,6 +133,7 @@ DBGSPECFLAGS = /Show=(Source,Include,Expansion)
# just in case.
.first
@ Set Process/Privilege=(NoSYSNAM)
+ @ @[.vms]fndvers.com "" "" "[.vms]descrip.mms"
@ If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include
.ifdef __AXP__
@ If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS Sys$Library
@@ -118,14 +144,17 @@ DBGSPECFLAGS = /Show=(Source,Include,Expansion)
LIBS2 =
XTRACCFLAGS = /Include=[]/Standard=Relaxed_ANSI/Prefix=All/Obj=$(OBJVAL)
XTRADEF =
+POSIX = POSIX
.else # VAXC
.first
+ @ @[.vms]fndvers.com "" "" "[.vms]descrip.mms"
@ If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library
@ If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include
XTRACCFLAGS = /Include=[]/Object=$(O)
XTRADEF =
LIBS2 = Sys$Share:VAXCRTL/Shareable
+POSIX =
.endif
.endif
@@ -138,7 +167,7 @@ DBGLINKFLAGS = /Trace/Debug/Map/Full/Cross
DBG = DBG
.else
DBGCCFLAGS = /NoList
-DBGLINKFLAGS = /NoMap
+DBGLINKFLAGS = /NoTrace/NoMap
DBG =
.endif
@@ -146,8 +175,13 @@ DBG =
#: By default, used SOCKETSHR library; see ReadMe.VMS
#: for information on changing socket support
.ifdef SOCKET
+.ifdef DECC_SOCKETS
+SOCKDEF = ,VMS_DO_SOCKETS,DECCRTL_SOCKETS
+SOCKLIB =
+.else
SOCKDEF = ,VMS_DO_SOCKETS
SOCKLIB = SocketShr/Share
+.endif
# N.B. the targets for $(SOCKC) and $(SOCKH) assume that the permanent
# copies live in [.vms], and the `clean' target will delete copies of
# these files in the current default directory.
@@ -211,18 +245,18 @@ extobj = $(myextobj)
h1 = EXTERN.h, INTERN.h, XSUB.h, av.h, config.h, cop.h, cv.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, vmsish.h, util.h
+h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h, perlio.h, perlsdio.h
h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS)
-c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c
+c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c, universal.c, perlio.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, globals.c, vms.c $(SOCKCLIS)
c = $(c1), $(c2), $(c3), miniperlmain.c, perlmain.c
-obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O)
+obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O), perlio$(O)
obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O)
-obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), globals$(O), vms$(O) $(SOCKOBJ)
+obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), universal$(O), globals$(O), vms$(O) $(SOCKOBJ)
obj = $(obj1), $(obj2), $(obj3)
@@ -231,7 +265,7 @@ ac2 = $(ARCHCORE)config.h $(ARCHCORE)cop.h $(ARCHCORE)cv.h $(ARCHCORE)embed.h
ac3 = $(ARCHCORE)form.h $(ARCHCORE)gv.h $(ARCHCORE)handy.h $(ARCHCORE)hv.h
ac4 = $(ARCHCORE)keywords.h $(ARCHCORE)mg.h $(ARCHCORE)op.h $(ARCHCORE)opcode.h
ac5 = $(ARCHCORE)patchlevel.h $(ARCHCORE)perl.h $(ARCHCORE)perly.h
-ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h
+ac6 = $(ARCHCORE)pp.h $(ARCHCORE)proto.h $(ARCHCORE)regcomp.h $(ARCHCORE)perlio.h $(ARCHCORE)perlsdio.h
ac7 = $(ARCHCORE)regexp.h $(ARCHCORE)scope.h $(ARCHCORE)sv.h $(ARCHCORE)util.h
ac8 = $(ARCHCORE)vmsish.h $(ARCHCORE)$(DBG)libperl$(OLB) $(ARCHCORE)perlshr_attr.opt
ac9 = $(ARCHCORE)$(DBG)perlshr_bld.opt
@@ -262,27 +296,39 @@ CRTLOPTS =,$(CRTL)/Options
$(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c
.endif
+# Modules which must be installed before we can build extensions
+LIBPREREQ = $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib]vmsish.pm [.lib.VMS]Filespec.pm [.lib.ExtUtils]XSSymSet.pm
+utils1 = [.lib.pod]perldoc.com [.lib.ExtUtils]Miniperl.pm [.utils]c2ph.com [.utils]h2ph.com [.utils]h2xs.com [.lib]perlbug.com
+utils2 = [.lib]splain.com [.utils]pl2pm.com
+
+.ifdef NOX2P
all : base extras archcorefiles preplibrary perlpods
@ $(NOOP)
+.else
+all : base extras x2p archcorefiles preplibrary perlpods
+ @ $(NOOP)
+.endif
base : miniperl perl
@ $(NOOP)
-extras : Fcntl FileHandle Safe libmods utils podxform
+extras : Fcntl IO Opcode $(POSIX) libmods utils podxform
@ $(NOOP)
-libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm
+libmods : $(LIBPREREQ)
@ $(NOOP)
-utils : [.lib.pod]perldoc [.lib.ExtUtils]Miniperl.pm [.utils]c2ph [.utils]h2ph [.utils]h2xs [.lib]perlbug
+utils : $(utils1) $(utils2)
@ $(NOOP)
-podxform : [.lib.pod]pod2text [.lib.pod]pod2html [.lib.pod]pod2latex [.lib.pod]pod2man
+podxform : [.lib.pod]pod2text.com [.lib.pod]pod2html.com [.lib.pod]pod2latex.com [.lib.pod]pod2man.com
+ @ $(NOOP)
+x2p : [.x2p]a2p$(E) [.x2p]s2p.com [.x2p]find2perl.com
@ $(NOOP)
-pod1 = [.lib.pod]perl.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod
-pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod
+pod1 = [.lib.pod]perl.pod [.lib.pod]perlapio.pod [.lib.pod]perlbook.pod [.lib.pod]perlbot.pod [.lib.pod]perlcall.pod
+pod2 = [.lib.pod]perldata.pod [.lib.pod]perldebug.pod [.lib.pod]perldelta.pod [.lib.pod]perldiag.pod [.lib.pod]perldsc.pod
pod3 = [.lib.pod]perlembed.pod [.lib.pod]perlform.pod [.lib.pod]perlfunc.pod [.lib.pod]perlguts.pod
-pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod
-pod5 = [.lib.pod]perlop.pod [.lib.pod]perlovl.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod
-pod6 = [.lib.pod]perlref.pod [.lib.pod]perlrun.pod [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod
-pod7 = [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod [.lib.pod]perltie.pod [.lib.pod]perltoc.pod
+pod4 = [.lib.pod]perlipc.pod [.lib.pod]perllocale.pod [.lib.pod]perllol.pod [.lib.pod]perlmod.pod [.lib.pod]perlobj.pod
+pod5 = [.lib.pod]perlop.pod [.lib.pod]perlpod.pod [.lib.pod]perlre.pod [.lib.pod]perlref.pod [.lib.pod]perlrun.pod
+pod6 = [.lib.pod]perlsec.pod [.lib.pod]perlstyle.pod [.lib.pod]perlsub.pod [.lib.pod]perlsyn.pod
+pod7 = [.lib.pod]perltie.pod [.lib.pod]perltoc.pod [.lib.pod]perltoot.pod
pod8 = [.lib.pod]perltrap.pod [.lib.pod]perlvar.pod [.lib.pod]perlxs.pod [.lib.pod]perlxstut.pod
perlpods : $(pod1) $(pod2) $(pod3) $(pod4) $(pod5) $(pod6) $(pod7) $(pod8) [.lib.pod]perlvms.pod
@@ -295,7 +341,7 @@ miniperl : $(DBG)miniperl$(E)
@ Continue
miniperl_objs = miniperlmain$(O), $(obj)
$(MINIPERL_EXE) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
- Link $(LINKFLAGS)/NoDebug/Exe=$(MMS$TARGET) miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
+ Link $(LINKFLAGS)/NoDebug/NoMap/NoFull/NoCross/Exe=$(MMS$TARGET) miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
$(DBG)miniperl$(E) : $(miniperl_objs), $(DBG)libperl$(OLB) $(CRTL)
Link $(LINKFLAGS)/Exe=$(MMS$TARGET) miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
@@ -313,12 +359,13 @@ perl : $(DBG)perl$(E)
$(DBG)perl$(E) : perlmain$(O), $(DBG)perlshr$(E), $(MINIPERL_EXE)
@ @[.vms]genopt "PerlShr.Opt/Write" "|" "''F$Environment("Default")'$(DBG)PerlShr$(E)/Share"
.ifdef gnuc
- @ @[.vms]genopt "PerlShr.Opt/Append" "|" "$(LIBS1)|$(LIBS2)"
-.endif
+ Link $(LINKFLAGS)/Exe=$(MMS$TARGET) perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option, crtl.opt/Option
+.else
Link $(LINKFLAGS)/Exe=$(MMS$TARGET) perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option
+.endif
$(DBG)perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts
- Link /NoTrace$(LINKFLAGS)/Share=$(MMS$TARGET) $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option
+ Link $(LINKFLAGS)/Share=$(MMS$TARGET) $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option
# The following files are built in one go by gen_shrfls.pl:
# perlshr_attr.opt, $(DBG)perlshr_bld.opt - VAX and AXP
@@ -358,54 +405,47 @@ $(ARCHDIR)config.pm : [.lib]config.pm
@ Delete/NoLog/NoConfirm genconfig.opt;
$(MINIPERL) ConfigPM.
-[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs $(MINIPERL_EXE)
+[.ext.dynaloader]dl_vms.c : [.ext.dynaloader]dl_vms.xs [.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE)
$(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET)
[.ext.dynaloader]dl_vms$(O) : [.ext.dynaloader]dl_vms.c
- $(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE)
+ $(CC) $(CFLAGS) /Include=([],[.ext.dynaloader])/Object=$(MMS$TARGET) $(MMS$SOURCE)
[.lib]DynaLoader.pm : [.ext.dynaloader]dynaloader.pm
Copy/Log/NoConfirm [.ext.dynaloader]dynaloader.pm [.lib]DynaLoader.pm
@ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]DynaLoader.pm
-Safe : [.lib]Safe.pm [.lib.auto.Safe]Safe$(E)
+Opcode : [.lib]Opcode.pm [.lib]ops.pm [.lib]Safe.pm [.lib.auto.Opcode]Opcode$(E)
@ $(NOOP)
-[.lib]Safe.pm : [.ext.Safe]Descrip.MMS
+[.lib]Opcode.pm : [.ext.Opcode]Descrip.MMS
@ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
- @ Set Default [.ext.Safe]
+ @ Set Default [.ext.Opcode]
$(MMS)
@ Set Default [--]
-[.lib.auto.Safe]Safe$(E) : [.ext.Safe]Descrip.MMS
- @ Set Default [.ext.Safe]
+[.lib]ops.pm : [.ext.Opcode]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.Opcode]
$(MMS)
@ Set Default [--]
-# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
-# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.Safe]Descrip.MMS : [.ext.Safe]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
- $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Safe]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
-
-FileHandle : [.lib]FileHandle.pm [.lib.auto.FileHandle]FileHandle$(E)
- @ $(NOOP)
-
-[.lib]FileHandle.pm : [.ext.FileHandle]Descrip.MMS
+[.lib]Safe.pm : [.ext.Opcode]Descrip.MMS
@ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
- @ Set Default [.ext.FileHandle]
+ @ Set Default [.ext.Opcode]
$(MMS)
@ Set Default [--]
-[.lib.auto.FileHandle]FileHandle$(E) : [.ext.FileHandle]Descrip.MMS
- @ Set Default [.ext.FileHandle]
+[.lib.auto.Opcode]Opcode$(E) : [.ext.Opcode]Descrip.MMS
+ @ Set Default [.ext.Opcode]
$(MMS)
@ Set Default [--]
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.FileHandle]Descrip.MMS : [.ext.FileHandle]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
- $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.FileHandle]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+[.ext.Opcode]Descrip.MMS : [.ext.Opcode]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
+ $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Opcode]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
@ $(NOOP)
@@ -423,58 +463,172 @@ Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
-[.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
+[.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E)
+ @ $(NOOP)
+
+[.lib]POSIX.pm : [.ext.POSIX]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.POSIX]
+ $(MMS)
+ @ Set Default [--]
+
+[.lib.auto.POSIX]POSIX$(E) : [.ext.POSIX]Descrip.MMS
+ @ Set Default [.ext.POSIX]
+ $(MMS)
+ @ Set Default [--]
+
+# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
+# ${@} necessary to distract different versions of MM[SK]/make
+[.ext.POSIX]Descrip.MMS : [.ext.POSIX]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
+ $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.POSIX]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+
+IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]Seekable.pm [.lib.IO]Socket.pm [.lib.auto.IO]IO$(E)
+ @ $(NOOP)
+
+[.lib]IO.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+[.lib.IO]File.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+[.lib.IO]Handle.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+[.lib.IO]Pipe.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+[.lib.IO]Seekable.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+[.lib.IO]Socket.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+[.lib.auto.IO]IO$(E) : [.ext.IO]Descrip.MMS
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
+# ${@} necessary to distract different versions of MM[SK]/make
+[.ext.IO]Descrip.MMS : [.ext.IO]Makefile.PL $(LIBPREREQ) $(DBG)perlshr$(E)
+ $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.IO]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+
+[.lib]vmsish.pm : [.vms.ext]vmsish.pm
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
@ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
-[.lib.pod]perldoc : [.utils]perldoc.PL $(ARCHDIR)Config.pm
+[.lib.ExtUtils]XSSymSet.pm : [.vms.ext]XSSymSet.pm
+ @ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
+[.lib.pod]perldoc.com : [.utils]perldoc.PL $(ARCHDIR)Config.pm
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
$(MINIPERL) $(MMS$SOURCE)
- Copy/Log [.utils]perldoc $(MMS$TARGET)
+ Copy/Log [.utils]perldoc.com $(MMS$TARGET)
[.lib.ExtUtils]Miniperl.pm : Minimod.PL miniperlmain.c $(ARCHDIR)Config.pm
$(MINIPERL) $(MMS$SOURCE) >$(MMS$TARGET)
-[.utils]c2ph : [.utils]c2ph.PL $(ARCHDIR)Config.pm
+[.utils]c2ph.com : [.utils]c2ph.PL $(ARCHDIR)Config.pm
+ $(MINIPERL) $(MMS$SOURCE)
+
+[.utils]h2ph.com : [.utils]h2ph.PL $(ARCHDIR)Config.pm
$(MINIPERL) $(MMS$SOURCE)
-[.utils]h2ph : [.utils]h2ph.PL $(ARCHDIR)Config.pm
+[.utils]h2xs.com : [.utils]h2xs.PL $(ARCHDIR)Config.pm
$(MINIPERL) $(MMS$SOURCE)
-[.utils]h2xs : [.utils]h2xs.PL $(ARCHDIR)Config.pm
+[.lib]perlbug.com : [.utils]perlbug.PL $(ARCHDIR)Config.pm
$(MINIPERL) $(MMS$SOURCE)
+ Rename/Log [.utils]perlbug.com $(MMS$TARGET)
-[.lib]perlbug : [.utils]perlbug.PL $(ARCHDIR)Config.pm
+[.utils]pl2pm.com : [.utils]pl2pm.PL $(ARCHDIR)Config.pm
$(MINIPERL) $(MMS$SOURCE)
- Rename/Log [.utils]perlbug $(MMS$TARGET)
-[.utils]pl2pm : [.utils]pl2pm.PL $(ARCHDIR)Config.pm
+[.lib]splain.com : [.utils]splain.PL $(ARCHDIR)Config.pm
$(MINIPERL) $(MMS$SOURCE)
+ Rename/Log [.utils]splain.com $(MMS$TARGET)
+
+[.x2p]find2perl.com : [.x2p]find2perl.PL $(ARCHDIR)Config.pm
+ $(MINIPERL) $(MMS$SOURCE)
+
+[.x2p]s2p.com : [.x2p]s2p.PL $(ARCHDIR)Config.pm
+ $(MINIPERL) $(MMS$SOURCE)
+
+# Rename catches problem with some DECC versions in which object file is
+# placed in current default dir, not same one as source file.
+[.x2p]$(DBG)a2p$(E) : [.x2p]a2p$(O), [.x2p]hash$(O), [.x2p]str$(O), [.x2p]util$(O), [.x2p]walk$(O)
+ @ If F$Search("hash$(O)").nes."" Then Rename/NoLog hash$(O),str$(O),util$(O),walk$(O) [.x2p]
+ Link $(LINKFLAGS) /Exe=$(MMS$TARGET) $(MMS$SOURCE_LIST) $(CRTLOPTS)
+
+# Accomodate buggy cpp in some version of DECC, which chokes on illegal
+# filespec "y.tab.c", and broken gcc cpp, which doesn't start #include ""
+# search in same dir as source file
+[.x2p]a2p$(O) : [.x2p]a2p.c $(MINIPERL_EXE)
+ $(MINIPERL) -pe "s/^#line\s+(\d+)\s+\Q""y.tab.c""/#line $1 ""y_tab.c""/;" $(MMS$SOURCE) >$(MMS$TARGET_NAME)_vms.c
+ $(CC) $(CFLAGS) /Object=$(MMS$TARGET)/Include=([.x2p],[]) $(MMS$TARGET_NAME)_vms.c
+ Delete/Log/NoConfirm $(MMS$TARGET_NAME)_vms.c;
+
+# gcc cpp broken -- doesn't look in directory of source file for #include ""
+.ifdef GNUC
+[.x2p]hash$(O) : [.x2p]hash.c
+ $(CC) $(CFLAGS) /Include=[.x2p] $(MMS$SOURCE)
+
+[.x2p]str$(O) : [.x2p]str.c
+ $(CC) $(CFLAGS) /Include=[.x2p] $(MMS$SOURCE)
+
+[.x2p]util$(O) : [.x2p]util.c
+ $(CC) $(CFLAGS) /Include=[.x2p] $(MMS$SOURCE)
-[.lib.pod]pod2html : [.pod]pod2html.PL $(ARCHDIR)Config.pm
+[.x2p]walk$(O) : [.x2p]walk.c
+ $(CC) $(CFLAGS) /Include=[.x2p] $(MMS$SOURCE)
+.endif
+
+[.lib.pod]pod2html.com : [.pod]pod2html.PL $(ARCHDIR)Config.pm
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
$(MINIPERL) $(MMS$SOURCE)
- Rename/Log [.pod]pod2html $(MMS$TARGET)
+ Rename/Log [.pod]pod2html.com $(MMS$TARGET)
-[.lib.pod]pod2latex : [.pod]pod2latex.PL $(ARCHDIR)Config.pm
+[.lib.pod]pod2latex.com : [.pod]pod2latex.PL $(ARCHDIR)Config.pm
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
$(MINIPERL) $(MMS$SOURCE)
- Rename/Log [.pod]pod2latex $(MMS$TARGET)
+ Rename/Log [.pod]pod2latex.com $(MMS$TARGET)
-[.lib.pod]pod2man : [.pod]pod2man.PL $(ARCHDIR)Config.pm
+[.lib.pod]pod2man.com : [.pod]pod2man.PL $(ARCHDIR)Config.pm
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
$(MINIPERL) $(MMS$SOURCE)
- Rename/Log [.pod]pod2man $(MMS$TARGET)
+ Rename/Log [.pod]pod2man.com $(MMS$TARGET)
-[.lib.pod]pod2text : [.pod]pod2text.PL $(ARCHDIR)Config.pm
+[.lib.pod]pod2text.com : [.pod]pod2text.PL $(ARCHDIR)Config.pm
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
$(MINIPERL) $(MMS$SOURCE)
- Rename/Log [.pod]pod2text $(MMS$TARGET)
+ Rename/Log [.pod]pod2text.com $(MMS$TARGET)
-preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm $(SOCKPM)
+preplibrary : $(MINIPERL_EXE) $(LIBPREREQ) $(SOCKPM)
@ Write Sys$Output "Autosplitting Perl library . . ."
@ Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]*.pm [.lib.*]*.pm
@@ -483,6 +637,10 @@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
@ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+[.lib.pod]perlapio.pod : [.pod]perlapio.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+
[.lib.pod]perlbook.pod : [.pod]perlbook.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
@ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
@@ -503,6 +661,10 @@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
@ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+[.lib.pod]perldelta.pod : [.pod]perldelta.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+
[.lib.pod]perldiag.pod : [.pod]perldiag.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
@ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
@@ -527,6 +689,10 @@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
@ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+[.lib.pod]perllocale.pod : [.pod]perllocale.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+
[.lib.pod]perlipc.pod : [.pod]perlipc.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
@ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
@@ -547,10 +713,6 @@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
@ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
-[.lib.pod]perlovl.pod : [.pod]perlovl.pod
- @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
- @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
-
[.lib.pod]perlpod.pod : [.pod]perlpod.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
@ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
@@ -591,6 +753,10 @@ preplibrary : $(MINIPERL_EXE) $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
@ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+[.lib.pod]perltoot.pod : [.pod]perltoot.pod
+ @ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
+ @ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+
[.lib.pod]perltrap.pod : [.pod]perltrap.pod
@ If F$Search("[.lib]pod.dir").eqs."" Then Create/Directory [.lib.pod]
@ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
@@ -624,7 +790,7 @@ $(SOCKOBJ) : $(SOCKC) $(SOCKH)
[.ext.Socket]Socket$(O) : [.ext.Socket]Socket.c
$(CC) $(CFLAGS) /Object=$(MMS$TARGET) $(MMS$SOURCE)
-[.ext.Socket]Socket.c : [.ext.Socket]Socket.xs $(MINIPERL_EXE)
+[.ext.Socket]Socket.c : [.ext.Socket]Socket.xs [.lib.ExtUtils]XSSymSet.pm $(MINIPERL_EXE)
$(XSUBPP) $(MMS$SOURCE) >$(MMS$TARGET)
.endif # !LINK_ONLY
@@ -676,8 +842,27 @@ perly$(O) : perly.c, perly.h, $(h)
$(CC) $(CFLAGS) $(MMS$SOURCE)
.endif
-test : all
- - @[.VMS]Test.Com
+[.t.lib]vmsfspec.t : [.vms.ext]filespec.t
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
+[.t.lib]vmsish.t : [.vms.ext]vmsish.t
+ Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
+
+test : all [.t.lib]vmsfspec.t [.t.lib]vmsish.t
+ - @[.VMS]Test.Com "$(E)"
+
+archify : all
+ @ Write Sys$Output "Moving files to architecture-specific locations for $(ARCH)"
+ archroot = "$(ARCHAUTO)" - "]" + "...]"
+ Backup/Log/Verify [.lib.auto...]*.*;/Exclude=(*.al,*.ix) 'archroot'/New_Version
+ Delete/Log/NoConfirm [.lib.auto...]*.*;*/exclude=(*.al,*.ix,*.dir)
+ Delete/Log/NoConfirm [.lib]Config.pm;*
+ Copy/Log/NoConfirm *$(E);,[.x2p]a2p$(E); $(ARCHDIR)
+ Delete/Log/NoConfirm Perl*$(E);*,[.x2p]a2p$(E);*
+ @ Write Sys$Output "Architecture-specific setup completed."
+ @ Write Sys$Output "Before building for another architecture, be sure to"
+ @ Write Sys$Output " 1. $(MMS)$(MMSQUALIFIERS) clean"
+ @ Write Sys$Output " 2. Delete Miniperl$(E)"
# CORE subset for MakeMaker, so we can build Perl without sources
# Should move to VMS installperl when we get one
@@ -735,6 +920,12 @@ $(ARCHCORE)patchlevel.h : patchlevel.h
$(ARCHCORE)perl.h : perl.h
@ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)perlio.h : perlio.h
+ @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
+$(ARCHCORE)perlsdio.h : perlsdio.h
+ @ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
+ Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
$(ARCHCORE)perly.h : perly.h
@ If F$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
Copy/Log $(MMS$SOURCE) $(MMS$TARGET)
@@ -782,6 +973,10 @@ $(ARCHAUTO)time.stamp :
.ifdef LINK_ONLY
.else
+# We need an action line here for broken older versions of MMS which
+# otherwise conclude that they should be compiling [.x2p]utils.c :-(
+util$(O) : util.c
+ $(CC) $(CFLAGS) util.c
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
av$(O) : EXTERN.h
av$(O) : av.c
@@ -967,6 +1162,29 @@ mg$(O) : scope.h
mg$(O) : sv.h
mg$(O) : vmsish.h
mg$(O) : util.h
+universal$(O) : EXTERN.h
+universal$(O) : av.h
+universal$(O) : config.h
+universal$(O) : cop.h
+universal$(O) : cv.h
+universal$(O) : embed.h
+universal$(O) : form.h
+universal$(O) : gv.h
+universal$(O) : handy.h
+universal$(O) : hv.h
+universal$(O) : mg.h
+universal$(O) : op.h
+universal$(O) : opcode.h
+universal$(O) : perl.h
+universal$(O) : perly.h
+universal$(O) : pp.h
+universal$(O) : proto.h
+universal$(O) : regexp.h
+universal$(O) : scope.h
+universal$(O) : sv.h
+universal$(O) : vmsish.h
+universal$(O) : util.h
+universal$(O) : universal.c
perl$(O) : EXTERN.h
perl$(O) : av.h
perl$(O) : config.h
@@ -1339,6 +1557,29 @@ vms$(O) : scope.h
vms$(O) : sv.h
vms$(O) : vmsish.h
vms$(O) : util.h
+perlio$(O) : EXTERN.h
+perlio$(O) : av.h
+perlio$(O) : config.h
+perlio$(O) : cop.h
+perlio$(O) : cv.h
+perlio$(O) : embed.h
+perlio$(O) : form.h
+perlio$(O) : gv.h
+perlio$(O) : handy.h
+perlio$(O) : hv.h
+perlio$(O) : mg.h
+perlio$(O) : op.h
+perlio$(O) : opcode.h
+perlio$(O) : perl.h
+perlio$(O) : perly.h
+perlio$(O) : pp.h
+perlio$(O) : proto.h
+perlio$(O) : regexp.h
+perlio$(O) : perlio.c
+perlio$(O) : scope.h
+perlio$(O) : sv.h
+perlio$(O) : vmsish.h
+perlio$(O) : util.h
miniperlmain$(O) : EXTERN.h
miniperlmain$(O) : av.h
miniperlmain$(O) : config.h
@@ -1408,6 +1649,42 @@ globals$(O) : scope.h
globals$(O) : sv.h
globals$(O) : vmsish.h
globals$(O) : util.h
+[.x2p]a2p$(O) : [.x2p]a2p.c
+[.x2p]a2p$(O) : [.x2p]a2py.c
+[.x2p]a2p$(O) : [.x2p]INTERN.h
+[.x2p]a2p$(O) : [.x2p]a2p.h
+[.x2p]a2p$(O) : [.x2p]hash.h
+[.x2p]a2p$(O) : [.x2p]str.h
+[.x2p]a2p$(O) : handy.h
+[.x2p]hash$(O) : [.x2p]hash.c
+[.x2p]hash$(O) : [.x2p]EXTERN.h
+[.x2p]hash$(O) : [.x2p]a2p.h
+[.x2p]hash$(O) : [.x2p]hash.h
+[.x2p]hash$(O) : [.x2p]str.h
+[.x2p]hash$(O) : handy.h
+[.x2p]hash$(O) : [.x2p]util.h
+[.x2p]str$(O) : [.x2p]str.c
+[.x2p]str$(O) : [.x2p]EXTERN.h
+[.x2p]str$(O) : [.x2p]a2p.h
+[.x2p]str$(O) : [.x2p]hash.h
+[.x2p]str$(O) : [.x2p]str.h
+[.x2p]str$(O) : handy.h
+[.x2p]str$(O) : [.x2p]util.h
+[.x2p]util$(O) : [.x2p]util.c
+[.x2p]util$(O) : [.x2p]EXTERN.h
+[.x2p]util$(O) : [.x2p]a2p.h
+[.x2p]util$(O) : [.x2p]hash.h
+[.x2p]util$(O) : [.x2p]str.h
+[.x2p]util$(O) : handy.h
+[.x2p]util$(O) : [.x2p]INTERN.h
+[.x2p]util$(O) : [.x2p]util.h
+[.x2p]walk$(O) : [.x2p]walk.c
+[.x2p]walk$(O) : [.x2p]EXTERN.h
+[.x2p]walk$(O) : [.x2p]a2p.h
+[.x2p]walk$(O) : [.x2p]hash.h
+[.x2p]walk$(O) : [.x2p]str.h
+[.x2p]walk$(O) : handy.h
+[.x2p]walk$(O) : [.x2p]util.h
.endif # !LINK_ONLY
config.h : [.vms]config.vms
@@ -1429,9 +1706,9 @@ cleanlis :
- If F$Search("*.Map").nes."" Then Delete/NoConfirm/Log *.Map;*
tidy : cleanlis
- - If F$Search("*.Opt;-1").nes."" Then Purge/NoConfirm/Log *.Opt
- - If F$Search("*$(O);-1").nes."" Then Purge/NoConfirm/Log *$(O)
- - If F$Search("*$(E);-1").nes."" Then Purge/NoConfirm/Log *$(E)
+ - If F$Search("[...]*.Opt;-1").nes."" Then Purge/NoConfirm/Log [...]*.Opt
+ - If F$Search("[...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [...]*$(O)
+ - If F$Search("[...]*$(E);-1").nes."" Then Purge/NoConfirm/Log [...]*$(E)
- If F$Search("Config.H;-1").nes."" Then Purge/NoConfirm/Log Config.H
- If F$Search("Config.SH;-1").nes."" Then Purge/NoConfirm/Log Config.SH
- If F$Search("perly.c;-1").nes."" Then Purge/NoConfirm/Log perly.c
@@ -1442,8 +1719,7 @@ tidy : cleanlis
- If F$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar
- If F$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O)
- If F$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C
- - If F$Search("[.Ext.Safe...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.Safe]
- - If F$Search("[.Ext.FileHandle...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.FileHandle]
+ - If F$Search("[.Ext.Opcode...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.Opcode]
- If F$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*.C
- If F$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*$(O)
- If F$Search("[.Lib.Auto...]*.al;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Auto...]*.al
@@ -1452,24 +1728,33 @@ tidy : cleanlis
- If F$Search("[.Lib]Socket.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Socket.pm
- If F$Search("[.Lib]Config.pm;-1").nes."" Then Purge/NoConfirm/Log [.Lib]Config.pm
- If F$Search("$(ARCHDIR)Config.pm;-1").nes."" Then Purge/NoConfirm/Log $(ARCHDIR)Config.pm
+ - If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;*
+ - If F$Search("[.lib.ExtUtils]XSSymSet.pm").nes."" Then Purge/NoConfirm/Log [.lib.ExtUtils]XSSymSet.pm;*
- If F$Search("[.Lib.VMS]*.*;-1").nes."" Then Purge/NoConfirm/Log [.Lib.VMS]*.*
- If F$Search("[.Lib.Pod]*.Pod;-1").nes."" Then Purge/NoConfirm/Log [.Lib.Pod]*.Pod
- If F$Search("$(ARCHCORE)*.*").nes."" Then Purge/NoConfirm/Log $(ARCHCORE)*.*
- - If F$Search("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*.
- - If F$Search("[.lib.pod]*.;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.
+ - If F$Search("[.lib]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib]*.com
+ - If F$Search("[.utils]*.com;-1").nes."" Then Purge/NoConfirm/Log [.utils]*.com
+ - If F$Search("[.x2p]*.com;-1").nes."" Then Purge/NoConfirm/Log [.x2p]*.com
+ - If F$Search("[.lib.pod]*.com;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.com
clean : tidy
Set Default [.ext.Fcntl]
- $(MMS) clean
Set Default [--]
- Set Default [.ext.FileHandle]
+ Set Default [.ext.IO]
+ - $(MMS) clean
+ Set Default [--]
+ Set Default [.ext.Opcode]
- $(MMS) clean
Set Default [--]
- Set Default [.ext.Safe]
+.ifdef DECC
+ Set Default [.ext.POSIX]
- $(MMS) clean
Set Default [--]
+.endif
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
- - If F$Search("*$(O);*") .nes."" Then Delete/NoConfirm/Log *$(O);*
+ - If F$Search("[...]*$(O);*") .nes."" Then Delete/NoConfirm/Log [...]*$(O);*
- If F$Search("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;*
- If F$Search("Config.SH").nes."" Then Delete/NoConfirm/Log Config.SH;*
- If F$Search(F$Parse("Sys$Disk:[]","$(SOCKH)")).nes."" Then Delete/NoConfirm/Log $(SOCKH);*
@@ -1492,25 +1777,34 @@ realclean : clean
Set Default [.ext.Fcntl]
- $(MMS) realclean
Set Default [--]
- Set Default [.ext.FileHandle]
+ Set Default [.ext.IO]
+ - $(MMS) realclean
+ Set Default [--]
+ Set Default [.ext.Opcode]
- $(MMS) realclean
Set Default [--]
- Set Default [.ext.Safe]
+.ifdef DECC
+ Set Default [.ext.POSIX]
- $(MMS) realclean
Set Default [--]
+.endif
- If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);"
- If F$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
+ - If F$Search("[.Lib]Socket.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Socket.pm;*
- If F$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
- - If F$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;*
+ - If F$Search("[.Lib]*.com").nes."" Then Delete/NoConfirm/Log [.Lib]*.com;*
+ - If F$Search("[.utils]*.com").nes."" Then Delete/NoConfirm/Log [.utils]*.com;*
+ - If F$Search("[.x2p]*.com").nes."" Then Delete/NoConfirm/Log [.x2p]*.com;*
- If F$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;*
- If F$Search("[.lib.ExtUtils]Miniperl.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]Miniperl.pm;*
- - If F$Search("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*
+ - If F$Search("[.lib.ExtUtils]XSSymSet.pm").nes."" Then Delete/NoConfirm/Log [.lib.ExtUtils]XSSymSet.pm;*
- If F$Search("[.lib.pod]*.pod").nes."" Then Delete/NoConfirm/Log [.lib.pod]*.pod;*
- - If F$Search("[.lib.pod]perldoc.").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.;*
- - If F$Search("[.lib.pod]pod2*.").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.;*
- - If F$Search("*$(E)").nes."" Then Delete/NoConfirm/Log *$(E);*
+ - If F$Search("[.lib.pod]perldoc.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]perldoc.com;*
+ - If F$Search("[.lib.pod]pod2*.com").nes."" Then Delete/NoConfirm/Log [.lib.pod]pod2*.com;*
+ - If F$Search("[.t.lib]vms*.t").nes."" Then Delete/NoConfirm/Log [.t.lib]vms*.t;*
+ - If F$Search("[...]*$(E)").nes."" Then Delete/NoConfirm/Log [...]*$(E);*
cleansrc : clean
- If F$Search("*.C;-1").nes."" Then Purge/NoConfirm/Log *.C
diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/0README.txt b/gnu/usr.bin/perl/vms/ext/DCLsym/0README.txt
new file mode 100644
index 00000000000..9dc721d36b0
--- /dev/null
+++ b/gnu/usr.bin/perl/vms/ext/DCLsym/0README.txt
@@ -0,0 +1,21 @@
+VMS::DCLsym is an extension to Perl 5 which allows it to manipulate DCL symbols
+via an object-oriented or tied-hash interface.
+
+In order to build the extension, just say
+
+$ Perl Makefile.PL
+$ MMK
+
+in the directory containing the source files. Once it's built, you can run the
+test script by saying
+
+$ Perl "-Iblib" test.pl
+
+Finally, if you want to make it part of your regular Perl library, you can say
+$ MMK install
+
+If you have any problems or suggestions, please feel free to let me know.
+
+Regards,
+Charles Bailey bailey@genetics.upenn.edu
+17-Aug-1995
diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm
new file mode 100644
index 00000000000..44c4b84a654
--- /dev/null
+++ b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.pm
@@ -0,0 +1,270 @@
+package VMS::DCLsym;
+
+use Carp;
+use DynaLoader;
+use vars qw( @ISA $VERSION );
+use strict;
+
+# Package globals
+@ISA = ( 'DynaLoader' );
+$VERSION = '1.01';
+my(%Locsyms) = ( ':ID' => 'LOCAL' );
+my(%Gblsyms) = ( ':ID' => 'GLOBAL');
+my $DoCache = 1;
+my $Cache_set = 0;
+
+
+#====> OO methods
+
+sub new {
+ my($pkg,$type) = @_;
+ bless { TYPE => $type }, $pkg;
+}
+
+sub DESTROY { }
+
+sub getsym {
+ my($self,$name) = @_;
+ my($val,$table);
+
+ if (($val,$table) = _getsym($name)) {
+ if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; }
+ else { $Locsyms{$name} = $val; }
+ }
+ wantarray ? ($val,$table) : $val;
+}
+
+sub setsym {
+ my($self,$name,$val,$table) = @_;
+
+ $table = $self->{TYPE} unless $table;
+ if (_setsym($name,$val,$table)) {
+ if ($table eq 'GLOBAL') { $Gblsyms{$name} = $val; }
+ else { $Locsyms{$name} = $val; }
+ 1;
+ }
+ else { 0; }
+}
+
+sub delsym {
+ my($self,$name,$table) = @_;
+
+ $table = $self->{TYPE} unless $table;
+ if (_delsym($name,$table)) {
+ if ($table eq 'GLOBAL') { delete $Gblsyms{$name}; }
+ else { delete $Locsyms{$name}; }
+ 1;
+ }
+ else { 0; }
+}
+
+sub clearcache {
+ my($self,$perm) = @_;
+ my($old);
+
+ $Cache_set = 0;
+ %Locsyms = ( ':ID' => 'LOCAL');
+ %Gblsyms = ( ':ID' => 'GLOBAL');
+ $old = $DoCache;
+ $DoCache = $perm if defined($perm);
+ $old;
+}
+
+#====> TIEHASH methods
+
+sub TIEHASH {
+ $_[0]->new(@_);
+}
+
+sub FETCH {
+ my($self,$name) = @_;
+ if ($name eq ':GLOBAL') { $self->{TYPE} eq 'GLOBAL'; }
+ elsif ($name eq ':LOCAL' ) { $self->{TYPE} eq 'LOCAL'; }
+ else { scalar($self->getsym($name)); }
+}
+
+sub STORE {
+ my($self,$name,$val) = @_;
+ if ($name eq ':GLOBAL') { $self->{TYPE} = 'GLOBAL'; }
+ elsif ($name eq ':LOCAL' ) { $self->{TYPE} = 'LOCAL'; }
+ else { $self->setsym($name,$val); }
+}
+
+sub DELETE {
+ my($self,$name) = @_;
+
+ $self->delsym($name);
+}
+
+sub FIRSTKEY {
+ my($self) = @_;
+ my($name,$eqs,$val);
+
+ if (!$DoCache || !$Cache_set) {
+ # We should eventually replace this with a C routine which walks the
+ # CLI symbol table directly. If I ever get 'hold of an I&DS manual . . .
+ open(P,'Show Symbol * |');
+ while (<P>) {
+ ($name,$eqs,$val) = /^\s+(\S+) (=+) (.+)/
+ or carp "VMS::CLISym: unparseable line $_";
+ $name =~ s#\*##;
+ $val =~ s/"(.*)"$/$1/ or $val =~ s/^(\S+).*/$1/;
+ if ($eqs eq '==') { $Gblsyms{$name} = $val; }
+ else { $Locsyms{$name} = $val; }
+ }
+ close P;
+ $Cache_set = 1;
+ }
+ $self ->{IDX} = 0;
+ $self->{CACHE} = $self->{TYPE} eq 'GLOBAL' ? \%Gblsyms : \%Locsyms;
+ while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) {
+ if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; }
+ $self->{CACHE} = \%Gblsyms;
+ }
+ $name;
+}
+
+sub NEXTKEY {
+ my($self) = @_;
+ my($name,$val);
+
+ while (($name,$val) = each(%{$self->{CACHE}}) and !defined($name)) {
+ if ($self->{CACHE}{':ID'} eq 'GLOBAL') { return undef; }
+ $self->{CACHE} = \%Gblsyms;
+ }
+ $name;
+}
+
+
+sub EXISTS { defined($_[0]->FETCH(@_)) ? 1 : 0 }
+
+sub CLEAR { }
+
+
+bootstrap VMS::DCLsym;
+
+1;
+
+__END__
+
+=head1 NAME
+
+VMS::DCLsym - Perl extension to manipulate DCL symbols
+
+=head1 SYNOPSIS
+
+ tie %allsyms, VMS::DCLsym;
+ tie %cgisyms, VMS::DCLsym, 'GLOBAL';
+
+
+ $handle = new VMS::DCLsyms;
+ $value = $handle->getsym($name);
+ $handle->setsym($name,$value,'GLOBAL') or die "Can't create symbol: $!\n";
+ $handle->delsym($name,'LOCAL') or die "Can't delete symbol: $!\n";
+ $handle->clearcache();
+
+=head1 DESCRIPTION
+
+The VMS::DCLsym extension provides access to DCL symbols using a
+tied hash interface. This allows Perl scripts to manipulate symbols in
+a manner similar to the way in which logical names are manipulated via
+the built-in C<%ENV> hash. Alternatively, one can call methods in this
+package directly to read, create, and delete symbols.
+
+=head2 Tied hash interface
+
+This interface lets you treat the DCL symbol table as a Perl associative array,
+in which the key of each element is the symbol name, and the value of the
+element is that symbol's value. Case is not significant in the key string, as
+DCL converts symbol names to uppercase, but it is significant in the value
+string. All of the usual operations on associative arrays are supported.
+Reading an element retrieves the current value of the symbol, assigning to it
+defines a new symbol (or overwrites the old value of an existing symbol), and
+deleting an element deletes the corresponding symbol. Setting an element to
+C<undef>, or C<undef>ing it directly, sets the corresponding symbol to the null
+string. You may also read the special keys ':GLOBAL' and ':LOCAL' to find out
+whether a default symbol table has been specified for this hash (see C<table>
+below), or set either or these keys to specify a default symbol table.
+
+When you call the C<tie> function to bind an associative array to this package,
+you may specify as an optional argument the symbol table in which you wish to
+create and delete symbols. If the argument is the string 'GLOBAL', then the
+global symbol table is used; any other string causes the local symbol table to
+be used. Note that this argument does not affect attempts to read symbols; if
+a symbol with the specified name exists in the local symbol table, it is always
+returned in preference to a symbol by the same name in the global symbol table.
+
+=head2 Object interface
+
+Although it's less convenient in some ways than the tied hash interface, you
+can also call methods directly to manipulate individual symbols. In some
+cases, this allows you finer control than using a tied hash aggregate. The
+following methods are supported:
+
+=over
+
+=item new
+
+This creates a C<VMS::DCLsym> object which can be used as a handle for later
+method calls. The single optional argument specifies the symbol table used
+by default in future method calls, in the same way as the optional argument to
+C<tie> described above.
+
+=item getsym
+
+If called in a scalar context, C<getsym> returns the value of the symbol whose
+name is given as the argument to the call, or C<undef> if no such symbol
+exists. Symbols in the local symbol table are always used in preference to
+symbols in the global symbol table. If called in an array context, C<getsym>
+returns a two-element list, whose first element is the value of the symbol, and
+whose second element is the string 'GLOBAL' or 'LOCAL', indicating the table
+from which the symbol's value was read.
+
+=item setsym
+
+The first two arguments taken by this method are the name of the symbol and the
+value which should be assigned to it. The optional third argument is a string
+specifying the symbol table to be used; 'GLOBAL' specifies the global symbol
+table, and any other string specifies the local symbol table. If this argument
+is omitted, the default symbol table for the object is used. C<setsym> returns
+TRUE if successful, and FALSE otherwise.
+
+=item delsym
+
+This method deletes the symbol whose name is given as the first argument. The
+optional second argument specifies the symbol table, as described above under
+C<setsym>. It returns TRUE if the symbol was successfully deleted, and FALSE
+if it was not.
+
+=item clearcache
+
+Because of the overhead associated with obtaining the list of defined symbols
+for the tied hash iterator, it is only done once, and the list is reused for
+subsequent iterations. Changes to symbols made through this package are
+recorded, but in the rare event that someone changes the process' symbol table
+from outside (as is possible using some software from the net), the iterator
+will be out of sync with the symbol table. If you expect this to happen, you
+can reset the cache by calling this method. In addition, if you pass a FALSE
+value as the first argument, caching will be disabled. It can be reenabled
+later by calling C<clearcache> again with a TRUE value as the first argument.
+It returns TRUE or FALSE to indicate whether caching was previously enabled or
+disabled, respectively.
+
+This method is a stopgap until we can incorporate code into this extension to
+traverse the process' symbol table directly, so it may disappear in a future
+version of this package.
+
+=head1 AUTHOR
+
+Charles Bailey bailey@genetics.upenn.edu
+
+=head1 VERSION
+
+1.01 08-Dec-1996
+
+=head1 BUGS
+
+The list of symbols for the iterator is assembled by spawning off a
+subprocess, which can be slow. Ideally, we should just traverse the
+process' symbol table directly from C.
+
diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.xs b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.xs
new file mode 100644
index 00000000000..3918eb11e57
--- /dev/null
+++ b/gnu/usr.bin/perl/vms/ext/DCLsym/DCLsym.xs
@@ -0,0 +1,151 @@
+/* VMS::DCLsym - manipulate DCL symbols
+ *
+ * Version: 1.0
+ * Author: Charles Bailey bailey@genetics.upenn.edu
+ * Revised: 17-Aug-1995
+ *
+ *
+ * Revision History:
+ *
+ * 1.0 17-Aug-1995 Charles Bailey bailey@genetics.upenn.edu
+ * original production version
+ */
+
+#include <descrip.h>
+#include <lib$routines.h>
+#include <libclidef.h>
+#include <libdef.h>
+#include <ssdef.h>
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+MODULE = VMS::DCLsym PACKAGE = VMS::DCLsym
+
+void
+_getsym(name)
+ SV * name
+ PPCODE:
+ {
+ struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
+ valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
+ STRLEN namlen;
+ int tbltype;
+ unsigned long int retsts;
+ SETERRNO(0,SS$_NORMAL);
+ if (!name) {
+ PUSHs(sv_newmortal());
+ SETERRNO(EINVAL,LIB$_INVARG);
+ return;
+ }
+ namdsc.dsc$a_pointer = SvPV(name,namlen);
+ namdsc.dsc$w_length = (unsigned short int) namlen;
+ retsts = lib$get_symbol(&namdsc,&valdsc,0,&tbltype);
+ if (retsts & 1) {
+ PUSHs(sv_2mortal(newSVpv(valdsc.dsc$w_length ?
+ valdsc.dsc$a_pointer : "",valdsc.dsc$w_length)));
+ if (GIMME) {
+ EXTEND(sp,2); /* just in case we're at the end of the stack */
+ if (tbltype == LIB$K_CLI_LOCAL_SYM)
+ PUSHs(sv_2mortal(newSVpv("LOCAL",5)));
+ else
+ PUSHs(sv_2mortal(newSVpv("GLOBAL",6)));
+ }
+ _ckvmssts(lib$sfree1_dd(&valdsc));
+ }
+ else {
+ ST(0) = &sv_undef; /* error - we're returning undef, if anything */
+ switch (retsts) {
+ case LIB$_NOSUCHSYM:
+ break; /* nobody home */;
+ case LIB$_INVSYMNAM: /* user errors; set errno return undef */
+ case LIB$_INSCLIMEM:
+ case LIB$_NOCLI:
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ break;
+ default: /* bail out */
+ { _ckvmssts(retsts); }
+ }
+ }
+ }
+
+
+void
+_setsym(name,val,typestr="LOCAL")
+ SV * name
+ SV * val
+ char * typestr
+ CODE:
+ {
+ struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
+ valdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
+ STRLEN slen;
+ int type;
+ unsigned long int retsts;
+ SETERRNO(0,SS$_NORMAL);
+ if (!name || !val) {
+ SETERRNO(EINVAL,LIB$_INVARG);
+ XSRETURN_UNDEF;
+ }
+ namdsc.dsc$a_pointer = SvPV(name,slen);
+ namdsc.dsc$w_length = (unsigned short int) slen;
+ valdsc.dsc$a_pointer = SvPV(val,slen);
+ valdsc.dsc$w_length = (unsigned short int) slen;
+ type = strNE(typestr,"GLOBAL") ?
+ LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM;
+ retsts = lib$set_symbol(&namdsc,&valdsc,&type);
+ if (retsts & 1) { XSRETURN_YES; }
+ else {
+ switch (retsts) {
+ case LIB$_AMBSYMDEF: /* user errors; set errno and return */
+ case LIB$_INSCLIMEM:
+ case LIB$_INVSYMNAM:
+ case LIB$_NOCLI:
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ XSRETURN_NO;
+ break; /* NOTREACHED */
+ default: /* bail out */
+ { _ckvmssts(retsts); }
+ }
+ }
+ }
+
+
+void
+_delsym(name,typestr="LOCAL")
+ SV * name
+ char * typestr
+ CODE:
+ {
+ struct dsc$descriptor_s namdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
+ STRLEN slen;
+ int type;
+ unsigned long int retsts;
+ SETERRNO(0,SS$_NORMAL);
+ if (!name || !typestr) {
+ SETERRNO(EINVAL,LIB$_INVARG);
+ XSRETURN_UNDEF;
+ }
+ namdsc.dsc$a_pointer = SvPV(name,slen);
+ namdsc.dsc$w_length = (unsigned short int) slen;
+ type = strNE(typestr,"GLOBAL") ?
+ LIB$K_CLI_LOCAL_SYM : LIB$K_CLI_GLOBAL_SYM;
+ retsts = lib$delete_symbol(&namdsc,&type);
+ if (retsts & 1) { XSRETURN_YES; }
+ else {
+ switch (retsts) {
+ case LIB$_INVSYMNAM: /* user errors; set errno and return */
+ case LIB$_NOCLI:
+ case LIB$_NOSUCHSYM:
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ XSRETURN_NO;
+ break; /* NOTREACHED */
+ default: /* bail out */
+ { _ckvmssts(retsts); }
+ }
+ }
+ }
+
diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL b/gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL
new file mode 100644
index 00000000000..8e6f5bce40a
--- /dev/null
+++ b/gnu/usr.bin/perl/vms/ext/DCLsym/Makefile.PL
@@ -0,0 +1,3 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm' );
diff --git a/gnu/usr.bin/perl/vms/ext/DCLsym/test.pl b/gnu/usr.bin/perl/vms/ext/DCLsym/test.pl
new file mode 100644
index 00000000000..57f2afbd20f
--- /dev/null
+++ b/gnu/usr.bin/perl/vms/ext/DCLsym/test.pl
@@ -0,0 +1,41 @@
+print "1..15\n";
+
+require VMS::DCLsym or die "failed 1\n";
+print "ok 1\n";
+
+tie %syms, VMS::DCLsym or die "failed 2\n";
+print "ok 2\n";
+
+$name = 'FOO_'.time();
+$syms{$name} = 'Perl_test';
+print +($! ? "(\$! = $!) not " : ''),"ok 3\n";
+
+print +($syms{$name} eq 'Perl_test' ? '' : 'not '),"ok 4\n";
+
+($val) = `Show Symbol $name` =~ /(\w+)"$/;
+print +($val eq 'Perl_test' ? '' : 'not '),"ok 5\n";
+
+while (($sym,$val) = each %syms) {
+ last if $sym eq $name && $val eq 'Perl_test';
+}
+print +($sym ? '' : 'not '),"ok 6\n";
+
+delete $syms{$name};
+print +($! ? "(\$! = $!) not " : ''),"ok 7\n";
+
+print +(defined($syms{$name}) ? 'not ' : ''),"ok 8\n";
+undef %syms;
+
+$obj = new VMS::DCLsym 'GLOBAL';
+print +($obj ? '' : 'not '),"ok 9\n";
+
+print +($obj->clearcache(0) ? '' : 'not '),"ok 10\n";
+print +($obj->clearcache(1) ? 'not ' : ''),"ok 11\n";
+
+print +($obj->setsym($name,'Another_test') ? '' : 'not '),"ok 12\n";
+
+($val,$tab) = $obj->getsym($name);
+print +($val eq 'Another_test' && $tab eq 'GLOBAL' ? '' : 'not '),"ok 13\n";
+
+print +($obj->delsym($name,'LOCAL') ? 'not ' : ''),"ok 14\n";
+print +($obj->delsym($name,'GLOBAL') ? '' : 'not '),"ok 15\n";
diff --git a/gnu/usr.bin/perl/vms/ext/Filespec.pm b/gnu/usr.bin/perl/vms/ext/Filespec.pm
index 3ce67aafdab..db3283c5713 100644
--- a/gnu/usr.bin/perl/vms/ext/Filespec.pm
+++ b/gnu/usr.bin/perl/vms/ext/Filespec.pm
@@ -12,6 +12,7 @@ VMS::Filespec - convert between VMS and Unix file specification syntax
=head1 SYNOPSIS
use VMS::Filespec;
+$fullspec = rmsexpand('[.VMS]file.specification');
$vmsspec = vmsify('/my/Unix/file/specification');
$unixspec = unixify('my:[VMS]file.specification');
$path = pathify('my:[VMS.or.Unix.directory]specification.dir');
@@ -61,6 +62,14 @@ subroutine call, which bypasses prototype checking).
The routines provided are:
+=head2 rmsexpand
+
+Uses the RMS $PARSE and $SEARCH services to expand the input
+specification to its fully qualified form. (If the file does
+not exist, the input specification is expanded as much as
+possible.) If an error occurs, returns C<undef> and sets C<$!>
+and C<$^E>.
+
=head2 vmsify
Converts a file specification to VMS syntax.
@@ -124,10 +133,9 @@ require 5.002;
require Exporter;
@ISA = qw( Exporter );
-@EXPORT = qw( &vmsify &unixify &pathify &fileify
- &vmspath &unixpath &candelete);
+@EXPORT = qw( &vmsify &unixify &pathify &fileify
+ &vmspath &unixpath &candelete &rmsexpand );
-@EXPORT_OK = qw( &rmsexpand );
1;
@@ -142,7 +150,7 @@ __END__
# should be adequate for most purposes.
# A sort-of sys$parse() replacement
-sub rmsexpand {
+sub rmsexpand ($;$) {
my($fspec,$defaults) = @_;
if (!$fspec) { return undef }
my($node,$dev,$dir,$name,$type,$ver,$dnode,$ddev,$ddir,$dname,$dtype,$dver);
diff --git a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm b/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm
index f87631a32aa..218c406fa44 100644
--- a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm
+++ b/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.pm
@@ -1,8 +1,8 @@
# VMS::Stdio - VMS extensions to Perl's stdio calls
#
# Author: Charles Bailey bailey@genetics.upenn.edu
-# Version: 2.0
-# Revised: 28-Feb-1996
+# Version: 2.02
+# Revised: 15-Feb-1997
package VMS::Stdio;
@@ -12,8 +12,8 @@ use Carp '&croak';
use DynaLoader ();
use Exporter ();
-$VERSION = '2.0';
-@ISA = qw( Exporter DynaLoader FileHandle );
+$VERSION = '2.02';
+@ISA = qw( Exporter DynaLoader IO::File );
@EXPORT = qw( &O_APPEND &O_CREAT &O_EXCL &O_NDELAY &O_NOWAIT
&O_RDONLY &O_RDWR &O_TRUNC &O_WRONLY );
@EXPORT_OK = qw( &flush &getname &remove &rewind &sync &tmpnam
@@ -32,12 +32,13 @@ sub AUTOLOAD {
if ($constname =~ /^O_/) {
my($val) = constant($constname);
defined $val or croak("Unknown VMS::Stdio constant $constname");
- *$AUTOLOAD = sub { $val };
+ *$AUTOLOAD = sub { val; }
}
- else { # We don't know about it; hand off to FileHandle
- require FileHandle;
- my($obj) = shift(@_);
- $obj->FileHandle::$constname(@_);
+ else { # We don't know about it; hand off to IO::File
+ require IO::File;
+
+ *$AUTOLOAD = eval "sub { shift->IO::File::$constname(\@_) }";
+ croak "Error autoloading IO::File::$constname: $@" if $@;
}
goto &$AUTOLOAD;
}
@@ -75,7 +76,7 @@ __END__
=head1 NAME
-VMS::Stdio
+VMS::Stdio - standard I/O functions via VMS extensions
=head1 SYNOPSIS
@@ -98,7 +99,7 @@ remove("another.file");
=head1 DESCRIPTION
-This package gives Perl scripts access to VMS extensions to several
+This package gives Perl scripts access via VMS extensions to several
C stdio operations not available through Perl's CORE I/O functions.
The specific routines are described below. These functions are
prototyped as unary operators, with the exception of C<vmsopen>
@@ -124,12 +125,12 @@ easily choose what you'd like to import:
Of course, you can also choose to import specific functions by
name, as usual.
-This package C<ISA> FileHandle, so that you can call FileHandle
+This package C<ISA> IO::File, so that you can call IO::File
methods on the handles returned by C<vmsopen> and C<vmssysopen>.
-The FileHandle package is not initialized, however, until you
+The IO::File package is not initialized, however, until you
actually call a method that VMS::Stdio doesn't provide. This
is doen to save startup time for users who don't wish to use
-the FileHandle methods.
+the IO::File methods.
B<Note:> In order to conform to naming conventions for Perl
extensions and functions, the name of this package has been
@@ -140,6 +141,8 @@ VMS::Stdio function. This compatibility interface will be
removed in a future release of this extension, so please
update your code to use the new routines.
+=over
+
=item flush
This function causes the contents of stdio buffers for the specified
@@ -152,7 +155,7 @@ returns a true value if successful, and C<undef> if not.
=item getname
The C<getname> function returns the file specification associated
-with a Perl FileHandle. If an error occurs, it returns C<undef>.
+with a Perl I/O handle. If an error occurs, it returns C<undef>.
=item remove
@@ -187,23 +190,23 @@ reason, it is unable to generate a name, it returns C<undef>.
=item vmsopen
The C<vmsopen> function enables you to specify optional RMS arguments
-to the VMS CRTL when opening a file. It is similar to the built-in
+to the VMS CRTL when opening a file. Its operation is similar to the built-in
Perl C<open> function (see L<perlfunc> for a complete description),
-but will only open normal files; it cannot open pipes or duplicate
-existing FileHandles. Up to 8 optional arguments may follow the
+but it will only open normal files; it cannot open pipes or duplicate
+existing I/O handles. Up to 8 optional arguments may follow the
file name. These arguments should be strings which specify
optional file characteristics as allowed by the CRTL. (See the
CRTL reference manual description of creat() and fopen() for details.)
If successful, C<vmsopen> returns a VMS::Stdio file handle; if an
error occurs, it returns C<undef>.
-You can use the file handle returned by C<vmsfopen> just as you
+You can use the file handle returned by C<vmsopen> just as you
would any other Perl file handle. The class VMS::Stdio ISA
-FileHandle, so you can call FileHandle methods using the handle
+IO::File, so you can call IO::File methods using the handle
returned by C<vmsopen>. However, C<use>ing VMS::Stdio does not
-automatically C<use> FileHandle; you must do so explicitly in
-your program if you want to call FileHandle methods. This is
-done to avoid the overhead of initializing the FileHandle package
+automatically C<use> IO::File; you must do so explicitly in
+your program if you want to call IO::File methods. This is
+done to avoid the overhead of initializing the IO::File package
in programs which intend to use the handle returned by C<vmsopen>
as a normal Perl file handle only. When the scalar containing
a VMS::Stdio file handle is overwritten, C<undef>d, or goes
@@ -230,6 +233,6 @@ task by calling the CRTL routine fwait().
=head1 REVISION
-This document was last revised on 28-Jan-1996, for Perl 5.002.
+This document was last revised on 10-Dec-1996, for Perl 5.004.
=cut
diff --git a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs b/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs
index 79eb95335e4..b10fec0d485 100644
--- a/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs
+++ b/gnu/usr.bin/perl/vms/ext/Stdio/Stdio.xs
@@ -1,8 +1,8 @@
/* VMS::Stdio - VMS extensions to stdio routines
*
- * Version: 2.0
+ * Version: 2.02
* Author: Charles Bailey bailey@genetics.upenn.edu
- * Revised: 28-Feb-1996
+ * Revised: 15-Feb-1997
*
*/
@@ -79,8 +79,8 @@ IV *pval;
static SV *
newFH(FILE *fp, char type) {
- SV *rv, *gv = NEWSV(0,0);
- GV **stashp;
+ SV *rv;
+ GV **stashp, *gv = (GV *)NEWSV(0,0);
HV *stash;
IO *io;
@@ -100,9 +100,9 @@ newFH(FILE *fp, char type) {
gv_init(gv,stash,"__FH__",6,0);
io = GvIOp(gv) = newIO();
IoIFP(io) = fp;
- if (type != '>') IoOFP(io) = fp;
+ if (type != '<') IoOFP(io) = fp;
IoTYPE(io) = type;
- rv = newRV(gv);
+ rv = newRV((SV *)gv);
SvREFCNT_dec(gv);
return sv_bless(rv,stash);
}
@@ -127,7 +127,8 @@ flush(sv)
CODE:
FILE *fp = Nullfp;
if (SvOK(sv)) fp = IoIFP(sv_2io(sv));
- ST(0) = fflush(fp) ? &sv_undef : &sv_yes;
+ if (fflush(fp)) { ST(0) = &sv_undef; }
+ else { clearerr(fp); ST(0) = &sv_yes; }
char *
getname(fp)
@@ -157,7 +158,8 @@ sync(fp)
FILE * fp
PROTOTYPE: $
CODE:
- ST(0) = fsync(fileno(fp)) ? &sv_undef : &sv_yes;
+ if (fsync(fileno(fp))) { ST(0) = &sv_undef; }
+ else { clearerr(fp); ST(0) = &sv_yes; }
char *
tmpnam()
@@ -225,7 +227,7 @@ vmsopen(spec,...)
break;
}
if (fp != Nullfp) {
- SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : '>')));
+ SV *fh = newFH(fp,(mode[1] ? '+' : (mode[0] == 'r' ? '<' : (mode[0] == 'a' ? 'a' : '>'))));
ST(0) = (fh ? sv_2mortal(fh) : &sv_undef);
}
else { ST(0) = &sv_undef; }
diff --git a/gnu/usr.bin/perl/vms/ext/Stdio/test.pl b/gnu/usr.bin/perl/vms/ext/Stdio/test.pl
index 12e508aa1f7..0b50d63e3aa 100644
--- a/gnu/usr.bin/perl/vms/ext/Stdio/test.pl
+++ b/gnu/usr.bin/perl/vms/ext/Stdio/test.pl
@@ -1,8 +1,8 @@
-# Tests for VMS::Stdio v2.0
+# Tests for VMS::Stdio v2.01
use VMS::Stdio;
import VMS::Stdio qw(&flush &getname &rewind &sync);
-print "1..13\n";
+print "1..14\n";
print +(defined(&getname) ? '' : 'not '), "ok 1\n";
$name = "test$$";
@@ -16,26 +16,29 @@ print +(sync($fh) ? '' : 'not '),"ok 4\n";
$time = (stat("$name.tmp"))[9];
print +($time ? '' : 'not '), "ok 5\n";
-print 'not ' unless print $fh scalar(localtime($time)),"\n";
+$fh->autoflush; # Can we autoload autoflush from IO::File? Do or die.
print "ok 6\n";
-print +(rewind($fh) ? '' : 'not '),"ok 7\n";
+print 'not ' unless print $fh scalar(localtime($time)),"\n";
+print "ok 7\n";
+
+print +(rewind($fh) ? '' : 'not '),"ok 8\n";
chop($line = <$fh>);
-print +($line eq localtime($time) ? '' : 'not '), "ok 8\n";
+print +($line eq localtime($time) ? '' : 'not '), "ok 9\n";
($gotname) = (getname($fh) =~/\](.*);/);
-print +($gotname eq "\U$name.tmp" ? '' : 'not '), "ok 9\n";
+print +($gotname eq "\U$name.tmp" ? '' : 'not '), "ok 10\n";
$sfh = VMS::Stdio::vmssysopen($name, O_RDONLY, 0,
'ctx=rec', 'shr=put', 'dna=.tmp');
-print +($sfh ? '' : 'not ($!) '), "ok 10\n";
+print +($sfh ? '' : 'not ($!) '), "ok 11\n";
close($fh);
sysread($sfh,$line,24);
-print +($line eq localtime($time) ? '' : 'not '), "ok 11\n";
+print +($line eq localtime($time) ? '' : 'not '), "ok 12\n";
undef $sfh;
-print +(stat("$name.tmp") ? 'not ' : ''),"ok 12\n";
+print +(stat("$name.tmp") ? 'not ' : ''),"ok 13\n";
-print +(&VMS::Stdio::tmpnam ? '' : 'not '),"ok 13\n";
+print +(&VMS::Stdio::tmpnam ? '' : 'not '),"ok 14\n";
diff --git a/gnu/usr.bin/perl/vms/ext/XSSymSet.pm b/gnu/usr.bin/perl/vms/ext/XSSymSet.pm
new file mode 100644
index 00000000000..868a303c01d
--- /dev/null
+++ b/gnu/usr.bin/perl/vms/ext/XSSymSet.pm
@@ -0,0 +1,239 @@
+package ExtUtils::XSSymSet;
+
+use Carp qw( &carp );
+use strict;
+use vars qw( $VERSION );
+$VERSION = '1.0';
+
+
+sub new {
+ my($pkg,$maxlen,$silent) = @_;
+ $maxlen ||= 31;
+ $silent ||= 0;
+ my($obj) = { '__M@xLen' => $maxlen, '__S!lent' => $silent };
+ bless $obj, $pkg;
+}
+
+
+sub trimsym {
+ my($self,$name,$maxlen,$silent) = @_;
+
+ unless (defined $maxlen) {
+ if (ref $self) { $maxlen ||= $self->{'__M@xLen'}; }
+ $maxlen ||= 31;
+ }
+ unless (defined $silent) {
+ if (ref $self) { $silent ||= $self->{'__S!lent'}; }
+ $silent ||= 0;
+ }
+ return $name if (length $name <= $maxlen);
+
+ my $trimmed = $name;
+ # First, just try to remove duplicated delimiters
+ $trimmed =~ s/__/_/g;
+ if (length $trimmed > $maxlen) {
+ # Next, all duplicated chars
+ $trimmed =~ s/(.)\1+/$1/g;
+ if (length $trimmed > $maxlen) {
+ my $squeezed = $trimmed;
+ my($xs,$prefix,$func) = $trimmed =~ /^(XS_)?(.*)_([^_]*)$/;
+ if (length $func <= 12) { # Try to preserve short function names
+ my $frac = int(length $prefix / (length $trimmed - $maxlen) + 0.5);
+ my $pat = '([^_])';
+ if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; }
+ $prefix =~ s/$pat/$1/g;
+ $squeezed = "$xs$prefix" . "_$func";
+ if (length $squeezed > $maxlen) {
+ $pat =~ s/A-Z//;
+ $prefix =~ s/$pat/$1/g;
+ $squeezed = "$xs$prefix" . "_$func";
+ }
+ }
+ else {
+ my $frac = int(length $trimmed / (length $trimmed - $maxlen) + 0.5);
+ my $pat = '([^_])';
+ if ($frac > 1) { $pat .= '[^A-Z_]{' . ($frac - 1) . '}'; }
+ $squeezed = "$prefix$func";
+ $squeezed =~ s/$pat/$1/g;
+ if (length "$xs$squeezed" > $maxlen) {
+ $pat =~ s/A-Z//;
+ $squeezed =~ s/$pat/$1/g;
+ }
+ $squeezed = "$xs$squeezed";
+ }
+ if (length $squeezed <= $maxlen) { $trimmed = $squeezed; }
+ else {
+ my $frac = int((length $trimmed - $maxlen) / length $trimmed + 0.5);
+ my $pat = '(.).{$frac}';
+ $trimmed =~ s/$pat/$1/g;
+ }
+ }
+ }
+ carp "Warning: long symbol $name\n\ttrimmed to $trimmed\n\t" unless $silent;
+ return $trimmed;
+}
+
+
+sub addsym {
+ my($self,$sym,$maxlen,$silent) = @_;
+ my $trimmed = $self->get_trimmed($sym);
+
+ return $trimmed if defined $trimmed;
+
+ $maxlen ||= $self->{'__M@xLen'} || 31;
+ $silent ||= $self->{'__S!lent'} || 0;
+ $trimmed = $self->trimsym($sym,$maxlen,1);
+ if (exists $self->{$trimmed}) {
+ my($i) = "00";
+ $trimmed = $self->trimsym($sym,$maxlen-3,$silent);
+ while (exists $self->{"${trimmed}_$i"}) { $i++; }
+ carp "Warning: duplicate symbol $trimmed\n\tchanged to ${trimmed}_$i\n\t(original was $sym)\n\t"
+ unless $silent;
+ $trimmed .= "_$i";
+ }
+ elsif (not $silent and $trimmed ne $sym) {
+ carp "Warning: long symbol $sym\n\ttrimmed to $trimmed\n\t";
+ }
+ $self->{$trimmed} = $sym;
+ $self->{'__N+Map'}->{$sym} = $trimmed;
+ $trimmed;
+}
+
+
+sub delsym {
+ my($self,$sym) = @_;
+ my $trimmed = $self->{'__N+Map'}->{$sym};
+ if (defined $trimmed) {
+ delete $self->{'__N+Map'}->{$sym};
+ delete $self->{$trimmed};
+ }
+ $trimmed;
+}
+
+
+sub get_trimmed {
+ my($self,$sym) = @_;
+ $self->{'__N+Map'}->{$sym};
+}
+
+
+sub get_orig {
+ my($self,$trimmed) = @_;
+ $self->{$trimmed};
+}
+
+
+sub all_orig { (keys %{$_[0]->{'__N+Map'}}); }
+sub all_trimmed { (grep { /^\w+$/ } keys %{$_[0]}); }
+
+__END__
+
+=head1 NAME
+
+VMS::XSSymSet - keep sets of symbol names palatable to the VMS linker
+
+=head1 SYNOPSIS
+
+ use VMS::XSSymSet;
+
+ $set = new VMS::XSSymSet;
+ while ($sym = make_symbol()) { $set->addsym($sym); }
+ foreach $safesym ($set->all_trimmed) {
+ print "Processing $safesym (derived from ",$self->get_orig($safesym),")\n";
+ do_stuff($safesym);
+ }
+
+ $safesym = VMS::XSSymSet->trimsym($onesym);
+
+=head1 DESCRIPTION
+
+Since the VMS linker distinguishes symbols based only on the first 31
+characters of their names, it is occasionally necessary to shorten
+symbol names in order to avoid collisions. (This is especially true of
+names generated by xsubpp, since prefixes generated by nested package
+names can become quite long.) C<VMS::XSSymSet> provides functions to
+shorten names in a consistent fashion, and to track a set of names to
+insure that each is unique. While designed with F<xsubpp> in mind, it
+may be used with any set of strings.
+
+This package supplies the following functions, all of which should be
+called as methods.
+
+=over 4
+
+=item new([$maxlen[,$silent]])
+
+Creates an empty C<VMS::XSSymset> set of symbols. This function may be
+called as a static method or via an existing object. If C<$maxlen> or
+C<$silent> are specified, they are used as the defaults for maximum
+name length and warning behavior in future calls to addsym() or
+trimsym() via this object.
+
+=item addsym($name[,$maxlen[,$silent]])
+
+Creates a symbol name from C<$name>, using the methods described
+under trimsym(), which is unique in this set of symbols, and returns
+the new name. C<$name> and its resultant are added to the set, and
+any future calls to addsym() specifying the same C<$name> will return
+the same result, regardless of the value of C<$maxlen> specified.
+Unless C<$silent> is true, warnings are output if C<$name> had to be
+trimmed or changed in order to avoid collision with an existing symbol
+name. C<$maxlen> and C<$silent> default to the values specified when
+this set of symbols was created. This method must be called via an
+existing object.
+
+=item trimsym($name[,$maxlen[,$silent]])
+
+Creates a symbol name C<$maxlen> or fewer characters long from
+C<$name> and returns it. If C<$name> is too long, it first tries to
+shorten it by removing duplicate characters, then by periodically
+removing non-underscore characters, and finally, if necessary, by
+periodically removing characters of any type. C<$maxlen> defaults
+to 31. Unless C<$silent> is true, a warning is output if C<$name>
+is altered in any way. This function may be called either as a
+static method or via an existing object, but in the latter case no
+check is made to insure that the resulting name is unique in the
+set of symbols.
+
+=item delsym($name)
+
+Removes C<$name> from the set of symbols, where C<$name> is the
+original symbol name passed previously to addsym(). If C<$name>
+existed in the set of symbols, returns its "trimmed" equivalent,
+otherwise returns C<undef>. This method must be called via an
+existing object.
+
+=item get_orig($trimmed)
+
+Returns the original name which was trimmed to C<$trimmed> by a
+previous call to addsym(), or C<undef> if C<$trimmed> does not
+correspond to a member of this set of symbols. This method must be
+called via an existing object.
+
+=item get_trimmed($name)
+
+Returns the trimmed name which was generated from C<$name> by a
+previous call to addsym(), or C<undef> if C<$name> is not a member
+of this set of symbols. This method must be called via an
+existing object.
+
+=item all_orig()
+
+Returns a list containing all of the original symbol names
+from this set.
+
+=item all_trimmed()
+
+Returns a list containing all of the trimmed symbol names
+from this set.
+
+=back
+
+=head1 AUTHOR
+
+Charles Bailey E<lt>I<bailey@genetics.upenn.edu>E<gt>
+
+=head1 REVISION
+
+Last revised 14-Feb-1997, for Perl 5.004.
+
diff --git a/gnu/usr.bin/perl/vms/ext/filespec.t b/gnu/usr.bin/perl/vms/ext/filespec.t
new file mode 100644
index 00000000000..6201a42dc69
--- /dev/null
+++ b/gnu/usr.bin/perl/vms/ext/filespec.t
@@ -0,0 +1,133 @@
+#!./perl
+
+BEGIN { unshift(@INC,'../lib') if -d '../lib'; }
+
+use VMS::Filespec;
+
+foreach (<DATA>) {
+ chomp;
+ s/\s*#.*//;
+ next if /^\s*$/;
+ push(@tests,$_);
+}
+print '1..',scalar(@tests)+3,"\n";
+
+foreach $test (@tests) {
+ ($arg,$func,$expect) = split(/\t+/,$test);
+ $idx++;
+ $rslt = eval "$func('$arg')";
+ if ($@) { print "not ok $idx : eval error: $@\n"; next; }
+ else {
+ if ($rslt ne $expect) {
+ print "not ok $idx : $func('$arg') expected |$expect|, got |$rslt|\n";
+ }
+ else { print "ok $idx\n"; }
+ }
+}
+
+if (rmsexpand('[]') eq "\U$ENV{DEFAULT}") { print 'ok ',++$idx,"\n"; }
+else {
+ print 'not ok ', ++$idx, ": rmsexpand('[]') = |", rmsexpand('[]'),
+ "|, \$ENV{DEFAULT} = |\U$ENV{DEFAULT}|\n";
+ print "# Note: This failure may have occurred because your default device\n";
+ print "# was set using a non-concealed logical name. If this is the case,\n";
+ print "# you will need to determine by inspection that the two resultant\n";
+ print "# file specifications shwn above are in fact equivalent.\n";
+}
+if (rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here") {
+ print 'ok ', ++$idx, "\n";
+}
+else {
+ print 'not ok ', ++$idx, ": rmsexpand('from.here') = |",
+ rmsexpand('from.here'),
+ "|, \$ENV{DEFAULT}from.here = |\L$ENV{DEFAULT}from.here|\n";
+ print "# Note: This failure may have occurred because your default device\n";
+ print "# was set using a non-concealed logical name. If this is the case,\n";
+ print "# you will need to determine by inspection that the two resultant\n";
+ print "# file specifications shwn above are in fact equivalent.\n";
+}
+if (rmsexpand('from.here','cant:[get.there];2') eq
+ 'cant:[get.there]from.here;2') { print 'ok ',++$idx,"\n"; }
+else {
+ print 'not ok ', ++$idx, ': expected |cant:[get.there]from.here;2|, got |',
+ rmsexpand('from.here','cant:[get.there];2'),"|\n";
+}
+
+__DATA__
+
+# Basic VMS to Unix filespecs
+some:[where.over]the.rainbow unixify /some/where/over/the.rainbow
+[.some.where.over]the.rainbow unixify some/where/over/the.rainbow
+[-.some.where.over]the.rainbow unixify ../some/where/over/the.rainbow
+[.some.--.where.over]the.rainbow unixify some/../../where/over/the.rainbow
+[.some...where.over]the.rainbow unixify some/.../where/over/the.rainbow
+[...some.where.over]the.rainbow unixify .../some/where/over/the.rainbow
+[.some.where.over...]the.rainbow unixify some/where/over/.../the.rainbow
+[.some.where.over...] unixify some/where/over/.../
+[.some.where.over.-] unixify some/where/over/../
+[] unixify ./
+[-] unixify ../
+[--] unixify ../../
+[...] unixify .../
+
+# and back again
+/some/where/over/the.rainbow vmsify some:[where.over]the.rainbow
+some/where/over/the.rainbow vmsify [.some.where.over]the.rainbow
+../some/where/over/the.rainbow vmsify [-.some.where.over]the.rainbow
+some/../../where/over/the.rainbow vmsify [-.where.over]the.rainbow
+.../some/where/over/the.rainbow vmsify [...some.where.over]the.rainbow
+some/.../where/over/the.rainbow vmsify [.some...where.over]the.rainbow
+/some/.../where/over/the.rainbow vmsify some:[...where.over]the.rainbow
+some/where/... vmsify [.some.where...]
+/where/... vmsify where:[...]
+. vmsify []
+.. vmsify [-]
+../.. vmsify [--]
+.../ vmsify [...]
+
+# Fileifying directory specs
+down:[the.garden.path] fileify down:[the.garden]path.dir;1
+[.down.the.garden.path] fileify [.down.the.garden]path.dir;1
+/down/the/garden/path fileify /down/the/garden/path.dir;1
+/down/the/garden/path/ fileify /down/the/garden/path.dir;1
+down/the/garden/path fileify down/the/garden/path.dir;1
+down:[the.garden]path fileify down:[the.garden]path.dir;1
+down:[the.garden]path. fileify # N.B. trailing . ==> null type
+down:[the]garden.path fileify
+/down/the/garden/path. fileify # N.B. trailing . ==> null type
+/down/the/garden.path fileify
+
+# and pathifying them
+down:[the.garden]path.dir;1 pathify down:[the.garden.path]
+[.down.the.garden]path.dir pathify [.down.the.garden.path]
+/down/the/garden/path.dir pathify /down/the/garden/path/
+down/the/garden/path.dir pathify down/the/garden/path/
+down:[the.garden]path pathify down:[the.garden.path]
+down:[the.garden]path. pathify # N.B. trailing . ==> null type
+down:[the]garden.path pathify
+/down/the/garden/path. pathify # N.B. trailing . ==> null type
+/down/the/garden.path pathify
+down:[the.garden]path.dir;2 pathify #N.B. ;2
+path pathify path/
+/down/the/garden/. pathify /down/the/garden/./
+/down/the/garden/.. pathify /down/the/garden/../
+/down/the/garden/... pathify /down/the/garden/.../
+path.notdir pathify
+
+# Both VMS/Unix and file/path conversions
+down:[the.garden]path.dir;1 unixpath /down/the/garden/path/
+/down/the/garden/path vmspath down:[the.garden.path]
+down:[the.garden.path] unixpath /down/the/garden/path/
+down:[the.garden.path...] unixpath /down/the/garden/path/.../
+/down/the/garden/path.dir vmspath down:[the.garden.path]
+[.down.the.garden]path.dir unixpath down/the/garden/path/
+down/the/garden/path vmspath [.down.the.garden.path]
+path vmspath [.path]
+
+# Redundant characters in Unix paths
+//some/where//over/../the.rainbow vmsify some:[where]the.rainbow
+/some/where//over/./the.rainbow vmsify some:[where.over]the.rainbow
+..//../ vmspath [--]
+./././ vmspath []
+./../. vmsify [-]
+
diff --git a/gnu/usr.bin/perl/vms/ext/vmsish.pm b/gnu/usr.bin/perl/vms/ext/vmsish.pm
new file mode 100644
index 00000000000..851d576e792
--- /dev/null
+++ b/gnu/usr.bin/perl/vms/ext/vmsish.pm
@@ -0,0 +1,76 @@
+package vmsish;
+
+=head1 NAME
+
+vmsish - Perl pragma to control VMS-specific language features
+
+=head1 SYNOPSIS
+
+ use vmsish;
+
+ use vmsish 'status'; # or '$?'
+ use vmsish 'exit';
+ use vmsish 'time';
+
+ use vmsish;
+ no vmsish 'time';
+
+=head1 DESCRIPTION
+
+If no import list is supplied, all possible VMS-specific features are
+assumed. Currently, there are three VMS-specific features available:
+'status' (a.k.a '$?'), 'exit', and 'time'.
+
+=over 6
+
+=item C<vmsish status>
+
+This makes C<$?> and C<system> return the native VMS exit status
+instead of emulating the POSIX exit status.
+
+=item C<vmsish exit>
+
+This makes C<exit 1> produce a successful exit (with status SS$_NORMAL),
+instead of emulating UNIX exit(), which considers C<exit 1> to indicate
+an error. As with the CRTL's exit() function, C<exit 0> is also mapped
+to an exit status of SS$_NORMAL, and any other argument to exit() is
+used directly as Perl's exit status.
+
+=item C<vmsish time>
+
+This makes all times relative to the local time zone, instead of the
+default of Universal Time (a.k.a Greenwich Mean Time, or GMT).
+
+=back
+
+See L<perlmod/Pragmatic Modules>.
+
+=cut
+
+if ($^O ne 'VMS') {
+ require Carp;
+ Carp::croak("This isn't VMS");
+}
+
+sub bits {
+ my $bits = 0;
+ my $sememe;
+ foreach $sememe (@_) {
+ $bits |= 0x01000000, next if $sememe eq 'status' || $sememe eq '$?';
+ $bits |= 0x02000000, next if $sememe eq 'exit';
+ $bits |= 0x04000000, next if $sememe eq 'time';
+ }
+ $bits;
+}
+
+sub import {
+ shift;
+ $^H |= bits(@_ ? @_ : qw(status exit time));
+}
+
+sub unimport {
+ shift;
+ $^H &= ~ bits(@_ ? @_ : qw(status exit time));
+}
+
+1;
diff --git a/gnu/usr.bin/perl/vms/ext/vmsish.t b/gnu/usr.bin/perl/vms/ext/vmsish.t
new file mode 100644
index 00000000000..f68b3ac89c0
--- /dev/null
+++ b/gnu/usr.bin/perl/vms/ext/vmsish.t
@@ -0,0 +1,122 @@
+
+BEGIN { unshift @INC, '[-.lib]'; }
+
+my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
+
+print "1..16\n";
+
+#========== vmsish status ==========
+`$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter.
+if ($?) { print "not ok 1 # POSIX status is $?\n"; }
+else { print "ok 1\n"; }
+{
+ use vmsish qw(status);
+ if (not ($? & 1)) { print "not ok 2 # vmsish status is $?\n"; }
+ else { print "ok 2\n"; }
+ {
+ no vmsish '$?'; # check unimport function
+ if ($?) { print "not ok 3 # POSIX status is $?\n"; }
+ else { print "ok 3\n"; }
+ }
+ # and lexical scoping
+ if (not ($? & 1)) { print "not ok 4 # vmsish status is $?\n"; }
+ else { print "ok 4\n"; }
+}
+if ($?) { print "not ok 5 # POSIX status is $?\n"; }
+else { print "ok 5\n"; }
+{
+ use vmsish qw(exit); # check import function
+ if ($?) { print "not ok 6 # POSIX status is $?\n"; }
+ else { print "ok 6\n"; }
+}
+
+#========== vmsish exit ==========
+{
+ use vmsish qw(status);
+ my $msg = `$Invoke_Perl "-I[-.lib]" -e "exit 1"`;
+ if ($msg !~ /ABORT/) {
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ print "not ok 7 # subprocess output: |$msg|\n";
+ }
+ else { print "ok 7\n"; }
+ if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; }
+ else { print "ok 8\n"; }
+
+ $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 1"`;
+ if (length $msg) {
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ print "not ok 9 # subprocess output: |$msg|\n";
+ }
+ else { print "ok 9\n"; }
+ if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; }
+ else { print "ok 10\n"; }
+
+ $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 44"`;
+ if ($msg !~ /ABORT/) {
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ print "not ok 11 # subprocess output: |$msg|\n";
+ }
+ else { print "ok 11\n"; }
+ if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; }
+ else { print "ok 12\n"; }
+}
+
+
+#========== vmsish time ==========
+{
+ my($utctime, @utclocal, @utcgmtime, $utcmtime,
+ $vmstime, @vmslocal, @vmsgmtime, $vmsmtime,
+ $utcval, $vmaval, $offset);
+ # Make sure apparent local time isn't GMT
+ if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) {
+ $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
+ $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600;
+ eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }";
+ gmtime(0); # Force reset of tz offset
+ }
+ {
+ use vmsish qw(time);
+ $vmstime = time;
+ @vmslocal = localtime($vmstime);
+ @vmsgmtime = gmtime($vmstime);
+ $vmsmtime = (stat $0)[9];
+ }
+ $utctime = time;
+ @utclocal = localtime($vmstime);
+ @utcgmtime = gmtime($vmstime);
+ $utcmtime = (stat $0)[9];
+
+ $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
+
+ # We allow lots of leeway (10 sec) difference for these tests,
+ # since it's unlikely local time will differ from UTC by so small
+ # an amount, and it renders the test resistant to delays from
+ # things like stat() on a file mounted over a slow network link.
+ if ($utctime - $vmstime + $offset > 10) {
+ print "not ok 13 # (time) UTC: $utctime VMS: $vmstime\n";
+ }
+ else { print "ok 13\n"; }
+
+ $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
+ $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0];
+ $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
+ $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0];
+ if ($vmsval - $utcval + $offset > 10) {
+ print "not ok 14 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n";
+ }
+ else { print "ok 14\n"; }
+
+ $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
+ $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0];
+ $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
+ $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0];
+ if ($vmsval - $utcval + $offset > 10) {
+ print "not ok 15 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
+ }
+ else { print "ok 15\n"; }
+
+ if ($utcmtime - $vmsmtime + $offset > 10) {
+ print "not ok 16 # (stat) UTC: $utcmtime VMS: $vmsmtime\n";
+ }
+ else { print "ok 16\n"; }
+}
diff --git a/gnu/usr.bin/perl/vms/fndvers.com b/gnu/usr.bin/perl/vms/fndvers.com
index f1ddc03eca9..2e49ae6fcb8 100644
--- a/gnu/usr.bin/perl/vms/fndvers.com
+++ b/gnu/usr.bin/perl/vms/fndvers.com
@@ -58,6 +58,11 @@ $ If .not.teststs Then Exit teststs
$!
$ If teststs.ne.1 ! current values in config.vms are appropriate
$ Then
+$ token = """""""""VMS_''arch' /**/"""""""""
+$ Call update_file "''p2'" "#define ARCHNAME" "''token'"
+$ teststs = $Status
+$ If .not.teststs Then Exit teststs
+$!
$ token = """""""""/perl_root/lib/VMS_''arch'"""""""" /**/"
$ Call update_file "''p2'" "#define OLDARCHLIB_EXP" "''token'"
$ If .not.$Status Then Exit $Status
diff --git a/gnu/usr.bin/perl/vms/gen_shrfls.pl b/gnu/usr.bin/perl/vms/gen_shrfls.pl
index 256cdb51720..e451e1826b6 100644
--- a/gnu/usr.bin/perl/vms/gen_shrfls.pl
+++ b/gnu/usr.bin/perl/vms/gen_shrfls.pl
@@ -34,12 +34,13 @@
# (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)?
#
# Author: Charles Bailey bailey@genetics.upenn.edu
-# Revised: 20-Feb-1996
require 5.000;
$debug = $ENV{'GEN_SHRFLS_DEBUG'};
+print "gen_shrfls.pl Rev. 14-Dec-1996\n" if $debug;
+
if ($ARGV[0] eq '-f') {
open(INP,$ARGV[1]) or die "Can't read input file $ARGV[1]: $!\n";
print "Input taken from file $ARGV[1]\n" if $debug;
@@ -78,7 +79,9 @@ if ($docc) {
$isvaxc = 0;
$isgcc = `$cc_cmd _nla0:/Version` =~ /GNU/
or 0; # make debug output nice
- $isvaxc = (!$isgcc && $isvax && `$cc_cmd /prefix=all _nla0:` =~ /IVQUAL/)
+ $isvaxc = (!$isgcc && $isvax &&
+ # Check exit status too, in case message is shut off
+ (`$cc_cmd /prefix=all _nla0:` =~ /IVQUAL/ || $? == 0x38240))
or 0; # again, make debug output nice
print "\$isgcc: $isgcc\n" if $debug;
print "\$isvaxc: $isvaxc\n" if $debug;
@@ -139,16 +142,31 @@ sub scan_enum {
sub scan_var {
my($line) = @_;
+ my($const) = $line =~ /^EXTCONST/;
print "\tchecking for global variable\n" if $debug > 1;
- $line =~ s/INIT\(.*\)//;
+ $line =~ s/\s*EXT/EXT/;
+ $line =~ s/INIT\s*\(.*\)//;
$line =~ s/\[.*//;
$line =~ s/=.*//;
$line =~ s/\W*;?\s*$//;
print "\tfiltered to \\$line\\\n" if $debug > 1;
if ($line =~ /(\w+)$/) {
- print "\tvar name is \\$1\\\n" if $debug > 1;
- $vars{$1}++;
+ print "\tvar name is \\$1\\" . ($const ? ' (const)' : '') . "\n" if $debug > 1;
+ if ($const) { $cvars{$1}++; }
+ else { $vars{$1}++; }
+ }
+ if ($isvaxc) {
+ my($type) = $line =~ /^\s*EXT\w*\s+(\w+)/;
+ print "\tchecking for use of enum (type is \"$type\")\n" if $debug > 2;
+ if ($type eq 'expectation') {
+ $used_expectation_enum++;
+ print "\tsaw global use of enum \"expectation\"\n" if $debug > 1;
+ }
+ if ($type eq 'opcode') {
+ $used_opcode_enum++;
+ print "\tsaw global use of enum \"opcode\"\n" if $debug > 1;
+ }
}
}
@@ -177,18 +195,18 @@ LINE: while (<CPP>) {
while (/^#.*vmsish\.h/i .. /^#.*perl\.h/i) {
while (/__VMS_PROTOTYPES__/i .. /__VMS_SEPYTOTORP__/i) {
print "vms_proto>> $_" if $debug > 2;
- if (/^EXT/) { &scan_var($_); }
+ if (/^\s*EXT/) { &scan_var($_); }
else { &scan_func($_); }
last LINE unless $_ = <CPP>;
}
print "vmsish.h>> $_" if $debug > 2;
- if (/^EXT/) { &scan_var($_); }
+ if (/^\s*EXT/) { &scan_var($_); }
last LINE unless $_ = <CPP>;
}
while (/^#.*opcode\.h/i .. /^#.*perl\.h/i) {
print "opcode.h>> $_" if $debug > 2;
if (/^OP \*\s/) { &scan_func($_); }
- if (/^EXT/) { &scan_var($_); }
+ if (/^\s*EXT/) { &scan_var($_); }
if (/^\s+OP_/) { &scan_enum($_); }
last LINE unless $_ = <CPP>;
}
@@ -199,33 +217,21 @@ LINE: while (<CPP>) {
}
while (/^#.*proto\.h/i .. /^#.*perl\.h/i) {
print "proto.h>> $_" if $debug > 2;
- if (/^EXT/) { &scan_var($_); }
+ if (/\s*^EXT/) { &scan_var($_); }
else { &scan_func($_); }
last LINE unless $_ = <CPP>;
}
- print $_ if $debug > 3;
- if (($type) = /^EXT\s+(\w+)/) {
- if ($isvaxc) {
- if ($type eq 'expectation') {
- $used_expectation_enum++;
- print "\tsaw global use of enum \"expectation\"\n" if $debug > 1;
- }
- if ($type eq 'opcode') {
- $used_opcode_enum++;
- print "\tsaw global use of enum \"opcode\"\n" if $debug > 1;
- }
- }
- &scan_var($_);
- }
+ print $_ if $debug > 3 && ($debug > 5 || length($_));
+ if (/^\s*EXT/) { &scan_var($_); }
}
close CPP;
# Kluge to determine whether we need to add EMBED prefix to
-# symbols read from local list. init_os_extras() is a VMS-
+# symbols read from local list. vmsreaddirversions() is a VMS-
# specific function whose Perl_ prefix is added in vmsish.h
# if EMBED is #defined.
-$embed = exists($fcns{'Perl_init_os_extras'}) ? 'Perl_' : '';
+$embed = exists($fcns{'Perl_vmsreaddirversions'}) ? 'Perl_' : '';
while (<DATA>) {
next if /^#/;
s/\s+#.*\n//;
@@ -257,6 +263,14 @@ if ($isvaxc) {
print STDERR "Unrecognized enum constant \"$_\" ignored\n";
}
}
+elsif ($isgcc) {
+ # gcc creates this as a SHR,WRT psect in globals.c, but we
+ # don't see it in the perl.h scan, since it's only declared
+ # if DOINIT is #defined. Bleah. It's cheaper to just add
+ # it by hand than to add /Define=DOINIT to the preprocessing
+ # run and wade through all the extra junk.
+ $vars{"${embed}Error"}++;
+}
# Eventually, we'll check against existing copies here, so we can add new
# symbols to an existing options file in an upwardly-compatible manner.
@@ -269,7 +283,11 @@ if ($isvax) {
or die "$0: Can't write to ${dir}perlshr_gbl${marord}.mar: $!\n";
print MAR "\t.title perlshr_gbl$marord\n";
}
-foreach $var (sort keys %vars) {
+unless ($isgcc) {
+ print OPTBLD "PSECT_ATTR=\$GLOBAL_RO_VARS,PIC,NOEXE,RD,NOWRT,SHR\n";
+ print OPTBLD "PSECT_ATTR=\$GLOBAL_RW_VARS,PIC,NOEXE,RD,WRT,NOSHR\n";
+}
+foreach $var (sort (keys %vars,keys %cvars)) {
if ($isvax) { print OPTBLD "UNIVERSAL=$var\n"; }
else { print OPTBLD "SYMBOL_VECTOR=($var=DATA)\n"; }
# This hack brought to you by the lack of a globaldef in gcc.
@@ -304,9 +322,19 @@ if ($isvax) {
open(OPTATTR,">${dir}perlshr_attr.opt")
or die "$0: Can't write to ${dir}perlshr_attr.opt: $!\n";
-print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n";
-foreach $var (sort keys %vars) {
- print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
+if ($isvaxc) {
+ print OPTATTR "PSECT_ATTR=\$CHAR_STRING_CONSTANTS,PIC,SHR,NOEXE,RD,NOWRT\n";
+}
+elsif ($isgcc) {
+ foreach $var (sort keys %cvars) {
+ print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,NOWRT,SHR\n";
+ }
+ foreach $var (sort keys %vars) {
+ print OPTATTR "PSECT_ATTR=${var},PIC,OVR,RD,NOEXE,WRT,NOSHR\n";
+ }
+}
+else {
+ print OPTATTR "! No additional linker directives are needed when using DECC\n";
}
close OPTATTR;
@@ -322,7 +350,7 @@ if ($isvax) {
print DRVR "\$ Set Verify\n";
print DRVR "\$ If F\$Search(\"$libperl\").eqs.\"\" Then Library/Object/Create $libperl\n";
do {
- $incstr .= ",perlshr_gbl$marord";
+ push(@symfiles,"perlshr_gbl$marord");
print DRVR "\$ Macro/NoDebug/Object=PerlShr_Gbl${marord}$objsuffix PerlShr_Gbl$marord.Mar\n";
print DRVR "\$ Library/Object/Replace/Log $libperl PerlShr_Gbl${marord}$objsuffix\n";
} while (--$marord);
@@ -337,6 +365,17 @@ if ($isvax) {
close DRVR;
}
+# Initial hack to permit building of compatible shareable images for a
+# given version of Perl.
+if ($ENV{PERLSHR_USE_GSMATCH}) {
+ my $major = int($] * 1000) & 0xFF; # range 0..255
+ my $minor = int(($] * 1000 - $major) * 100 + 0.5) & 0xFF; # range 0..255
+ print OPTBLD "GSMATCH=LEQUAL,$major,$minor\n";
+ foreach (@symfiles) {
+ print OPTBLD "CLUSTER=\$\$TRANSFER_VECTOR,,,$_.$objsuffix\n";
+ }
+}
+elsif (@symfiles) { $incstr .= ',' . join(',',@symfiles); }
# Include object modules and RTLs in options file
# Linker wants /Include and /Library on different lines
print OPTBLD "$libperl/Include=($incstr)\n";
diff --git a/gnu/usr.bin/perl/vms/genconfig.pl b/gnu/usr.bin/perl/vms/genconfig.pl
index 336c24b8da4..d2e514b1c9e 100644
--- a/gnu/usr.bin/perl/vms/genconfig.pl
+++ b/gnu/usr.bin/perl/vms/genconfig.pl
@@ -6,9 +6,19 @@
# that went into your perl binary. In addition, values which change from run
# to run may be supplied on the command line as key=val pairs.
#
-# Rev. 13-Dec-1995 Charles Bailey bailey@genetics.upenn.edu
+# Rev. 3-Dec-1996 Charles Bailey bailey@genetics.upenn.edu
#
+#==== Locations of installed Perl components
+$prefix='perl_root';
+$builddir="$prefix:[000000]";
+$installbin="$prefix:[000000]";
+$installscript="$prefix:[000000]";
+$installman1dir="$prefix:[man.man1]";
+$installman3dir="$prefix:[man.man3]";
+$installprivlib="$prefix:[lib]";
+$installsitelib="$prefix:[lib.site_perl]";
+
unshift(@INC,'lib'); # In case someone didn't define Perl_Root
# before the build
@@ -37,6 +47,15 @@ open(IN,"$infile") || die "Can't open $infile: $!\n";
open(OUT,">${outdir}Config.sh") || die "Can't open ${outdir}Config.sh: $!\n";
$time = localtime;
+$cf_by = (getpwuid($<))[0];
+$archsufx = `Write Sys\$Output F\$GetSyi("HW_MODEL")` > 1024 ? 'AXP' : 'VAX';
+($vers = $]) =~ tr/./_/;
+$installarchlib = VMS::Filespec::vmspath($installprivlib);
+$installarchlib =~ s#\]#.VMS_$archsufx.$vers\]#;
+$installsitearch = VMS::Filespec::vmspath($installsitelib);
+$installsitearch =~ s#\]#.VMS_$archsufx\]#;
+($osvers = `Write Sys\$Output F\$GetSyi("VERSION")`) =~ s/^V?(\S+)\s*\n?$/$1/;
+
print OUT <<EndOfIntro;
# This file generated by GenConfig.pl on a VMS system.
# Input obtained from:
@@ -47,6 +66,11 @@ print OUT <<EndOfIntro;
package='perl5'
CONFIG='true'
cf_time='$time'
+cf_by='$cf_by'
+ccdlflags=''
+cccdlflags=''
+mab=''
+libpth='/sys\$share /sys\$library'
ld='Link'
lddlflags='/Share'
ranlib=''
@@ -54,31 +78,33 @@ ar=''
eunicefix=':'
hint='none'
hintfile=''
-intsize='4'
-alignbytes='8'
shrplib='define'
usemymalloc='n'
+usevfork='true'
+useposix='false'
spitshell='write sys\$output '
+dlsrc='dl_vms.c'
+binexp='$installbin'
+man1ext='rno'
+man3ext='rno'
+arch='VMS_$archsufx'
+archname='VMS_$archsufx'
+osvers='$osvers'
+prefix='$prefix'
+builddir='$builddir'
+installbin='$installbin'
+installscript='$installscript'
+installman1dir='$installman1dir'
+installman3dir='$installman3dir'
+installprivlib='$installprivlib'
+installarchlib='$installarchlib'
+installsitelib='$installsitelib'
+installsitearch='$installsitearch'
+path_sep='|'
+startperl='\$ perl 'f\$env("procedure")' 'p1' 'p2' 'p3' 'p4' 'p5' 'p6' 'p7' 'p8' !
+\$ exit++ + ++\$status != 0 and \$exit = \$status = undef;'
EndOfIntro
-$cf_by = (getpwuid($<))[0];
-print OUT "cf_by='$cf_by'\n";
-
-$hw_model = `Write Sys\$Output F\$GetSyi("HW_MODEL")`;
-chomp $hw_model;
-if ($hw_model > 1024) {
- print OUT "arch='VMS_AXP'\n";
- print OUT "archname='VMS_AXP'\n";
- $archsufx = "AXP";
-}
-else {
- print OUT "arch='VMS_VAX'\n";
- print OUT "archname='VMS_VAX'\n";
- $archsufx = 'VAX';
-}
-$osvers = `Write Sys\$Output F\$GetSyi("VERSION")`;
-$osvers =~ s/^V?(\S+)\s*\n?$/$1/;
-print OUT "osvers='$osvers'\n";
foreach (@ARGV) {
($key,$val) = split('=',$_,2);
if ($key eq 'cc') { # Figure out which C compiler we're using
@@ -95,12 +121,15 @@ foreach (@ARGV) {
$cctype = 'vaxc';
$d_attr = 'undef';
}
- elsif (`$val/NoObject/NoList _nla0:/Version` =~ /GNU/) {
+ elsif (`$val/NoObject/NoList _nla0:/Version` =~ /GNU C version (\S+)/) {
$cctype = 'gcc';
$d_attr = 'define';
+ print OUT "gccversion='$1'\n";
}
elsif ($archsufx eq 'VAX' &&
- `$val/NoObject/NoList /prefix=all _nla0:` =~ /IVQUAL/) {
+ # Check exit status too, in case message is turned off
+ ( `$val/NoObject/NoList /prefix=all _nla0:` =~ /IVQUAL/ ||
+ $? == 0x38240 )) {
$cctype = 'vaxc';
$d_attr = 'undef';
}
@@ -120,9 +149,30 @@ foreach (@ARGV) {
print OUT "ccflags='$ccflags'\n";
$dosock = ($ccflags =~ m!/DEF[^/]+VMS_DO_SOCKETS!i and
$ccflags !~ m!/UND[^/]+VMS_DO_SOCKETS!i);
+ print OUT "d_vms_do_sockets=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "d_socket=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "d_sockpair=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "d_gethent=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "d_select=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "i_niin=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "i_neterrno=",$dosock ? "'define'\n" : "'undef'\n";
+
+ if ($cctype eq 'decc') { $rtlhas = 'define'; }
+ else { $rtlhas = 'undef'; }
+ foreach (qw[ d_stdstdio d_stdio_ptr_lval d_stdio_cnt_lval d_stdiobase
+ d_locconv d_setlocale i_locale d_mbstowcs d_mbtowc
+ d_wcstombs d_wctomb d_mblen d_mktime d_strcoll d_strxfrm ]) {
+ print OUT "$_='$rtlhas'\n";
+ }
next;
}
- print OUT "$key=\'$val\'\n";
+ elsif ($key eq 'exe_ext') {
+ my($nodot) = $val;
+ $nodot =~ s!\.!!;
+ print OUT "so='$nodot'\ndlext='$nodot'\n";
+ }
+ elsif ($key eq 'obj_ext') { print OUT "dlobj='dl_vms$val'\n"; }
+ print OUT "$key='$val'\n";
}
# Are there any other logicals which TCP/IP stacks use for the host name?
@@ -152,6 +202,33 @@ chomp($hwname = `Write Sys\$Output F\$GetSyi("HW_NAME")`);
$hwname = $archsufx if $hwname =~ /IVKEYW/; # *really* old VMS version
print OUT "myuname='VMS $myname $osvers $hwname'\n";
+# Before we read the C header file, find out what config.sh constants are
+# equivalent to the C preprocessor macros
+if (open(SH,"${outdir}config_h.SH")) {
+ while (<SH>) {
+ next unless m%^#(?!if).*\$%;
+ s/^#//; s!(.*?)\s*/\*.*!$1!;
+ my(@words) = split;
+ $words[1] =~ s/\(.*//; # Clip off args from macro
+ # Did we use a shell variable for the preprocessor directive?
+ if ($words[0] =~ m!^\$(\w+)!) { $pp_vars{$words[1]} = $1; }
+ if (@words > 2) { # We may also have a shell var in the value
+ shift @words; # Discard preprocessor directive
+ my($token) = shift @words; # and keep constant name
+ my($word);
+ foreach $word (@words) {
+ next unless $word =~ m!\$(\w+)!;
+ $val_vars{$token} = $1;
+ last;
+ }
+ }
+ }
+ close SH;
+}
+else { warn "Couldn't read ${outdir}config_h.SH: $!\n"; }
+$pp_vars{UNLINK_ALL_VERSIONS} = 'd_unlink_all_versions'; # VMS_specific
+
+# OK, now read the C header file, and retcon statements into config.sh
while (<IN>) { # roll through the comment header in Config.VMS
last if /config-start/;
}
@@ -165,54 +242,66 @@ while (<IN>) {
s/^\s*//;
$_ = $line . $_;
}
- next unless my ($blocked,$un,$token,$val) = m%^(\/\*)?\s*\#\s*(un)?def\w*\s*([A-za-z0-9]\w+)\S*\s*(.*)%;
- next if /config-skip/;
+ next unless my ($blocked,$un,$token,$val) =
+ m%^(\/\*)?\s*\#\s*(un)?def\w*\s+([A-Za-z0-9]\w+)\S*\s*(.*)%;
+ if (/config-skip/) {
+ delete $pp_vars{$token} if exists $pp_vars{$token};
+ delete $val_vars{$token} if exists $val_vars{$token};
+ next;
+ }
+ $val =~ s!\s*/\*.*!!; # strip off trailing comment
+ my($had_val); # Maybe a macro with args that we just #undefd or commented
+ if (!length($val) and $val_vars{$token} and ($un || $blocked)) {
+ print OUT "$val_vars{$token}=''\n" unless exists $done{$val_vars{$token}};
+ $done{$val_vars{$token}}++;
+ delete $val_vars{$token};
+ $had_val = 1;
+ }
$state = ($blocked || $un) ? 'undef' : 'define';
- $token =~ tr/A-Z/a-z/;
- $token =~ s/_exp$/exp/; # Config.pm has 'privlibexp' etc. where config.h
- # has 'privlib_exp' etc.
- # Fixup differences between Configure vars and config.h manifests
- # This isn't comprehensize; we fix 'em as we need 'em.
- $token = 'castneg' if $token eq 'castnegfloat';
- $token = 'dlsymun' if $token eq 'dlsym_needs_underscore';
- $token = 'stdstdio' if $token eq 'use_stdio_ptr';
- $token = 'stdiobase' if $token eq 'use_stdio_base';
- $val =~ s%/\*.*\*/\s*%%g; $val =~ s/\s*$//; # strip off trailing comment
- $val =~ s/^"//; $val =~ s/"$//; # remove end quotes
- $val =~ s/","/ /g; # make signal list look nice
- if ($val) { print OUT "$token=\'$val\'\n"; }
- else {
+ if ($pp_vars{$token}) {
+ print OUT "$pp_vars{$token}='$state'\n" unless exists $done{$pp_vars{$token}};
+ $done{$pp_vars{$token}}++;
+ delete $pp_vars{$token};
+ }
+ elsif (not length $val and not $had_val) {
+ # Wups -- should have been shell var for C preprocessor directive
+ warn "Constant $token not found in config_h.SH\n";
+ $token = lc $token;
$token = "d_$token" unless $token =~ /^i_/;
print OUT "$token='$state'\n";
}
+ next unless length $val;
+ $val =~ s/^"//; $val =~ s/"$//; # remove end quotes
+ $val =~ s/","/ /g; # make signal list look nice
+ # Library directory; convert to VMS syntax
+ $val = VMS::Filespec::vmspath($val) if ($token =~ /EXP$/);
+ if ($val_vars{$token}) {
+ print OUT "$val_vars{$token}='$val'\n" unless exists $done{$val_vars{$token}};
+ if ($val_vars{$token} =~ s/exp$//) {
+ print OUT "$val_vars{$token}='$val'\n" unless exists $done{$val_vars{$token}};;
+ }
+ $done{$val_vars{$token}}++;
+ delete $val_vars{$token};
+ }
+ elsif (!$pp_vars{$token}) { # Haven't seen it previously, either
+ warn "Constant $token not found in config_h.SH (val=|$val|)\n";
+ $token = lc $token;
+ print OUT "$token='$val'\n";
+ if ($token =~ s/exp$//) {print OUT "$token='$val'\n";}
+ }
}
close IN;
+# Special case -- preprocessor manifest "VMS" is defined automatically
+# on VMS systems, but is also used erroneously by the Perl build process
+# as the manifest for the obsolete variable $d_eunice.
+print OUT "d_eunice='undef'\n"; delete $pp_vars{VMS};
-while (<DATA>) {
- next if /^\s*#/ or /^\s*$/;
- s/#.*$//; s/\s*$//;
- ($key,$val) = split('=',$_,2);
- print OUT "$key='$val'\n";
- eval "\$$key = '$val'";
+foreach (sort keys %pp_vars) {
+ warn "Didn't see $_ in $infile\n";
+}
+foreach (sort keys %val_vars) {
+ warn "Didn't see $_ in $infile(val)\n";
}
-# Add in some of the architecture-dependent stuff which has to be consistent
-print OUT "d_vms_do_sockets=",$dosock ? "'define'\n" : "'undef'\n";
-print OUT "d_has_sockets=",$dosock ? "'define'\n" : "'undef'\n";
-$archlib = &VMS::Filespec::vmspath($privlib);
-$installarchlib = &VMS::Filespec::vmspath($installprivlib);
-$sitearch = &VMS::Filespec::vmspath($sitelib);
-$archlib =~ s#\]#.VMS_$archsufx\]#;
-$sitearch =~ s#\]#.VMS_$archsufx\]#;
-print OUT "oldarchlib='$archlib'\n";
-print OUT "oldarchlibexp='$archlib'\n";
-($vers = $]) =~ tr/./_/;
-$archlib =~ s#\]#.$vers\]#;
-$installarchlib =~ s#\]#.VMS_$archsufx.$vers\]#;
-print OUT "archlib='$archlib'\n";
-print OUT "archlibexp='$archlib'\n";
-print OUT "installarchlib='$installarchlib'\n";
-print OUT "sitearch='$sitearch'\n";
-print OUT "sitearchexp='$sitearch'\n";
if (open(OPT,"${outdir}crtl.opt")) {
while (<OPT>) {
@@ -237,8 +326,8 @@ if (open(PL,"${outdir}patchlevel.h")) {
}
else { warn "Can't read ${outdir}patchlevel.h - skipping 'PATCHLEVEL'"; }
-# simple pager support for perldoc
-if (`most` =~ /IVVERB/) {
+# simple pager support for perldoc
+if (`most not..file` =~ /IVVERB/) {
$pager = 'more';
if (`more nl:` =~ /IVVERB/) { $pager = 'type/page'; }
}
@@ -246,36 +335,3 @@ else { $pager = 'most'; }
print OUT "pager='$pager'\n";
close OUT;
-__END__
-
-# This list is incomplete in comparison to what ends up in config.sh, but
-# should contain the essentials. Some of these definitions reflect
-# options chosen when building perl or site-specific data; these should
-# be hand-edited appropriately. Someday, perhaps, we'll get this automated.
-
-# The definitions in this block are constant across most systems, and
-# should only rarely need to be changed.
-ccdlflags=
-cccdlflags=
-usedl=true
-dlobj=dl_vms.obj
-dlsrc=dl_vms.c
-so=exe
-dlext=exe
-libpth=/sys$share /sys$library
-usevfork=false
-castflags=0
-signal_t=void
-timetype=long
-builddir=perl_root:[000000]
-prefix=perl_root
-installprivlib=perl_root:[lib] # The *lib constants should match the
-privlib=perl_root:[lib] # equivalent *(?:ARCH)LIB_EXP constants
-sitelib=perl_root:[lib.site_perl] # in config.h
-installbin=perl_root:[000000]
-installman1dir=perl_root:[man.man1]
-installman3dir=perl_root:[man.man3]
-man1ext=rno
-man3ext=rno
-binexp=perl_root:[000000] # should be same as installbin
-useposix=false
diff --git a/gnu/usr.bin/perl/vms/genopt.com b/gnu/usr.bin/perl/vms/genopt.com
index 70013aec425..3d3e5fe5df6 100644
--- a/gnu/usr.bin/perl/vms/genopt.com
+++ b/gnu/usr.bin/perl/vms/genopt.com
@@ -9,6 +9,24 @@ $loop:
$ x=f$element(element,p2,p3)
$ if x .eqs. p2 then goto out
$ y=f$edit(x,"COLLAPSE") ! lose spaces
+$! Expand potential name-only args so we find shareable images
+$! either via a logical name or in the default location
+$ if y .nes. "" .and. -
+ f$locate("/SHARE",f$edit(y,"UPCASE")) .ne. f$length(y)
+$ then
+$ name = f$element(0,"/",y)
+$ tail = f$extract(f$length(name),1024,y)
+$ if f$trnlnm(name) .eqs. "" ! If it's a logical name, assume it's OK as is
+$ then
+$ name = f$parse(name,"sys$share:.exe;") ! Look where image activator will
+$ name = f$search(name) ! Does it really exist?
+$ if name .nes. ""
+$ then
+$ name = name - f$parse(name,,,"version") ! Insist on current version
+$ y = name + tail
+$ endif
+$ endif
+$ endif
$ if y .nes. "" then write file y
$ element=element+1
$ goto loop
diff --git a/gnu/usr.bin/perl/vms/myconfig.com b/gnu/usr.bin/perl/vms/myconfig.com
index 7fb728eb62b..6af094357c5 100644
--- a/gnu/usr.bin/perl/vms/myconfig.com
+++ b/gnu/usr.bin/perl/vms/myconfig.com
@@ -299,7 +299,7 @@ $! $spitshell = ECHO !<<!GROK!THIS!
$ ECHO " "
$ ECHO "Summary of my ''$package' (patchlevel ''$PATCHLEVEL' subversion ''$SUBVERSION') configuration:"
$ ECHO " Platform:"
-$ ECHO " osname=''$osname', osver=''$osvers', archname=''$archname'"
+$ ECHO " osname=''$osname', osvers=''$osvers', archname=''$archname'"
$ ECHO " uname=''$myuname'" !->d_has_uname?
$ ECHO " hint=''$hint' d_sigaction='undef'" !->hintfile?
$ ECHO " static exts=''$staticexts'" ! added for VMS
diff --git a/gnu/usr.bin/perl/vms/perlvms.pod b/gnu/usr.bin/perl/vms/perlvms.pod
index a66df9c8df2..c599e5834cd 100644
--- a/gnu/usr.bin/perl/vms/perlvms.pod
+++ b/gnu/usr.bin/perl/vms/perlvms.pod
@@ -58,7 +58,7 @@ define a foreign command to invoke this image.
Perl extensions are packages which provide both XS and Perl code
to add new functionality to perl. (XS is a meta-language which
simplifies writing C code which interacts with Perl, see
-L<perlapi> for more details.) The Perl code for an
+L<perlxs> for more details.) The Perl code for an
extension is treated like any other library module - it's
made available in your script through the appropriate
C<use> or C<require> statement, and usually defines a Perl
@@ -140,13 +140,16 @@ be added to the linker options file F<PGPLOT.Opt> produced
during the build process for the Perl extension.
By default, the shareable image for an extension is placed
-in the F<[.Lib.Auto.>I<Arch>.I<Extname>F<]> directory of the
+F<[.lib.site_perl.auto>I<Arch>.I<Extname>F<]> directory of the
installed Perl directory tree (where I<Arch> is F<VMS_VAX> or
-F<VMS_AXP>, followed by the Perl version number, and I<Extname>
-is the name of the extension, with each C<::> translated to C<.>).
+F<VMS_AXP>, and I<Extname> is the name of the extension, with
+each C<::> translated to C<.>). (See the MakeMaker documentation
+for more details on installation options for extensions.)
However, it can be manually placed in any of several locations:
- - the F<[.Lib.Auto.>I<Extname>F<]> subdirectory of one of
- the directories in C<@INC>, or
+ - the F<[.Lib.Auto.>I<Arch>I<$PVers>I<Extname>F<]> subdirectory
+ of one of the directories in C<@INC> (where I<PVers>
+ is the version of Perl you're using, as supplied in C<$]>,
+ with '.' converted to '_'), or
- one of the directories in C<@INC>, or
- a directory which the extensions Perl library module
passes to the DynaLoader when asking it to map
@@ -165,12 +168,20 @@ We have tried to make Perl aware of both VMS-style and Unix-
style file specifications wherever possible. You may use
either style, or both, on the command line and in scripts,
but you may not combine the two styles within a single fle
-specification. Filenames are, of course, still case-
-insensitive. For consistency, most Perl routines return
-filespecs using lower case letters only, regardless of the
-case used in the arguments passed to them. (This is true
-only when running under VMS; Perl respects the case-
-sensitivity of OSs like Unix.)
+specification. VMS Perl interprets Unix pathnames in much
+the same way as the CRTL (I<e.g.> the first component of
+an absolute path is read as the device name for the
+VMS file specification). There are a set of functions
+provided in the C<VMS::Filespec> package for explicit
+interconversion between VMS and Unix syntax; its
+documentation provides more details.
+
+Filenames are, of course, still case-insensitive. For
+consistency, most Perl routines return filespecs using
+lower case letters only, regardless of the case used in
+the arguments passed to them. (This is true only when
+running under VMS; Perl respects the case-sensitivity
+of OSs like Unix.)
We've tried to minimize the dependence of Perl library
modules on Unix syntax, but you may find that some of these,
@@ -230,6 +241,7 @@ directory specifications may use either VMS or Unix syntax.
Perl for VMS supports redirection of input and output on the
command line, using a subset of Bourne shell syntax:
+
<F<file> reads stdin from F<file>,
>F<file> writes stdout to F<file>,
>>F<file> appends stdout to F<file>,
@@ -253,6 +265,17 @@ to pass uppercase switches to Perl, you need to enclose
them in double-quotes on the command line, since the CRTL
downcases all unquoted strings.
+=over 4
+
+=item -i
+
+If the C<-i> switch is present but no extension for a backup
+copy is given, then inplace editing creates a new version of
+a file; the existing copy is not deleted. (Note that if
+an extension is given, an existing file is renamed to the backup
+file, as is the case under other operating systems, so it does
+not remain as a previous version under the original filename.)
+
=item -S
If the C<-S> switch is present I<and> the script name does
@@ -269,13 +292,15 @@ The C<-u> switch causes the VMS debugger to be invoked
after the Perl program is compiled, but before it has
run. It does not create a core dump file.
+=back
+
=head1 Perl functions
As of the time this document was last revised, the following
Perl functions were implemented in the VMS port of Perl
(functions marked with * are discussed in more detail below):
- file tests*, abs, alarm, atan, binmode*, bless,
+ file tests*, abs, alarm, atan, backticks*, binmode*, bless,
caller, chdir, chmod, chown, chomp, chop, chr,
close, closedir, cos, crypt*, defined, delete,
die, do, dump*, each, endpwent, eof, eval, exec*,
@@ -285,7 +310,7 @@ Perl functions were implemented in the VMS port of Perl
last, lc, lcfirst, length, local, localtime, log, m//,
map, mkdir, my, next, no, oct, open, opendir, ord, pack,
pipe, pop, pos, print, printf, push, q//, qq//, qw//,
- qx//, quotemeta, rand, read, readdir, redo, ref, rename,
+ qx//*, quotemeta, rand, read, readdir, redo, ref, rename,
require, reset, return, reverse, rewinddir, rindex,
rmdir, s///, scalar, seek, seekdir, select(internal),
select (system call)*, setpwent, shift, sin, sleep,
@@ -320,6 +345,7 @@ your copy of Perl:
getsockopt, listen, recv, select(system call)*,
send, setsockopt, shutdown, socket
+=over 4
=item File tests
@@ -349,11 +375,28 @@ only, and then manually check the appropriate bits, as defined by
your C compiler's F<stat.h>, in the mode value it returns, if you
need an approximation of the file's protections.
+=item backticks
+
+Backticks create a subprocess, and pass the enclosed string
+to it for execution as a DCL command. Since the subprocess is
+created directly via C<lib$spawn()>, any valid DCL command string
+may be specified.
+
=item binmode FILEHANDLE
-The C<binmode> operator has no effect under VMS. It will
-return TRUE whenever called, but will not affect I/O
-operations on the filehandle given as its argument.
+The C<binmode> operator will attempt to insure that no translation
+of carriage control occurs on input from or output to this filehandle.
+Since this involves reopening the file and then restoring its
+file position indicator, if this function returns FALSE, the
+underlying filehandle may no longer point to an open file, or may
+point to a different position in the file than before C<binmode>
+was called.
+
+Note that C<binmode> is generally not necessary when using normal
+filehandles; it is provided so that you can control I/O to existing
+record-structured files when necessary. You can also use the
+C<vmsfopen> function in the VMS::Stdio extension to gain finer
+control of I/O to files and devices with different record structures.
=item crypt PLAINTEXT, USER
@@ -465,7 +508,7 @@ true, a warning message is printed, and C<undef> is returned.
In most cases, C<kill> kill is implemented via the CRTL's C<kill()>
function, so it will behave according to that function's
documentation. If you send a SIGKILL, however, the $DELPRC system
-service is is called directly. This insures that the target
+service is called directly. This insures that the target
process is actually deleted, if at all possible. (The CRTL's C<kill()>
function is presently implemented via $FORCEX, which is ignored by
supervisor-mode images like DCL.)
@@ -473,6 +516,10 @@ supervisor-mode images like DCL.)
Also, negative signal values don't do anything special under
VMS; they're just converted to the corresponding positive value.
+=item qx//
+
+See the entry on C<backticks> above.
+
=item select (system call)
If Perl was not built with socket support, the system call
@@ -501,7 +548,18 @@ valid DCL command string may be specified. If LIST consists
of the empty string, C<system> spawns an interactive DCL subprocess,
in the same fashion as typiing B<SPAWN> at the DCL prompt.
Perl waits for the subprocess to complete before continuing
-execution in the current process.
+execution in the current process. As described in L<perlfunc>,
+the return value of C<system> is a fake "status" which follows
+POSIX semantics; see the description of C<$?> in this document
+for more detail. The actual VMS exit status of the subprocess
+is available in C<$^S> (as long as you haven't used another Perl
+function that resets C<$?> and C<$^S> in the meantime).
+
+=item time
+
+The value returned by C<time> is the offset in seconds from
+01-JAN-1970 00:00:00 (just like the CRTL's times() routine), in order
+to make life easier for code coming in from the POSIX/Unix world.
=item times
@@ -572,8 +630,17 @@ and you invoked Perl with the C<-w> switch, a warning will be issued.)
The FLAGS argument is ignored in all cases.
+=back
+
=head1 Perl variables
+The following VMS-specific information applies to the indicated
+"special" Perl variables, in addition to the general information
+in L<perlvar>. Where there is a conflict, this infrmation
+takes precedence.
+
+=over 4
+
=item %ENV
Reading the elements of the %ENV array returns the
@@ -587,7 +654,7 @@ list logical names. For instance, if you say
$ Define STORY once,upon,a,time,there,was
$ perl -e "for ($i = 0; $i <= 6; $i++) " -
- _$ -e "{ print $ENV{'foo'.$i},' '}"
+ _$ -e "{ print $ENV{'story;'.$i},' '}"
Perl will print C<ONCE UPON A TIME THERE WAS>.
@@ -609,20 +676,25 @@ logical name or a name in another logical name table will
replace the logical name just deleted. It is not possible
at present to define a search list logical name via %ENV.
+At present, the first time you iterate over %ENV using
+C<keys>, or C<values>, you will incur a time penalty as all
+logical names are read, in order to fully populate %ENV.
+Subsequent iterations will not reread logical names, so they
+won't be as slow, but they also won't reflect any changes
+to logical name tables caused by other programs. The C<each>
+operator is special: it returns each element I<already> in
+%ENV, but doesn't go out and look for more. Therefore, if
+you've previously used C<keys> or C<values>, you'll see all
+the logical names visible to your process, and if not, you'll
+see only the names you've looked up so far. (This is a
+consequence of the way C<each> is implemented now, and it
+may change in the future, so it wouldn't be a good idea
+to rely on it too much.)
+
In all operations on %ENV, the key string is treated as if it
were entirely uppercase, regardless of the case actually
specified in the Perl expression.
-=item $?
-
-Since VMS status values are 32 bits wide, the value of C<$?>
-is simply the final status value of the last subprocess to
-complete. This differs from the behavior of C<$?> under Unix,
-and under VMS' POSIX environment, in that the low-order 8 bits
-of C<$?> do not specify whether the process terminated normally
-or due to a signal, and you do not need to shift C<$?> 8 bits
-to the right in order to find the process' exit status.
-
=item $!
The string value of C<$!> is that returned by the CRTL's
@@ -644,6 +716,30 @@ is the value of vaxc$errno, and its string value is the
corresponding VMS message string, as retrieved by sys$getmsg().
Setting C<$^E> sets vaxc$errno to the value specified.
+=item $?
+
+The "status value" returned in C<$?> is synthesized from the
+actual exit status of the subprocess in a way that approximates
+POSIX wait(5) semantics, in order to allow Perl programs to
+portably test for successful completion of subprocesses. The
+low order 8 bits of C<$?> are always 0 under VMS, since the
+termination status of a process may or may not have been
+generated by an exception. The next 8 bits are derived from
+severity portion of the subprocess' exit status: if the
+severity was success or informational, these bits are all 0;
+otherwise, they contain the severity value shifted left one bit.
+As a result, C<$?> will always be zero if the subprocess' exit
+status indicated successful completion, and non-zero if a
+warning or error occurred. The actual VMS exit status may
+be found in C<$^S> (q.v.).
+
+=item $^S
+
+Under VMS, this is the 32-bit VMS status value returned by the
+last subprocess to complete. Unlink C<$?>, no manipulation
+is done to make this look like a POSIX wait(5) value, so it
+may be treated as a normal VMS status value.
+
=item $|
Setting C<$|> for an I/O stream causes data to be flushed
@@ -651,6 +747,8 @@ all the way to disk on each write (I<i.e.> not just to
the underlying RMS buffers for a file). In other words,
it's equivalent to calling fflush() and fsync() from C.
+=back
+
=head1 Revision date
This document was last updated on 28-Feb-1996, for Perl 5,
diff --git a/gnu/usr.bin/perl/vms/perly_c.vms b/gnu/usr.bin/perl/vms/perly_c.vms
index 99046823998..ded0cf419c8 100644
--- a/gnu/usr.bin/perl/vms/perly_c.vms
+++ b/gnu/usr.bin/perl/vms/perly_c.vms
@@ -1,4 +1,4 @@
-/* Postprocessed by vms_yfix.pl 1.1 to add VMS declarations of globals */
+/* Postprocessed by vms_yfix.pl 1.11 to add VMS declarations of globals */
#ifndef lint
static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91";
#endif
@@ -13,1094 +13,1044 @@ dep()
deprecate("\"do\" to call subroutines");
}
+#line 16 "perly.c"
#define YYERRCODE 256
dEXT short yylhs[] = { -1,
- 31, 0, 5, 3, 6, 6, 6, 7, 7, 7,
- 7, 21, 21, 21, 21, 21, 21, 11, 11, 11,
- 9, 9, 9, 9, 30, 30, 8, 8, 8, 8,
- 8, 8, 8, 8, 10, 10, 25, 25, 29, 29,
- 1, 1, 1, 1, 2, 2, 32, 32, 28, 28,
- 4, 33, 33, 34, 13, 13, 13, 12, 12, 12,
- 26, 26, 26, 26, 26, 26, 26, 26, 27, 27,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
- 14, 14, 14, 14, 22, 22, 23, 23, 23, 20,
- 15, 16, 17, 18, 19, 24, 24, 24, 24,
+ 45, 0, 9, 7, 10, 8, 11, 11, 11, 12,
+ 12, 12, 12, 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,
};
dEXT short yylen[] = { 2,
- 0, 2, 4, 0, 0, 2, 2, 2, 1, 2,
- 3, 1, 1, 3, 3, 3, 3, 0, 2, 6,
- 6, 6, 4, 4, 0, 2, 7, 7, 5, 5,
- 8, 7, 10, 3, 0, 1, 0, 1, 0, 1,
- 1, 1, 1, 1, 4, 3, 5, 5, 0, 1,
- 0, 3, 2, 5, 3, 3, 1, 2, 3, 1,
- 3, 5, 6, 3, 5, 2, 4, 4, 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, 1, 2,
- 2, 1, 2, 2, 2, 1, 3, 1, 3, 4,
- 4, 6, 1, 1, 0, 1, 0, 1, 2, 2,
- 2, 2, 2, 2, 2, 1, 1, 1, 1,
+ 0, 2, 4, 0, 4, 0, 0, 2, 2, 2,
+ 1, 2, 3, 1, 1, 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,
};
dEXT short yydefred[] = { 1,
- 0, 5, 0, 40, 51, 51, 0, 51, 6, 41,
- 7, 9, 0, 42, 43, 44, 0, 0, 0, 53,
- 0, 12, 4, 143, 0, 0, 118, 0, 138, 0,
- 51, 51, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 7, 0, 44, 55, 53, 0, 53, 8, 45,
+ 9, 11, 0, 46, 47, 48, 0, 0, 0, 62,
+ 63, 14, 4, 156, 0, 0, 129, 0, 151, 0,
+ 54, 54, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 163, 164, 0,
+ 0, 0, 0, 0, 0, 0, 0, 12, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 10, 0, 0,
+ 0, 0, 119, 121, 0, 0, 0, 0, 157, 50,
+ 0, 56, 0, 61, 0, 7, 172, 175, 174, 173,
+ 0, 0, 0, 0, 0, 0, 4, 4, 4, 4,
+ 4, 4, 0, 0, 0, 0, 0, 146, 0, 0,
+ 0, 0, 76, 0, 170, 0, 135, 0, 0, 0,
+ 0, 0, 166, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 109, 0, 167, 168, 169, 171, 0,
+ 0, 33, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 10, 0, 0, 0,
- 0, 0, 0, 0, 0, 8, 0, 0, 0, 0,
- 0, 108, 110, 0, 0, 0, 144, 0, 46, 0,
- 52, 0, 5, 156, 159, 158, 157, 0, 0, 0,
+ 0, 0, 0, 101, 102, 0, 0, 0, 0, 0,
+ 0, 0, 0, 13, 0, 49, 58, 0, 0, 0,
+ 74, 0, 0, 78, 0, 0, 0, 0, 0, 0,
+ 0, 4, 150, 152, 0, 0, 0, 0, 0, 0,
+ 0, 111, 0, 133, 0, 0, 108, 26, 0, 0,
+ 19, 0, 0, 0, 65, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 154, 0, 124,
- 0, 0, 0, 0, 0, 0, 150, 0, 0, 0,
- 0, 66, 0, 133, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 98, 0, 151, 152, 153, 155,
- 0, 34, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 90, 91, 0, 0, 0, 0,
- 0, 0, 0, 0, 11, 45, 50, 0, 0, 0,
- 64, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 36, 0, 137, 139,
- 0, 0, 0, 0, 0, 0, 100, 0, 122, 0,
- 0, 0, 97, 26, 0, 0, 0, 0, 0, 0,
- 55, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 69, 0, 70,
- 0, 0, 0, 0, 0, 0, 0, 120, 0, 48,
- 47, 54, 3, 0, 141, 0, 68, 101, 0, 29,
- 0, 30, 0, 0, 0, 23, 0, 24, 0, 0,
- 0, 140, 149, 67, 0, 125, 0, 127, 0, 99,
- 0, 0, 0, 0, 0, 0, 0, 107, 0, 105,
- 0, 116, 0, 121, 65, 0, 0, 0, 0, 19,
- 0, 0, 0, 0, 0, 62, 126, 128, 115, 0,
- 113, 0, 0, 106, 0, 111, 117, 103, 142, 27,
- 28, 21, 0, 22, 0, 32, 0, 114, 112, 63,
- 0, 0, 31, 0, 0, 20, 33,
+ 0, 80, 0, 0, 81, 0, 0, 0, 0, 0,
+ 0, 0, 131, 0, 0, 60, 59, 52, 0, 3,
+ 0, 154, 0, 0, 112, 0, 41, 0, 42, 0,
+ 0, 0, 0, 165, 0, 0, 35, 40, 0, 0,
+ 0, 153, 162, 77, 0, 136, 0, 138, 0, 110,
+ 0, 0, 0, 0, 0, 140, 0, 0, 0, 118,
+ 0, 116, 0, 127, 0, 132, 0, 75, 0, 79,
+ 0, 0, 0, 0, 0, 0, 0, 0, 72, 137,
+ 139, 126, 0, 124, 0, 0, 141, 117, 0, 122,
+ 128, 114, 64, 155, 6, 0, 0, 0, 0, 0,
+ 0, 0, 0, 125, 123, 73, 7, 27, 28, 0,
+ 0, 23, 24, 0, 31, 0, 0, 0, 21, 0,
+ 0, 0, 30, 5, 0, 29, 0, 0, 32, 0,
+ 22,
};
dEXT short yydgoto[] = { 1,
- 9, 10, 83, 17, 86, 3, 11, 12, 66, 195,
- 266, 67, 202, 69, 70, 71, 72, 73, 74, 75,
- 197, 122, 203, 88, 187, 77, 241, 178, 13, 142,
- 2, 14, 15, 16,
+ 9, 66, 10, 18, 95, 17, 86, 337, 89, 326,
+ 3, 11, 12, 68, 342, 261, 70, 71, 72, 73,
+ 74, 75, 76, 267, 78, 268, 257, 259, 262, 270,
+ 258, 260, 113, 197, 91, 79, 236, 81, 83, 178,
+ 248, 142, 265, 13, 2, 14, 15, 16, 85, 254,
};
dEXT short yysindex[] = { 0,
- 0, 0, -82, 0, 0, 0, -52, 0, 0, 0,
- 0, 0, 853, 0, 0, 0, -80, -256, -19, 0,
- -245, 0, 0, 0, 19, 19, 0, 20, 0, 2177,
- 0, 0, -2, 1, 28, 41, 133, 2177, 27, 33,
- 52, 19, 1028, 2177, 1303, -210, 19, 2177, 965, 1359,
- 2177, 2177, 2177, 2177, 2177, 1415, 0, 2177, 2177, 1478,
- 19, 19, 19, 19, -225, 0, 71, 209, 1535, -49,
- -30, 0, 0, 8, 101, 42, 0, 30, 0, -112,
- 0, 2177, 0, 0, 0, 0, 0, 2177, 127, 2177,
- 1535, 30, -112, 2177, 30, 2177, 30, 2177, 30, 2177,
- 30, 1712, 128, 1535, 139, 1768, 965, 0, 141, 0,
- 1485, -14, 1485, 65, -42, 2177, 0, 71, 0, 71,
- -49, 0, 2177, 0, 1485, 334, 334, 334, -47, -47,
- 92, -26, 334, 334, 0, 63, 0, 0, 0, 0,
- 30, 0, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
- 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
- 2177, 2177, 2177, 2177, 0, 0, -27, 2177, 2177, 2177,
- 2177, 2177, 2177, 1824, 0, 0, 0, -48, 137, -92,
- 0, 2177, 221, 2177, 30, -191, 151, -225, -22, -225,
- -12, -147, 7, -147, 138, 5, 0, 2177, 0, 0,
- 9, -39, 160, 2177, 1887, 2121, 0, 77, 0, 71,
- 2177, 113, 0, 0, 1535, -191, -191, -191, -191, -86,
- 0, -20, 395, 1485, 1566, 461, -88, 1535, 4122, 1064,
- 679, 364, 1120, 728, 334, 334, 2177, 0, 2177, 0,
- 174, 89, 51, 98, 55, 118, 57, 0, 11, 0,
- 0, 0, 0, 175, 0, 2177, 0, 0, 30, 0,
- 30, 0, 30, 30, 178, 0, 30, 0, 2177, 30,
- 15, 0, 0, 0, 22, 0, 25, 0, 29, 0,
- 152, 2177, 94, 2177, 59, 177, 2177, 0, 96, 0,
- 97, 0, 102, 0, 0, 1190, -225, -225, -147, 0,
- 2177, -147, 176, -225, 30, 0, 0, 0, 0, 205,
- 0, 3039, 111, 0, 206, 0, 0, 0, 0, 0,
- 0, 0, 37, 0, 1712, 0, -225, 0, 0, 0,
- 30, 208, 0, -147, 30, 0, 0,
+ 0, 0, -120, 0, 0, 0, -50, 0, 0, 0,
+ 0, 0, 661, 0, 0, 0, -240, -238, -29, 0,
+ 0, 0, 0, 0, -32, -32, 0, -8, 0, 2115,
+ 0, 0, -4, 31, 32, 35, -35, 2115, 56, 57,
+ 61, 1037, 981, -32, 1100, 1364, -218, 0, 0, -32,
+ 2115, 2115, 2115, 2115, 2115, 2115, 1420, 0, 2115, 2115,
+ 1476, -32, -32, -32, -32, 2115, -205, 0, 201, 306,
+ -63, -62, 0, 0, -24, 67, 45, 65, 0, 0,
+ -15, 0, -149, 0, -144, 0, 0, 0, 0, 0,
+ 2115, 80, 2115, 841, -15, -149, 0, 0, 0, 0,
+ 0, 0, 85, 306, 86, 1535, 981, 0, 841, 0,
+ -63, 65, 0, 2115, 0, 88, 0, 841, -28, 4,
+ -51, 2115, 0, 65, 340, 340, 340, -76, -76, 49,
+ -31, 340, 340, 0, -82, 0, 0, 0, 0, 841,
+ -15, 0, 2115, 2115, 2115, 2115, 2115, 2115, 2115, 2115,
+ 2115, 2115, 2115, 2115, 2115, 2115, 2115, 2115, 2115, 2115,
+ 2115, 2115, 2115, 0, 0, 48, 2115, 2115, 2115, 2115,
+ 2115, 2115, 1710, 0, 2115, 0, 0, -43, -116, 241,
+ 0, 2115, 1193, 0, -15, 2115, 2115, 2115, 2115, 106,
+ 1769, 0, 0, 0, -23, 20, 104, 2115, 65, 1825,
+ 1881, 0, 36, 0, 2115, 62, 0, 0, -232, -232,
+ 0, -232, -232, -134, 0, -46, 1131, 841, 689, 316,
+ 859, 306, 3778, 1980, 3652, 1299, 480, 396, 340, 340,
+ 2115, 0, 1944, 2115, 0, 128, -58, 22, -56, 24,
+ 33, 28, 0, -19, 306, 0, 0, 0, 2115, 0,
+ 134, 0, 2115, 2115, 0, -232, 0, 142, 0, 148,
+ -232, 149, 150, 0, 153, 201, 0, 0, 154, 138,
+ 2115, 0, 0, 0, -7, 0, 2, 0, 16, 0,
+ 70, 2115, 73, 2115, 30, 0, 18, 101, 2115, 0,
+ 75, 0, 78, 0, 81, 0, 151, 0, 1247, 0,
+ 90, 90, 90, 90, 2115, 90, 2115, 167, 0, 0,
+ 0, 0, 103, 0, 3869, 84, 0, 0, 170, 0,
+ 0, 0, 0, 0, 0, -205, -205, -207, -207, 176,
+ -205, 168, 90, 0, 0, 0, 0, 0, 0, 90,
+ 192, 0, 0, 90, 0, 1769, -205, 402, 0, 2115,
+ -205, 207, 0, 0, 208, 0, 90, 90, 0, -207,
+ 0,
};
dEXT short yyrindex[] = { 0,
- 0, 0, 297, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 265, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 131, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 2156, -17, 0,
+ 0, 2675, 2720, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 2253, 505, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 2847, 2935,
+ 0, 0, 0, 0, 0, 0, 79, 0, -3, 108,
+ 2774, 2860, 0, 0, 2034, 121, 0, 140, 0, 0,
+ 0, 0, -33, 0, 0, 0, 0, 0, 0, 0,
+ 2203, 0, 0, 3504, 0, 145, 0, 0, 0, 0,
+ 0, 0, 0, 3772, 0, 0, 252, 0, 3551, 541,
+ 602, 2270, 0, 0, 0, 442, 0, 3587, 2774, 0,
+ 0, 2203, 0, 2324, 3010, 3049, 3096, 2911, 2972, 2439,
+ 0, 3147, 3193, 0, 0, 0, 0, 0, 0, 3633,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 107, 0, -35, 10, 53, 3109,
- 3156, 0, 0, 2298, 1976, 0, 0, 0, 0, -23,
- 0, 230, 0, 0, 0, 0, 0, 2385, 0, 0,
- 1004, 0, 168, 253, 0, 0, 0, 0, 0, 0,
- 0, 254, 0, 2242, 0, 0, 274, 0, 2032, 0,
- 3844, 3109, 3902, 0, 0, 2385, 0, 2440, 452, 2554,
- 572, 0, 0, 0, 3981, 3274, 3312, 3421, 3200, 3237,
- 2661, 0, 3560, 3596, 0, 0, 0, 0, 0, 0,
- 0, 0, 2714, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 909,
- 0, 274, 0, 2385, 0, 39, 0, 107, 0, 107,
- 0, 170, 0, 170, 0, 262, 0, 0, 0, 0,
- 0, 288, 0, 0, 0, 0, 0, 0, 0, 2805,
- 0, 2757, 0, 0, 2650, 49, 58, 61, 64, 365,
- 0, 0, -31, 4018, 4028, 3719, 630, 2995, 0, 1623,
- 4106, 4096, 4064, 3756, 3640, 3683, 0, 0, 0, 0,
+ 0, 0, 0, 0, 2522, 0, 0, 0, 0, 925,
+ 0, 252, 0, 0, 0, 263, 0, 0, 0, 0,
+ 223, 0, 0, 0, 0, 282, 0, 0, 2576, 0,
+ 0, 0, 0, 0, 0, 2624, 0, 0, -1, 26,
+ 0, 27, 51, 718, 0, 0, 3752, 1576, 1632, 3368,
+ 3413, 3799, 0, -38, 3710, 3678, 3060, 3459, 3285, 3332,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 3835, 0, 0, 0, 273, 0,
+ 0, 0, 0, 2203, 0, 59, 0, 0, 0, 0,
+ 293, 0, 0, 0, 0, 64, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 277, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 252, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 274, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 107, 107, 170, 0,
- 0, 170, 0, 107, 0, 0, 0, 0, 0, 0,
- 0, 13, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 300, 0, 107, 0, 0, 0,
- 0, 0, 0, 170, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 296, 0, 0, 0,
+ 0, 0, 0, 0, 2380, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 79, 79, 186, 186, 0,
+ 79, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 300, 79, 925, 0, 0,
+ 79, 0, 0, 0, 0, 0, 0, 0, 0, 186,
+ 0,
};
dEXT short yygindex[] = { 0,
- 0, 0, 0, 506, -13, 255, 0, 0, 0, 18,
- -180, 839, -11, 4398, 2162, 0, 0, 0, 0, 0,
- 342, -57, -174, 1032, 90, 0, 0, 267, 0, -172,
- 0, 0, 0, 0,
+ 0, 0, 0, 349, 328, 0, -48, 0, 679, 378,
+ -84, 0, 0, 0, -298, -13, 4075, 2485, 0, 0,
+ 0, 0, 0, 363, 908, 0, 0, 233, -168, 38,
+ 72, 196, -77, -175, 999, 0, 0, 0, 0, 290,
+ 0, -249, 0, 0, 0, 0, 0, 0, 0, 0,
};
-#define YYTABLESIZE 4682
-dEXT short yytable[] = { 65,
- 80, 68, 168, 79, 273, 57, 20, 254, 61, 80,
- 250, 82, 80, 268, 212, 260, 208, 262, 261, 95,
- 97, 99, 101, 57, 179, 206, 80, 80, 263, 110,
- 181, 80, 253, 115, 150, 49, 124, 94, 283, 81,
- 96, 170, 23, 168, 132, 270, 116, 267, 136, 272,
- 13, 294, 141, 83, 61, 305, 83, 57, 209, 90,
- 172, 80, 306, 239, 176, 307, 105, 98, 13, 308,
- 83, 83, 106, 169, 23, 150, 170, 331, 184, 38,
- 100, 188, 186, 190, 189, 192, 191, 194, 193, 16,
- 196, 107, 171, 60, 201, 237, 60, 38, 17, 49,
- 175, 14, 148, 149, 15, 83, 25, 16, 169, 289,
- 60, 60, 315, 291, 143, 293, 17, 313, 322, 14,
- 23, 324, 15, 23, 320, 321, 257, 214, 264, 265,
- 173, 326, 216, 217, 218, 219, 220, 221, 222, 25,
- 174, 23, 25, 25, 25, 60, 25, 177, 25, 25,
- 23, 25, 23, 336, 333, 213, 242, 243, 244, 245,
- 246, 247, 249, 23, 251, 25, 182, 198, 61, 18,
- 25, 258, 102, 4, 5, 6, 78, 7, 8, 199,
- 205, 288, 211, 4, 5, 6, 271, 7, 8, 207,
- 290, 259, 275, 277, 279, 252, 269, 25, 154, 281,
- 274, 280, 18, 282, 19, 18, 18, 18, 149, 18,
- 292, 18, 18, 287, 18, 295, 163, 301, 311, 164,
- 316, 317, 165, 166, 167, 285, 318, 286, 18, 25,
- 238, 25, 25, 18, 325, 329, 57, 57, 57, 57,
- 80, 80, 80, 80, 309, 297, 330, 298, 335, 299,
- 300, 148, 149, 302, 148, 149, 304, 186, 57, 57,
- 18, 255, 80, 80, 256, 167, 80, 148, 149, 314,
- 310, 148, 149, 148, 149, 84, 144, 145, 146, 147,
- 85, 148, 149, 157, 83, 83, 83, 83, 145, 323,
- 49, 327, 18, 37, 18, 18, 2, 328, 148, 149,
- 148, 149, 148, 149, 148, 149, 83, 83, 148, 149,
- 83, 168, 35, 68, 147, 148, 149, 334, 148, 149,
- 13, 337, 148, 149, 60, 60, 60, 60, 148, 39,
- 148, 149, 39, 39, 39, 37, 39, 180, 39, 39,
- 35, 39, 332, 150, 148, 149, 60, 60, 148, 149,
- 148, 149, 148, 149, 76, 39, 148, 149, 303, 185,
- 39, 0, 25, 25, 25, 25, 25, 25, 0, 25,
- 25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
- 25, 25, 148, 149, 0, 25, 25, 39, 25, 25,
- 25, 148, 149, 0, 0, 25, 25, 25, 25, 25,
- 0, 0, 25, 25, 0, 56, 0, 0, 56, 25,
- 0, 148, 149, 25, 0, 25, 25, 0, 0, 39,
- 0, 0, 39, 56, 168, 18, 18, 18, 18, 18,
- 18, 0, 18, 18, 18, 18, 18, 18, 18, 18,
- 18, 18, 18, 18, 18, 148, 149, 0, 18, 18,
- 0, 18, 18, 18, 168, 0, 150, 56, 18, 18,
- 18, 18, 18, 0, 0, 18, 18, 0, 0, 0,
- 148, 149, 18, 0, 0, 0, 18, 0, 18, 18,
- 144, 145, 146, 147, 156, 168, 150, 156, 156, 156,
- 0, 156, 143, 156, 156, 143, 156, 0, 148, 149,
- 0, 151, 148, 149, 0, 152, 153, 154, 155, 143,
- 143, 18, 0, 21, 143, 156, 0, 150, 156, 158,
- 159, 160, 161, 0, 162, 163, 0, 0, 164, 0,
- 0, 165, 166, 167, 0, 0, 92, 93, 0, 0,
- 0, 0, 143, 0, 143, 136, 0, 0, 136, 0,
- 0, 168, 39, 39, 39, 39, 39, 39, 0, 39,
- 39, 39, 136, 136, 0, 39, 0, 136, 39, 39,
- 39, 39, 0, 0, 143, 39, 39, 156, 39, 39,
- 39, 0, 0, 150, 0, 39, 39, 39, 39, 39,
- 0, 0, 39, 39, 0, 136, 0, 136, 0, 39,
- 0, 0, 0, 39, 157, 39, 39, 157, 157, 157,
- 0, 157, 102, 157, 157, 102, 157, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 136, 0, 102,
- 102, 0, 0, 0, 102, 157, 56, 56, 56, 56,
- 0, 164, 0, 0, 165, 166, 167, 0, 152, 153,
- 154, 155, 0, 0, 0, 0, 0, 0, 56, 0,
- 0, 0, 0, 0, 102, 161, 0, 162, 163, 0,
- 74, 164, 0, 74, 165, 166, 167, 0, 0, 152,
- 153, 154, 155, 0, 0, 0, 0, 74, 74, 0,
- 0, 0, 74, 158, 159, 160, 161, 157, 162, 163,
- 0, 0, 164, 0, 0, 165, 166, 167, 156, 156,
- 156, 156, 156, 0, 156, 156, 156, 0, 0, 0,
- 156, 0, 74, 143, 143, 143, 143, 0, 0, 0,
- 0, 156, 143, 156, 156, 156, 143, 143, 143, 143,
- 156, 156, 156, 156, 156, 143, 143, 156, 156, 143,
- 143, 143, 143, 143, 156, 143, 143, 0, 156, 143,
- 156, 156, 143, 143, 143, 163, 0, 0, 164, 168,
- 0, 165, 166, 167, 0, 0, 136, 136, 136, 136,
- 0, 0, 0, 0, 0, 136, 0, 0, 0, 136,
- 136, 136, 136, 0, 0, 0, 0, 0, 136, 136,
- 0, 150, 136, 136, 136, 136, 136, 0, 136, 136,
- 0, 0, 136, 0, 0, 136, 136, 136, 168, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 157, 157,
- 157, 157, 157, 0, 157, 157, 157, 0, 0, 0,
- 157, 0, 0, 102, 102, 102, 102, 0, 0, 0,
- 150, 157, 102, 157, 157, 157, 102, 102, 102, 102,
- 157, 157, 157, 157, 157, 102, 102, 157, 157, 102,
- 102, 102, 102, 102, 157, 102, 102, 0, 157, 102,
- 157, 157, 102, 102, 102, 51, 118, 120, 61, 63,
- 47, 0, 56, 0, 64, 59, 0, 58, 0, 0,
- 0, 74, 74, 74, 74, 0, 0, 0, 0, 0,
- 74, 57, 0, 0, 74, 74, 62, 74, 0, 0,
- 120, 0, 0, 74, 74, 0, 120, 74, 74, 74,
- 74, 74, 0, 74, 0, 0, 0, 0, 0, 0,
- 0, 39, 0, 60, 39, 39, 39, 0, 39, 0,
- 39, 39, 0, 39, 120, 0, 0, 0, 0, 0,
- 0, 210, 0, 152, 153, 154, 155, 39, 0, 0,
- 0, 0, 39, 0, 0, 23, 0, 0, 52, 160,
- 161, 0, 162, 163, 0, 0, 164, 0, 0, 165,
- 166, 167, 0, 0, 0, 0, 0, 51, 0, 39,
- 61, 63, 47, 0, 56, 0, 64, 59, 0, 58,
- 0, 0, 0, 0, 154, 155, 0, 0, 0, 0,
- 0, 0, 120, 0, 0, 0, 0, 0, 62, 0,
- 0, 39, 163, 0, 39, 164, 0, 0, 165, 166,
- 167, 0, 0, 0, 135, 0, 0, 135, 0, 0,
- 0, 0, 0, 0, 0, 60, 0, 89, 0, 0,
- 51, 135, 135, 61, 63, 47, 0, 56, 0, 64,
- 59, 0, 58, 108, 0, 0, 0, 0, 117, 0,
- 123, 0, 0, 0, 0, 0, 0, 23, 0, 0,
- 52, 62, 137, 138, 139, 140, 135, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 22, 24,
- 25, 26, 27, 28, 0, 29, 30, 31, 60, 0,
- 0, 32, 0, 0, 33, 34, 35, 36, 0, 0,
- 0, 37, 38, 0, 39, 40, 41, 0, 204, 0,
- 0, 42, 43, 44, 45, 46, 0, 0, 48, 49,
- 23, 0, 0, 52, 168, 50, 0, 0, 0, 53,
- 0, 54, 55, 0, 39, 39, 39, 39, 39, 39,
- 0, 39, 39, 39, 0, 0, 0, 39, 0, 0,
- 39, 39, 39, 39, 0, 0, 150, 39, 39, 0,
- 39, 39, 39, 0, 0, 0, 0, 39, 39, 39,
- 39, 39, 0, 0, 39, 39, 0, 0, 0, 0,
- 168, 39, 0, 0, 0, 39, 0, 39, 39, 0,
- 0, 119, 25, 26, 27, 28, 85, 29, 30, 31,
- 319, 0, 0, 32, 0, 0, 0, 0, 0, 0,
- 0, 0, 150, 0, 38, 0, 39, 40, 41, 0,
- 0, 0, 157, 42, 43, 44, 45, 46, 0, 0,
- 48, 49, 0, 0, 0, 0, 0, 50, 0, 0,
- 0, 53, 0, 54, 55, 135, 135, 135, 135, 0,
- 168, 0, 0, 0, 109, 25, 26, 27, 28, 0,
- 29, 30, 31, 0, 0, 0, 32, 135, 135, 0,
- 0, 0, 0, 0, 0, 0, 0, 38, 0, 39,
- 40, 41, 150, 0, 0, 0, 42, 43, 44, 45,
- 46, 0, 0, 48, 49, 0, 0, 0, 0, 0,
- 50, 0, 0, 0, 53, 51, 54, 55, 61, 63,
- 47, 0, 56, 0, 64, 59, 0, 58, 152, 153,
- 154, 155, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 114, 0, 159, 160, 161, 62, 162, 163, 0,
- 0, 164, 0, 0, 165, 166, 167, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 51, 0, 60, 61, 63, 47, 0, 56, 0,
- 64, 59, 0, 58, 152, 153, 154, 155, 0, 0,
+#define YYTABLESIZE 4359
+dEXT short yytable[] = { 69,
+ 62, 180, 93, 62, 102, 93, 251, 203, 20, 206,
+ 207, 201, 283, 181, 167, 246, 80, 272, 82, 93,
+ 93, 296, 269, 149, 93, 57, 149, 169, 171, 84,
+ 343, 93, 121, 309, 290, 97, 292, 15, 122, 18,
+ 149, 149, 310, 131, 204, 149, 149, 135, 186, 187,
+ 188, 189, 190, 191, 93, 15, 311, 18, 317, 168,
+ 170, 361, 169, 273, 147, 148, 38, 16, 340, 341,
+ 98, 99, 141, 149, 100, 149, 338, 339, 25, 23,
+ 291, 345, 293, 62, 38, 16, 295, 233, 316, 57,
+ 23, 17, 195, 196, 168, 105, 106, 353, 172, 37,
+ 107, 356, 308, 174, 39, 149, 173, 23, 175, 17,
+ 177, 25, 179, 319, 25, 25, 25, 37, 25, 182,
+ 25, 25, 15, 25, 192, 294, 193, 200, 202, 209,
+ 210, 212, 213, 214, 215, 216, 330, 25, 234, 205,
+ 249, 62, 25, 271, 274, 4, 5, 6, 70, 7,
+ 8, 70, 282, 237, 238, 239, 240, 241, 242, 244,
+ 280, 130, 312, 148, 130, 70, 70, 289, 196, 25,
+ 231, 297, 256, 210, 298, 210, 300, 266, 130, 130,
+ 67, 355, 301, 130, 275, 20, 277, 279, 302, 303,
+ 304, 281, 305, 318, 306, 334, 307, 314, 67, 320,
+ 70, 25, 321, 25, 25, 322, 19, 333, 335, 323,
+ 336, 130, 325, 130, 147, 148, 344, 285, 20, 287,
+ 288, 20, 20, 20, 87, 20, 346, 20, 20, 88,
+ 20, 350, 67, 93, 93, 93, 93, 166, 147, 148,
+ 147, 148, 93, 130, 20, 147, 148, 357, 358, 20,
+ 147, 148, 348, 51, 149, 149, 149, 149, 93, 93,
+ 101, 93, 93, 149, 2, 147, 148, 57, 313, 149,
+ 149, 149, 149, 147, 148, 196, 20, 147, 148, 149,
+ 149, 34, 149, 149, 149, 149, 149, 149, 149, 147,
+ 148, 149, 160, 256, 149, 149, 149, 43, 147, 148,
+ 43, 43, 43, 36, 43, 232, 43, 43, 20, 43,
+ 20, 20, 147, 148, 147, 148, 147, 148, 147, 148,
+ 147, 148, 161, 43, 147, 148, 147, 148, 43, 147,
+ 148, 158, 69, 39, 25, 25, 25, 25, 25, 25,
+ 34, 25, 25, 25, 25, 25, 25, 25, 25, 25,
+ 25, 25, 25, 25, 36, 43, 21, 25, 25, 96,
+ 25, 25, 25, 25, 25, 250, 147, 148, 156, 25,
+ 25, 25, 25, 25, 25, 77, 211, 25, 332, 70,
+ 70, 70, 70, 352, 263, 185, 25, 43, 25, 25,
+ 43, 0, 130, 130, 130, 130, 167, 147, 148, 147,
+ 148, 130, 0, 0, 70, 70, 167, 130, 130, 130,
+ 130, 67, 67, 67, 67, 0, 0, 130, 130, 0,
+ 130, 130, 130, 130, 130, 130, 130, 0, 149, 130,
+ 167, 0, 130, 130, 130, 0, 67, 67, 149, 0,
+ 0, 20, 20, 20, 20, 20, 20, 0, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 20,
+ 20, 0, 149, 0, 20, 20, 0, 20, 20, 20,
+ 20, 20, 143, 144, 145, 146, 20, 20, 20, 20,
+ 20, 20, 156, 0, 20, 156, 167, 0, 0, 0,
+ 0, 0, 0, 20, 0, 20, 20, 147, 148, 156,
+ 156, 0, 0, 0, 156, 0, 4, 5, 6, 0,
+ 7, 8, 0, 0, 0, 0, 0, 0, 149, 0,
+ 43, 43, 43, 43, 43, 43, 354, 43, 43, 43,
+ 0, 0, 156, 43, 156, 0, 43, 43, 43, 43,
+ 0, 0, 0, 43, 43, 0, 43, 43, 43, 43,
+ 43, 0, 0, 0, 0, 43, 43, 43, 43, 43,
+ 43, 0, 0, 43, 156, 0, 0, 0, 0, 0,
+ 167, 0, 43, 172, 43, 43, 172, 172, 172, 0,
+ 172, 156, 172, 172, 156, 172, 150, 0, 0, 0,
+ 0, 0, 151, 152, 153, 154, 0, 0, 156, 156,
+ 0, 0, 149, 156, 172, 155, 157, 158, 159, 160,
+ 161, 162, 0, 0, 163, 0, 0, 164, 165, 166,
+ 0, 162, 0, 0, 163, 0, 0, 164, 165, 166,
+ 0, 156, 0, 156, 173, 0, 0, 173, 173, 173,
+ 0, 173, 113, 173, 173, 113, 173, 0, 163, 0,
+ 0, 164, 165, 166, 0, 0, 0, 0, 0, 113,
+ 113, 0, 0, 156, 113, 173, 172, 4, 5, 6,
+ 0, 7, 8, 0, 0, 0, 0, 0, 0, 327,
+ 328, 329, 0, 331, 153, 154, 0, 0, 0, 0,
+ 0, 67, 0, 52, 113, 0, 62, 64, 50, 0,
+ 57, 162, 65, 60, 163, 59, 0, 164, 165, 166,
+ 347, 0, 0, 156, 156, 156, 156, 349, 0, 58,
+ 108, 351, 156, 117, 63, 0, 0, 173, 156, 156,
+ 156, 156, 0, 0, 359, 360, 0, 0, 156, 156,
+ 0, 156, 156, 156, 156, 156, 156, 156, 0, 0,
+ 156, 61, 0, 156, 156, 156, 0, 0, 66, 176,
+ 0, 66, 0, 0, 0, 0, 151, 152, 153, 154,
+ 0, 0, 0, 184, 0, 0, 66, 0, 0, 167,
+ 0, 0, 0, 23, 161, 162, 53, 0, 163, 0,
+ 0, 164, 165, 166, 0, 0, 0, 172, 172, 172,
+ 172, 172, 0, 172, 172, 172, 0, 0, 0, 172,
+ 66, 149, 156, 156, 156, 156, 0, 0, 0, 208,
+ 172, 156, 172, 172, 172, 172, 172, 156, 156, 156,
+ 156, 172, 172, 172, 172, 172, 172, 156, 156, 172,
+ 156, 156, 156, 156, 156, 156, 156, 0, 172, 156,
+ 172, 172, 156, 156, 156, 0, 247, 0, 173, 173,
+ 173, 173, 173, 255, 173, 173, 173, 0, 0, 0,
+ 173, 0, 0, 113, 113, 113, 113, 0, 0, 0,
+ 0, 173, 113, 173, 173, 173, 173, 173, 113, 113,
+ 113, 113, 173, 173, 173, 173, 173, 173, 113, 113,
+ 173, 113, 113, 113, 113, 113, 113, 113, 0, 173,
+ 113, 173, 173, 113, 113, 113, 22, 24, 25, 26,
+ 27, 28, 0, 29, 30, 31, 0, 0, 0, 32,
+ 0, 167, 33, 34, 35, 36, 0, 0, 0, 37,
+ 38, 0, 39, 40, 41, 42, 43, 0, 0, 167,
+ 112, 44, 45, 46, 47, 48, 49, 43, 124, 51,
+ 43, 43, 43, 149, 43, 0, 43, 43, 54, 43,
+ 55, 56, 0, 0, 0, 151, 0, 153, 154, 0,
+ 0, 149, 0, 43, 0, 0, 0, 0, 43, 66,
+ 66, 66, 66, 161, 162, 0, 0, 163, 112, 0,
+ 164, 165, 166, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 52, 66, 43, 62, 64, 50, 0,
+ 57, 199, 65, 60, 92, 59, 0, 0, 0, 112,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 62, 162, 163, 0, 0, 164, 52, 0,
- 165, 166, 167, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 51, 0, 60,
- 61, 63, 47, 0, 56, 131, 64, 59, 0, 58,
+ 0, 114, 115, 0, 63, 0, 0, 43, 123, 0,
+ 43, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 136, 137, 138, 139, 0, 0, 0, 0, 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,
- 151, 0, 0, 0, 152, 153, 154, 155, 62, 0,
- 0, 23, 0, 0, 52, 0, 0, 156, 158, 159,
- 160, 161, 0, 162, 163, 0, 0, 164, 0, 0,
- 165, 166, 167, 0, 0, 60, 0, 0, 0, 0,
- 51, 0, 0, 61, 63, 47, 0, 56, 0, 64,
- 59, 0, 58, 0, 0, 0, 0, 0, 0, 0,
+ 63, 0, 0, 23, 0, 198, 53, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 52, 62, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 24,
- 25, 26, 27, 28, 0, 29, 30, 31, 60, 0,
- 135, 32, 0, 0, 0, 168, 0, 0, 0, 0,
- 0, 0, 38, 0, 39, 40, 41, 0, 0, 0,
- 0, 42, 43, 44, 45, 46, 0, 157, 48, 49,
- 0, 0, 0, 52, 0, 50, 0, 150, 0, 53,
- 0, 54, 55, 0, 0, 24, 25, 26, 27, 28,
- 0, 29, 30, 31, 0, 168, 0, 32, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 61, 0, 153,
+ 154, 0, 52, 0, 0, 62, 64, 50, 0, 57,
+ 0, 65, 60, 0, 59, 161, 162, 153, 0, 163,
+ 0, 0, 164, 165, 166, 0, 112, 0, 0, 23,
+ 0, 112, 53, 63, 162, 0, 0, 163, 0, 0,
+ 164, 165, 166, 0, 0, 0, 0, 0, 0, 0,
+ 43, 43, 43, 43, 43, 43, 0, 43, 43, 43,
+ 61, 0, 0, 43, 0, 0, 43, 43, 43, 43,
+ 0, 0, 0, 43, 43, 0, 43, 43, 43, 43,
+ 43, 0, 0, 0, 0, 43, 43, 43, 43, 43,
+ 43, 167, 23, 43, 0, 53, 0, 0, 0, 0,
+ 0, 0, 43, 252, 43, 43, 253, 110, 25, 26,
+ 27, 28, 88, 29, 30, 31, 0, 0, 0, 32,
+ 0, 0, 0, 149, 0, 156, 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, 167, 0, 0, 0, 324, 54, 0,
+ 55, 56, 0, 24, 25, 26, 27, 28, 0, 29,
+ 30, 31, 0, 0, 0, 32, 0, 0, 0, 156,
+ 0, 0, 0, 0, 0, 149, 38, 0, 39, 40,
+ 41, 42, 43, 0, 0, 0, 0, 44, 45, 46,
+ 47, 48, 49, 0, 0, 51, 0, 167, 0, 0,
+ 0, 0, 0, 0, 54, 0, 55, 56, 0, 0,
+ 0, 0, 0, 0, 0, 0, 116, 25, 26, 27,
+ 28, 0, 29, 30, 31, 0, 0, 0, 32, 149,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 38,
+ 0, 39, 40, 41, 42, 43, 0, 0, 0, 167,
+ 44, 45, 46, 47, 48, 49, 52, 0, 51, 62,
+ 64, 50, 0, 57, 0, 65, 60, 54, 59, 55,
+ 56, 0, 0, 0, 0, 0, 0, 151, 152, 153,
+ 154, 149, 120, 0, 0, 0, 0, 63, 0, 0,
+ 0, 157, 158, 159, 160, 161, 162, 0, 0, 163,
+ 0, 0, 164, 165, 166, 0, 0, 0, 0, 0,
+ 0, 0, 52, 0, 61, 62, 64, 50, 0, 57,
+ 130, 65, 60, 0, 59, 0, 0, 0, 0, 0,
+ 0, 0, 0, 150, 0, 0, 0, 0, 0, 151,
+ 152, 153, 154, 63, 0, 0, 0, 0, 0, 53,
+ 0, 0, 155, 157, 158, 159, 160, 161, 162, 0,
+ 0, 163, 0, 0, 164, 165, 166, 0, 52, 0,
+ 61, 62, 64, 50, 0, 57, 0, 65, 60, 0,
+ 59, 0, 0, 0, 0, 0, 0, 150, 0, 0,
+ 0, 0, 0, 151, 152, 153, 154, 0, 0, 63,
+ 0, 0, 0, 0, 0, 53, 155, 157, 158, 159,
+ 160, 161, 162, 0, 0, 163, 0, 0, 164, 165,
+ 166, 0, 0, 0, 0, 0, 61, 52, 134, 0,
+ 62, 64, 50, 0, 57, 194, 65, 60, 0, 59,
+ 0, 0, 0, 0, 0, 151, 152, 153, 154, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 63, 0,
+ 0, 53, 160, 161, 162, 0, 0, 163, 0, 0,
+ 164, 165, 166, 0, 0, 0, 87, 0, 0, 87,
+ 24, 25, 26, 27, 28, 61, 29, 30, 31, 0,
+ 0, 0, 32, 87, 87, 0, 0, 0, 87, 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, 87, 0,
+ 0, 54, 88, 55, 56, 88, 24, 25, 26, 27,
+ 28, 0, 29, 30, 31, 0, 0, 0, 32, 88,
+ 88, 0, 0, 0, 88, 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, 88, 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,
+ 243, 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, 87, 87, 87,
+ 87, 0, 0, 0, 0, 0, 87, 52, 0, 61,
+ 62, 64, 50, 87, 57, 276, 65, 60, 0, 59,
+ 0, 0, 87, 87, 0, 87, 87, 87, 87, 87,
+ 0, 0, 0, 0, 0, 0, 0, 0, 63, 0,
+ 0, 0, 0, 0, 53, 0, 0, 0, 0, 0,
+ 0, 0, 0, 88, 88, 88, 88, 0, 0, 0,
+ 0, 0, 88, 52, 0, 61, 62, 64, 50, 0,
+ 57, 278, 65, 60, 0, 59, 0, 0, 88, 88,
+ 0, 88, 88, 88, 88, 88, 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, 286, 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, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 38, 0,
- 39, 40, 41, 0, 0, 0, 0, 42, 43, 44,
- 45, 46, 0, 0, 48, 49, 168, 150, 0, 0,
- 0, 50, 0, 82, 0, 53, 82, 54, 55, 0,
+ 39, 40, 41, 42, 43, 0, 0, 0, 0, 44,
+ 45, 46, 47, 48, 49, 0, 0, 51, 0, 53,
+ 167, 0, 0, 0, 115, 0, 54, 115, 55, 56,
0, 24, 25, 26, 27, 28, 0, 29, 30, 31,
- 82, 82, 0, 32, 0, 82, 0, 0, 150, 0,
- 0, 0, 0, 0, 38, 0, 39, 40, 41, 0,
- 0, 0, 0, 42, 43, 44, 45, 46, 0, 0,
- 48, 49, 0, 0, 0, 82, 0, 50, 0, 0,
- 0, 53, 0, 54, 55, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 24, 25, 26, 27, 28, 0,
- 29, 30, 31, 0, 51, 0, 32, 61, 63, 47,
- 0, 56, 0, 64, 59, 0, 58, 38, 0, 39,
- 40, 41, 0, 0, 0, 0, 42, 43, 44, 45,
- 46, 154, 155, 48, 49, 62, 0, 0, 0, 0,
- 50, 0, 0, 0, 53, 0, 54, 55, 162, 163,
- 0, 0, 164, 0, 0, 165, 166, 167, 0, 0,
- 51, 0, 60, 61, 63, 47, 0, 56, 200, 64,
- 59, 0, 58, 0, 0, 151, 0, 0, 0, 152,
- 153, 154, 155, 0, 0, 0, 0, 0, 0, 0,
- 0, 62, 156, 158, 159, 160, 161, 52, 162, 163,
- 0, 0, 164, 0, 0, 165, 166, 167, 0, 0,
- 152, 0, 154, 155, 0, 0, 51, 0, 60, 61,
- 63, 47, 0, 56, 248, 64, 59, 0, 58, 162,
- 163, 0, 0, 164, 0, 0, 165, 166, 167, 0,
- 0, 0, 0, 0, 0, 0, 0, 62, 0, 0,
- 0, 0, 0, 52, 82, 82, 82, 82, 0, 0,
- 0, 0, 0, 82, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 60, 0, 82, 82, 0, 51,
- 82, 82, 61, 63, 47, 0, 56, 276, 64, 59,
- 0, 58, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 52,
- 62, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 22, 24, 25,
- 26, 27, 28, 0, 29, 30, 31, 60, 0, 0,
- 32, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 38, 0, 39, 40, 41, 0, 0, 0, 0,
- 42, 43, 44, 45, 46, 0, 0, 48, 49, 0,
- 0, 0, 52, 0, 50, 0, 119, 0, 53, 119,
- 54, 55, 0, 0, 24, 25, 26, 27, 28, 0,
- 29, 30, 31, 119, 119, 0, 32, 0, 119, 0,
- 0, 0, 0, 0, 0, 0, 0, 38, 0, 39,
- 40, 41, 0, 0, 0, 0, 42, 43, 44, 45,
- 46, 0, 0, 48, 49, 0, 119, 0, 119, 0,
- 50, 0, 143, 0, 53, 143, 54, 55, 0, 0,
- 24, 25, 26, 27, 28, 0, 29, 30, 31, 143,
- 143, 0, 32, 0, 143, 0, 0, 0, 119, 0,
- 0, 0, 0, 38, 0, 39, 40, 41, 0, 0,
- 0, 0, 42, 43, 44, 45, 46, 0, 0, 48,
- 49, 0, 143, 0, 143, 0, 50, 0, 0, 0,
- 53, 0, 54, 55, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 24, 25, 26, 27, 28, 0, 29,
- 30, 31, 0, 51, 143, 32, 61, 63, 47, 0,
- 56, 278, 64, 59, 0, 58, 38, 0, 39, 40,
- 41, 0, 0, 0, 0, 42, 43, 44, 45, 46,
- 0, 0, 48, 49, 62, 0, 87, 87, 0, 50,
- 0, 0, 0, 53, 0, 54, 55, 0, 103, 0,
- 0, 0, 0, 87, 112, 0, 0, 0, 87, 51,
- 121, 60, 61, 63, 47, 0, 56, 0, 64, 59,
- 0, 58, 87, 87, 87, 87, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 62, 0, 0, 0, 0, 0, 52, 119, 119, 119,
- 119, 0, 0, 0, 0, 0, 119, 0, 0, 0,
- 119, 119, 119, 119, 0, 0, 0, 60, 121, 119,
- 119, 0, 0, 119, 119, 119, 119, 119, 0, 119,
- 119, 0, 130, 119, 0, 130, 119, 119, 119, 0,
- 0, 0, 0, 129, 0, 0, 129, 0, 0, 130,
- 130, 0, 52, 143, 143, 143, 143, 0, 0, 0,
- 129, 129, 143, 0, 0, 129, 143, 143, 143, 143,
- 0, 0, 0, 0, 0, 143, 143, 0, 240, 143,
- 143, 143, 143, 143, 130, 143, 143, 0, 104, 143,
- 0, 104, 143, 143, 143, 129, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 104, 104, 0, 0, 0,
- 104, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 129, 0, 24, 25, 26,
- 27, 28, 0, 29, 30, 31, 0, 0, 104, 32,
- 104, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 38, 0, 39, 40, 41, 0, 0, 0, 0, 42,
- 43, 44, 45, 46, 0, 0, 48, 49, 0, 0,
- 0, 0, 0, 50, 0, 145, 0, 53, 145, 54,
- 55, 0, 0, 24, 25, 26, 27, 28, 0, 29,
- 30, 31, 145, 145, 0, 32, 0, 145, 0, 0,
- 0, 0, 0, 0, 0, 0, 38, 0, 39, 40,
- 41, 0, 0, 0, 0, 42, 43, 44, 45, 46,
- 0, 0, 48, 49, 0, 0, 0, 145, 0, 50,
- 131, 0, 0, 53, 0, 54, 55, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 131, 131, 0,
- 0, 0, 131, 0, 0, 0, 0, 145, 0, 0,
- 0, 0, 0, 130, 130, 130, 130, 0, 0, 0,
- 0, 0, 0, 0, 129, 129, 129, 129, 0, 0,
- 131, 0, 131, 129, 0, 130, 130, 129, 129, 129,
- 129, 0, 0, 0, 0, 0, 129, 129, 0, 0,
- 129, 129, 129, 129, 129, 0, 129, 129, 0, 0,
- 129, 0, 131, 129, 129, 129, 0, 0, 0, 104,
- 104, 104, 104, 0, 0, 0, 0, 0, 104, 0,
- 0, 0, 104, 104, 104, 104, 0, 0, 0, 0,
- 0, 104, 104, 0, 146, 104, 104, 104, 104, 104,
- 0, 104, 104, 0, 0, 104, 0, 0, 104, 104,
- 104, 146, 146, 0, 0, 0, 146, 0, 0, 0,
+ 0, 115, 115, 32, 0, 0, 115, 0, 0, 0,
+ 0, 0, 149, 0, 38, 0, 39, 40, 41, 42,
+ 43, 0, 0, 0, 0, 44, 45, 46, 47, 48,
+ 49, 0, 0, 51, 115, 0, 115, 0, 0, 0,
+ 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, 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, 142, 0, 0, 142,
+ 24, 25, 26, 27, 28, 61, 29, 30, 31, 0,
+ 0, 0, 32, 142, 142, 0, 0, 0, 142, 0,
+ 0, 0, 0, 38, 0, 39, 40, 41, 42, 43,
+ 0, 0, 0, 0, 44, 45, 46, 47, 48, 49,
+ 53, 0, 51, 158, 0, 0, 158, 0, 142, 0,
+ 0, 54, 0, 55, 56, 0, 0, 0, 0, 0,
+ 158, 158, 0, 0, 0, 158, 151, 152, 153, 154,
+ 0, 0, 0, 0, 0, 0, 0, 0, 142, 0,
+ 0, 158, 159, 160, 161, 162, 0, 0, 163, 0,
+ 0, 164, 165, 166, 0, 158, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 115, 115, 115, 115, 0,
+ 159, 0, 0, 0, 115, 0, 0, 0, 0, 0,
+ 115, 115, 115, 115, 0, 158, 0, 159, 159, 0,
+ 115, 115, 159, 115, 115, 115, 115, 115, 115, 115,
+ 0, 0, 115, 0, 0, 115, 115, 115, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 159, 0, 159, 0, 144, 0, 0, 0, 0, 0,
+ 0, 24, 25, 26, 27, 28, 0, 29, 30, 31,
+ 0, 144, 144, 32, 0, 0, 144, 0, 0, 0,
+ 0, 0, 159, 0, 38, 0, 39, 40, 41, 42,
+ 43, 0, 0, 0, 0, 44, 45, 46, 47, 48,
+ 49, 0, 0, 51, 144, 0, 144, 0, 0, 0,
+ 94, 0, 54, 94, 55, 56, 0, 142, 142, 142,
+ 142, 0, 0, 0, 0, 0, 142, 94, 94, 0,
+ 0, 0, 142, 142, 142, 142, 144, 0, 0, 0,
+ 0, 0, 142, 142, 0, 142, 142, 142, 142, 142,
+ 142, 142, 0, 0, 142, 0, 0, 142, 142, 142,
+ 0, 0, 94, 0, 158, 158, 158, 158, 0, 107,
+ 0, 0, 107, 158, 0, 0, 0, 0, 0, 158,
+ 158, 158, 158, 0, 0, 0, 107, 107, 0, 158,
+ 158, 107, 158, 158, 158, 158, 158, 158, 158, 90,
+ 90, 158, 0, 0, 158, 158, 158, 0, 0, 0,
+ 0, 103, 0, 0, 0, 0, 0, 111, 90, 119,
+ 0, 107, 0, 0, 90, 0, 0, 0, 0, 0,
+ 0, 159, 159, 159, 159, 0, 90, 90, 90, 90,
+ 159, 0, 0, 0, 0, 0, 159, 159, 159, 159,
+ 0, 107, 68, 0, 0, 68, 159, 159, 0, 159,
+ 159, 159, 159, 159, 159, 159, 0, 0, 159, 68,
+ 68, 159, 159, 159, 68, 0, 0, 0, 0, 0,
+ 0, 111, 0, 0, 0, 144, 144, 144, 144, 0,
+ 0, 0, 0, 0, 144, 0, 0, 0, 0, 0,
+ 144, 144, 144, 144, 68, 0, 71, 0, 0, 0,
+ 144, 144, 0, 144, 144, 144, 144, 144, 144, 144,
+ 0, 0, 144, 71, 71, 144, 144, 144, 71, 0,
+ 0, 0, 0, 0, 68, 0, 0, 0, 0, 0,
+ 235, 94, 94, 94, 94, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 106, 0, 71, 106, 71, 0,
+ 0, 0, 0, 0, 264, 0, 94, 94, 0, 94,
+ 0, 106, 106, 0, 0, 0, 106, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 71, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 146, 0, 146, 0, 0, 0,
+ 107, 107, 107, 107, 0, 145, 106, 0, 145, 107,
+ 0, 0, 0, 0, 0, 107, 107, 107, 107, 0,
+ 0, 0, 145, 145, 0, 107, 107, 145, 107, 107,
+ 107, 107, 107, 107, 107, 0, 106, 107, 0, 0,
+ 107, 107, 107, 0, 0, 0, 0, 0, 0, 0,
+ 158, 0, 0, 158, 0, 0, 0, 145, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 158, 158, 0,
+ 0, 0, 158, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 68, 68, 68, 68, 0, 0, 0,
+ 0, 0, 68, 0, 0, 0, 0, 0, 68, 68,
+ 68, 68, 158, 0, 113, 0, 0, 113, 68, 68,
+ 0, 68, 68, 68, 68, 68, 68, 68, 0, 0,
+ 68, 113, 113, 68, 68, 68, 113, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 71, 71, 71,
+ 71, 0, 0, 0, 0, 0, 71, 0, 0, 0,
+ 0, 0, 71, 71, 71, 71, 113, 0, 0, 0,
+ 0, 0, 71, 71, 0, 71, 71, 71, 71, 71,
+ 71, 71, 0, 0, 71, 0, 0, 71, 71, 71,
+ 0, 0, 0, 0, 0, 106, 106, 106, 106, 0,
+ 120, 0, 0, 120, 106, 0, 0, 0, 0, 0,
+ 106, 106, 106, 106, 0, 0, 0, 120, 120, 0,
+ 106, 106, 120, 106, 106, 106, 106, 106, 106, 106,
+ 0, 0, 106, 0, 0, 106, 106, 106, 0, 0,
0, 0, 0, 0, 0, 0, 145, 145, 145, 145,
- 0, 0, 0, 0, 0, 145, 0, 0, 0, 145,
- 145, 145, 145, 0, 0, 0, 146, 0, 145, 145,
- 0, 0, 145, 145, 145, 145, 145, 0, 145, 145,
- 59, 0, 145, 59, 0, 145, 145, 145, 0, 0,
- 0, 96, 0, 0, 96, 0, 0, 59, 59, 0,
- 0, 131, 131, 131, 131, 0, 0, 0, 96, 96,
- 131, 0, 0, 96, 131, 131, 131, 131, 0, 0,
- 0, 0, 0, 131, 131, 0, 0, 131, 131, 131,
- 131, 131, 59, 131, 131, 0, 0, 131, 0, 0,
- 131, 131, 131, 96, 58, 0, 0, 58, 0, 0,
+ 0, 103, 120, 0, 103, 145, 0, 0, 0, 0,
+ 0, 145, 145, 145, 145, 0, 0, 0, 103, 103,
+ 0, 145, 145, 103, 145, 145, 145, 145, 145, 145,
+ 145, 0, 0, 145, 0, 0, 145, 145, 145, 0,
+ 0, 158, 158, 158, 158, 0, 0, 0, 0, 0,
+ 158, 0, 0, 103, 0, 0, 158, 158, 158, 158,
+ 0, 0, 104, 0, 0, 104, 158, 158, 0, 158,
+ 158, 158, 158, 158, 158, 158, 0, 0, 158, 104,
+ 104, 158, 158, 158, 104, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 113, 113, 113, 113, 0,
+ 98, 0, 0, 98, 113, 0, 0, 0, 0, 0,
+ 113, 113, 113, 113, 104, 0, 0, 98, 98, 0,
+ 113, 113, 98, 113, 113, 113, 113, 113, 113, 113,
+ 0, 0, 113, 0, 0, 113, 113, 113, 0, 99,
+ 0, 0, 99, 0, 0, 0, 0, 0, 0, 0,
+ 89, 0, 98, 89, 0, 0, 99, 99, 0, 0,
+ 0, 99, 0, 0, 0, 0, 0, 89, 89, 0,
+ 0, 0, 89, 0, 0, 0, 0, 0, 0, 0,
+ 0, 120, 120, 120, 120, 0, 100, 0, 0, 100,
+ 120, 99, 0, 0, 0, 0, 120, 120, 120, 120,
+ 0, 0, 89, 100, 100, 0, 120, 120, 100, 120,
+ 120, 120, 120, 120, 120, 120, 0, 0, 120, 0,
+ 0, 120, 120, 120, 0, 0, 0, 0, 0, 0,
+ 0, 0, 103, 103, 103, 103, 0, 96, 100, 0,
+ 96, 103, 0, 0, 0, 0, 0, 103, 103, 103,
+ 103, 0, 0, 0, 96, 96, 0, 103, 103, 96,
+ 103, 103, 103, 103, 103, 103, 103, 0, 0, 103,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 58, 58, 0, 0, 0, 58, 0, 0, 0,
- 0, 0, 0, 96, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 95, 0, 0,
- 95, 0, 0, 0, 0, 0, 58, 0, 0, 0,
- 0, 0, 0, 0, 95, 95, 0, 0, 0, 95,
- 0, 0, 0, 0, 0, 146, 146, 146, 146, 0,
- 0, 0, 0, 0, 146, 0, 58, 0, 146, 146,
- 146, 146, 0, 0, 0, 61, 0, 146, 146, 95,
- 0, 146, 146, 146, 146, 146, 0, 146, 146, 0,
- 0, 146, 61, 61, 146, 146, 146, 61, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 95,
- 0, 0, 0, 0, 0, 0, 0, 145, 0, 0,
- 145, 0, 0, 0, 0, 61, 0, 61, 0, 0,
- 0, 0, 0, 0, 145, 145, 0, 0, 0, 145,
+ 0, 0, 0, 97, 0, 0, 97, 0, 0, 96,
+ 0, 0, 0, 104, 104, 104, 104, 0, 0, 0,
+ 97, 97, 104, 0, 0, 97, 0, 0, 104, 104,
+ 104, 104, 0, 0, 0, 0, 0, 0, 104, 104,
+ 0, 104, 104, 104, 104, 104, 104, 104, 0, 0,
+ 104, 98, 98, 98, 98, 97, 0, 0, 0, 0,
+ 98, 0, 0, 0, 0, 0, 98, 98, 98, 98,
+ 0, 0, 0, 0, 0, 0, 98, 98, 0, 98,
+ 98, 98, 98, 98, 98, 98, 0, 0, 0, 0,
+ 99, 99, 99, 99, 0, 95, 0, 0, 95, 99,
+ 0, 89, 89, 89, 89, 99, 99, 99, 99, 0,
+ 89, 0, 95, 95, 0, 99, 99, 95, 99, 99,
+ 99, 99, 99, 99, 99, 0, 89, 89, 0, 89,
+ 89, 89, 89, 89, 0, 0, 0, 100, 100, 100,
+ 100, 0, 83, 0, 0, 83, 100, 95, 0, 0,
+ 0, 0, 100, 100, 100, 100, 0, 0, 0, 83,
+ 83, 0, 100, 100, 83, 100, 100, 100, 100, 100,
+ 100, 100, 0, 0, 0, 0, 0, 0, 84, 0,
+ 0, 84, 0, 0, 0, 0, 0, 0, 96, 96,
+ 96, 96, 0, 0, 83, 84, 84, 96, 0, 0,
+ 84, 0, 0, 96, 96, 96, 96, 0, 0, 0,
+ 0, 0, 0, 96, 96, 0, 96, 96, 96, 96,
+ 96, 96, 96, 85, 0, 0, 85, 0, 0, 0,
+ 84, 0, 0, 0, 97, 97, 97, 97, 0, 0,
+ 85, 85, 0, 97, 0, 85, 0, 0, 0, 97,
+ 97, 97, 97, 0, 0, 0, 0, 0, 0, 97,
+ 97, 0, 97, 97, 97, 97, 97, 97, 97, 86,
+ 0, 0, 86, 0, 0, 85, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 86, 86, 0, 0,
+ 0, 86, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 59, 59, 59, 59, 0, 0, 61, 0, 0,
- 0, 0, 96, 96, 96, 96, 0, 0, 0, 145,
- 0, 96, 0, 59, 59, 96, 96, 96, 96, 0,
- 0, 0, 0, 0, 96, 96, 0, 0, 96, 96,
- 96, 96, 96, 0, 96, 96, 0, 0, 96, 0,
- 0, 96, 96, 96, 0, 132, 0, 0, 132, 0,
- 0, 0, 0, 0, 0, 58, 58, 58, 58, 0,
- 0, 0, 132, 132, 58, 0, 0, 132, 58, 58,
- 58, 58, 0, 0, 0, 0, 0, 58, 58, 0,
- 0, 58, 58, 58, 58, 58, 0, 58, 58, 0,
- 0, 58, 0, 0, 58, 58, 58, 132, 95, 95,
- 95, 95, 0, 0, 0, 71, 0, 95, 71, 0,
+ 0, 0, 0, 0, 148, 0, 0, 148, 0, 0,
+ 0, 86, 0, 0, 0, 0, 95, 95, 95, 95,
+ 0, 148, 148, 0, 0, 95, 148, 0, 0, 0,
0, 95, 95, 95, 95, 0, 0, 0, 0, 0,
- 95, 95, 71, 71, 95, 95, 95, 95, 95, 0,
- 95, 95, 0, 0, 95, 0, 0, 95, 95, 95,
- 0, 0, 0, 0, 0, 0, 61, 61, 61, 61,
- 0, 0, 0, 0, 0, 61, 0, 71, 0, 61,
- 61, 61, 61, 0, 0, 0, 0, 0, 61, 61,
- 0, 157, 61, 61, 61, 61, 61, 0, 61, 61,
- 0, 0, 61, 0, 0, 61, 61, 61, 145, 145,
- 145, 145, 0, 0, 0, 0, 0, 145, 0, 168,
- 0, 145, 145, 145, 145, 0, 0, 0, 0, 0,
- 145, 145, 0, 0, 145, 145, 145, 145, 145, 102,
- 145, 145, 102, 0, 145, 0, 0, 145, 145, 145,
- 0, 150, 0, 0, 0, 0, 102, 102, 0, 0,
- 0, 102, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 109, 0, 0, 109,
- 0, 102, 0, 0, 0, 0, 132, 132, 132, 132,
- 0, 0, 0, 109, 109, 132, 0, 0, 109, 132,
- 132, 132, 132, 0, 0, 0, 0, 0, 132, 132,
- 0, 0, 132, 132, 132, 132, 132, 0, 132, 132,
- 92, 0, 132, 92, 0, 132, 132, 132, 109, 0,
- 0, 0, 0, 0, 0, 0, 0, 92, 92, 0,
- 0, 0, 92, 0, 0, 0, 71, 71, 71, 71,
- 0, 0, 0, 0, 0, 0, 0, 93, 0, 0,
- 93, 0, 0, 0, 0, 0, 0, 0, 71, 71,
- 0, 0, 92, 0, 93, 93, 0, 0, 0, 93,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 87, 0, 0, 87, 0, 151,
- 0, 0, 0, 152, 153, 154, 155, 0, 0, 93,
- 0, 87, 87, 0, 0, 0, 87, 158, 159, 160,
- 161, 0, 162, 163, 0, 0, 164, 0, 0, 165,
- 166, 167, 88, 0, 0, 88, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 87, 0, 0, 88,
- 88, 0, 0, 0, 88, 0, 0, 0, 0, 0,
- 102, 102, 102, 102, 0, 0, 0, 0, 0, 102,
- 0, 0, 0, 102, 102, 102, 102, 0, 0, 0,
- 0, 0, 102, 102, 88, 0, 102, 102, 102, 102,
- 102, 0, 102, 102, 0, 0, 102, 0, 0, 102,
- 102, 102, 0, 0, 0, 0, 0, 109, 109, 109,
- 109, 0, 0, 0, 0, 0, 109, 0, 0, 0,
- 109, 109, 109, 109, 0, 0, 0, 0, 0, 109,
- 109, 0, 0, 109, 109, 109, 109, 109, 0, 109,
- 109, 89, 0, 109, 89, 0, 109, 109, 109, 0,
- 0, 92, 92, 92, 92, 0, 0, 0, 89, 89,
- 92, 0, 0, 89, 92, 92, 92, 92, 0, 0,
- 0, 0, 0, 92, 92, 0, 0, 92, 92, 92,
- 92, 92, 0, 92, 92, 0, 0, 92, 93, 93,
- 93, 93, 0, 89, 0, 0, 0, 93, 0, 0,
- 0, 93, 93, 93, 93, 0, 0, 0, 0, 0,
- 93, 93, 0, 0, 93, 93, 93, 93, 93, 0,
- 93, 93, 0, 0, 93, 87, 87, 87, 87, 0,
- 0, 0, 0, 0, 87, 0, 0, 0, 87, 87,
- 87, 87, 0, 0, 0, 0, 0, 87, 87, 0,
- 0, 87, 87, 87, 87, 87, 0, 87, 87, 0,
- 0, 0, 0, 88, 88, 88, 88, 0, 0, 0,
- 0, 0, 88, 0, 0, 0, 88, 88, 88, 88,
- 85, 0, 0, 85, 0, 88, 88, 0, 0, 88,
- 88, 88, 88, 88, 0, 88, 88, 85, 85, 0,
- 0, 0, 85, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 86, 0, 0, 86,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 85, 86, 86, 0, 0, 0, 86, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 84, 0, 0, 84, 0, 0, 0, 0, 86, 0,
- 0, 0, 89, 89, 89, 89, 0, 84, 84, 0,
- 0, 89, 84, 0, 0, 89, 89, 89, 89, 0,
- 0, 0, 0, 0, 89, 89, 0, 0, 89, 89,
- 89, 89, 89, 72, 89, 89, 72, 0, 0, 0,
- 0, 0, 84, 0, 0, 0, 0, 0, 0, 0,
- 72, 72, 0, 0, 0, 72, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 73,
- 0, 0, 73, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 72, 73, 73, 0, 0,
- 0, 73, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 75, 0, 0, 75,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 73, 0, 75, 75, 0, 0, 0, 75, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 85, 85, 85, 85, 0, 0, 0, 0, 0,
- 85, 0, 0, 0, 85, 85, 85, 85, 75, 0,
- 0, 0, 0, 85, 85, 0, 0, 85, 85, 85,
- 85, 85, 0, 85, 85, 0, 0, 86, 86, 86,
- 86, 0, 0, 0, 0, 0, 86, 0, 0, 0,
- 86, 86, 86, 86, 123, 0, 0, 123, 0, 86,
- 86, 0, 0, 86, 86, 86, 86, 86, 0, 86,
- 86, 123, 123, 0, 0, 0, 123, 0, 0, 0,
- 0, 84, 84, 84, 84, 0, 0, 0, 0, 0,
- 84, 0, 0, 0, 84, 84, 84, 84, 0, 0,
- 0, 0, 0, 84, 84, 0, 123, 84, 84, 84,
- 84, 84, 94, 84, 84, 94, 0, 0, 0, 0,
- 0, 0, 0, 0, 72, 72, 72, 72, 0, 94,
- 94, 0, 0, 72, 94, 0, 0, 72, 72, 72,
- 72, 0, 0, 0, 0, 0, 72, 72, 0, 0,
- 72, 72, 72, 72, 72, 0, 72, 72, 0, 0,
- 73, 73, 73, 73, 94, 0, 0, 0, 0, 73,
- 0, 0, 0, 73, 73, 73, 73, 0, 0, 0,
- 0, 0, 73, 73, 0, 0, 73, 73, 73, 73,
- 73, 134, 73, 0, 134, 0, 0, 75, 75, 75,
- 75, 0, 0, 0, 0, 0, 75, 0, 134, 134,
- 75, 75, 0, 134, 0, 0, 0, 0, 0, 75,
- 75, 0, 0, 75, 75, 75, 75, 75, 76, 75,
- 0, 76, 0, 0, 0, 0, 0, 0, 77, 0,
- 0, 77, 0, 134, 0, 76, 76, 0, 0, 0,
- 76, 0, 0, 0, 0, 77, 77, 0, 0, 0,
- 77, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 78, 0, 0, 78, 0, 0,
- 76, 0, 0, 0, 0, 123, 123, 123, 123, 0,
- 77, 78, 78, 0, 123, 0, 78, 0, 123, 123,
- 0, 0, 0, 0, 0, 0, 79, 123, 123, 79,
- 0, 123, 123, 123, 123, 123, 81, 0, 0, 81,
- 0, 0, 0, 79, 79, 0, 78, 0, 79, 0,
- 0, 0, 0, 81, 81, 0, 0, 0, 81, 0,
- 0, 0, 0, 94, 94, 94, 94, 0, 0, 284,
- 0, 0, 94, 0, 157, 0, 94, 94, 79, 0,
- 0, 0, 0, 0, 0, 94, 94, 0, 81, 94,
- 94, 94, 94, 94, 0, 0, 0, 0, 0, 0,
- 0, 0, 168, 0, 0, 0, 0, 0, 0, 0,
+ 0, 95, 95, 0, 95, 95, 95, 95, 95, 95,
+ 95, 147, 0, 0, 147, 0, 148, 0, 0, 0,
+ 0, 0, 0, 83, 83, 83, 83, 0, 147, 147,
+ 0, 0, 83, 147, 0, 0, 0, 0, 83, 83,
+ 83, 83, 0, 0, 0, 0, 0, 134, 83, 83,
+ 134, 83, 83, 83, 83, 83, 83, 83, 0, 84,
+ 84, 84, 84, 147, 134, 134, 0, 0, 84, 134,
+ 0, 0, 0, 0, 84, 84, 84, 84, 0, 0,
+ 0, 0, 0, 0, 84, 84, 0, 84, 84, 84,
+ 84, 84, 84, 105, 0, 0, 105, 0, 0, 134,
+ 0, 0, 0, 0, 85, 85, 85, 85, 0, 0,
+ 105, 105, 0, 85, 0, 105, 0, 0, 0, 85,
+ 85, 0, 85, 0, 0, 0, 0, 0, 0, 85,
+ 85, 0, 85, 85, 85, 85, 85, 85, 90, 0,
+ 0, 90, 0, 0, 0, 105, 0, 0, 0, 0,
+ 86, 86, 86, 86, 0, 90, 90, 0, 0, 86,
+ 90, 0, 167, 0, 0, 86, 86, 0, 0, 0,
+ 92, 0, 0, 92, 0, 86, 86, 0, 86, 86,
+ 86, 86, 86, 86, 0, 0, 0, 92, 92, 0,
+ 90, 0, 92, 0, 149, 148, 148, 148, 148, 0,
+ 0, 0, 0, 0, 148, 0, 0, 0, 0, 0,
+ 148, 148, 91, 0, 0, 91, 0, 0, 0, 0,
+ 148, 148, 92, 148, 148, 148, 148, 148, 0, 91,
+ 91, 0, 143, 0, 91, 143, 0, 0, 0, 0,
+ 0, 0, 147, 147, 147, 147, 0, 0, 0, 143,
+ 143, 147, 0, 0, 0, 284, 0, 147, 147, 82,
+ 156, 0, 82, 0, 91, 0, 0, 147, 147, 0,
+ 147, 147, 147, 147, 147, 0, 82, 82, 134, 134,
+ 134, 134, 0, 0, 143, 0, 0, 134, 167, 0,
+ 0, 0, 0, 134, 134, 69, 0, 0, 69, 0,
+ 0, 0, 0, 134, 134, 0, 134, 134, 134, 134,
+ 134, 82, 69, 69, 0, 0, 0, 0, 0, 0,
+ 149, 0, 0, 0, 105, 105, 105, 105, 0, 0,
+ 0, 0, 0, 105, 0, 0, 0, 0, 0, 105,
+ 105, 0, 0, 0, 0, 0, 0, 69, 0, 105,
+ 105, 156, 105, 105, 105, 105, 105, 0, 151, 152,
+ 153, 154, 0, 0, 0, 0, 0, 0, 0, 90,
+ 90, 90, 90, 0, 159, 160, 161, 162, 90, 167,
+ 163, 0, 0, 164, 165, 166, 0, 0, 0, 0,
+ 0, 0, 0, 0, 90, 90, 0, 90, 90, 90,
+ 90, 92, 92, 92, 92, 0, 0, 0, 0, 0,
+ 92, 149, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 92, 92, 0, 92,
+ 92, 92, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 91, 91, 91, 91, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 143, 143, 143, 143, 0, 91, 91,
+ 0, 91, 0, 0, 0, 0, 0, 0, 150, 0,
+ 0, 0, 0, 0, 151, 152, 153, 154, 143, 143,
+ 82, 82, 82, 82, 0, 0, 0, 155, 157, 158,
+ 159, 160, 161, 162, 0, 0, 163, 0, 0, 164,
+ 165, 166, 0, 0, 0, 82, 82, 0, 0, 0,
+ 0, 0, 0, 0, 94, 0, 69, 69, 69, 69,
+ 0, 0, 104, 0, 0, 0, 109, 0, 0, 118,
+ 0, 0, 0, 0, 0, 0, 125, 126, 127, 128,
+ 129, 69, 69, 132, 133, 0, 0, 0, 0, 0,
+ 140, 0, 0, 0, 0, 0, 0, 0, 0, 150,
+ 0, 0, 0, 0, 0, 151, 152, 153, 154, 0,
+ 0, 0, 0, 0, 0, 0, 0, 183, 0, 157,
+ 158, 159, 160, 161, 162, 0, 0, 163, 0, 0,
+ 164, 165, 166, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 150, 0, 0, 0, 0, 0,
- 0, 0, 134, 134, 134, 134, 0, 0, 0, 0,
- 0, 134, 0, 0, 0, 134, 134, 0, 0, 0,
- 0, 0, 0, 0, 134, 134, 0, 0, 134, 134,
- 134, 134, 134, 0, 0, 0, 0, 0, 0, 76,
- 76, 76, 76, 0, 0, 0, 0, 0, 76, 77,
- 77, 77, 77, 76, 0, 0, 0, 0, 77, 0,
- 0, 76, 76, 0, 0, 76, 76, 76, 76, 76,
- 0, 77, 77, 0, 0, 77, 77, 77, 77, 77,
- 0, 0, 0, 0, 0, 78, 78, 78, 78, 0,
- 0, 0, 0, 0, 78, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 78, 78, 0,
- 0, 78, 78, 78, 78, 78, 0, 79, 79, 79,
- 79, 0, 0, 0, 0, 0, 79, 81, 81, 81,
- 81, 0, 0, 0, 0, 0, 81, 0, 0, 79,
- 79, 0, 0, 79, 79, 79, 79, 0, 0, 81,
- 81, 0, 151, 81, 81, 81, 152, 153, 154, 155,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 156,
- 158, 159, 160, 161, 0, 162, 163, 91, 0, 164,
- 0, 0, 165, 166, 167, 104, 0, 0, 0, 0,
- 111, 113, 0, 0, 0, 0, 0, 125, 126, 127,
- 128, 129, 130, 0, 0, 133, 134, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 183, 0, 0,
+ 0, 0, 0, 0, 217, 218, 219, 220, 221, 222,
+ 223, 224, 225, 226, 227, 228, 229, 230, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 245,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 215, 0, 0, 0, 0, 0, 0, 0, 223, 224,
- 225, 226, 227, 228, 229, 230, 231, 232, 233, 234,
- 235, 236, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 299, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 296, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 312,
+ 0, 0, 0, 0, 0, 0, 0, 0, 315,
};
dEXT short yycheck[] = { 13,
- 257, 13, 91, 17, 44, 41, 59, 182, 36, 41,
- 59, 257, 44, 194, 41, 188, 59, 190, 41, 33,
- 34, 35, 36, 59, 82, 40, 58, 59, 41, 43,
- 88, 63, 125, 45, 123, 59, 50, 40, 59, 59,
- 40, 91, 123, 91, 56, 41, 257, 41, 60, 41,
- 41, 41, 278, 41, 36, 41, 44, 93, 116, 40,
- 91, 93, 41, 91, 78, 41, 40, 40, 59, 41,
- 58, 59, 40, 123, 123, 123, 91, 41, 92, 41,
- 40, 95, 94, 97, 96, 99, 98, 101, 100, 41,
- 102, 40, 123, 41, 106, 123, 44, 59, 41, 123,
- 59, 41, 294, 295, 41, 93, 0, 59, 123, 59,
- 58, 59, 287, 59, 44, 59, 59, 59, 299, 59,
- 123, 302, 59, 123, 297, 298, 184, 141, 276, 277,
- 123, 304, 144, 145, 146, 147, 148, 149, 150, 33,
- 40, 123, 36, 37, 38, 93, 40, 260, 42, 43,
- 123, 45, 123, 334, 327, 93, 168, 169, 170, 171,
- 172, 173, 174, 123, 178, 59, 40, 40, 36, 0,
- 64, 185, 40, 266, 267, 268, 257, 270, 271, 41,
- 40, 93, 91, 266, 267, 268, 198, 270, 271, 125,
- 93, 41, 204, 205, 206, 59, 59, 91, 287, 211,
- 41, 125, 33, 91, 257, 36, 37, 38, 295, 40,
- 93, 42, 43, 40, 45, 41, 305, 40, 125, 308,
- 125, 125, 311, 312, 313, 237, 125, 239, 59, 123,
- 258, 125, 126, 64, 59, 125, 272, 273, 274, 275,
- 272, 273, 274, 275, 93, 259, 41, 261, 41, 263,
- 264, 294, 295, 267, 294, 295, 270, 269, 294, 295,
- 91, 41, 294, 295, 44, 313, 298, 294, 295, 93,
- 282, 294, 295, 294, 295, 257, 272, 273, 274, 275,
- 262, 294, 295, 63, 272, 273, 274, 275, 59, 301,
- 123, 305, 123, 41, 125, 126, 0, 93, 294, 295,
- 294, 295, 294, 295, 294, 295, 294, 295, 294, 295,
- 298, 91, 59, 325, 41, 294, 295, 331, 294, 295,
- 59, 335, 294, 295, 272, 273, 274, 275, 41, 33,
- 294, 295, 36, 37, 38, 59, 40, 83, 42, 43,
- 41, 45, 325, 123, 294, 295, 294, 295, 294, 295,
- 294, 295, 294, 295, 13, 59, 294, 295, 269, 93,
- 64, -1, 256, 257, 258, 259, 260, 261, -1, 263,
- 264, 265, 266, 267, 268, 269, 270, 271, 272, 273,
- 274, 275, 294, 295, -1, 279, 280, 91, 282, 283,
- 284, 294, 295, -1, -1, 289, 290, 291, 292, 293,
- -1, -1, 296, 297, -1, 41, -1, -1, 44, 303,
- -1, 294, 295, 307, -1, 309, 310, -1, -1, 123,
- -1, -1, 126, 59, 91, 256, 257, 258, 259, 260,
- 261, -1, 263, 264, 265, 266, 267, 268, 269, 270,
- 271, 272, 273, 274, 275, 294, 295, -1, 279, 280,
- -1, 282, 283, 284, 91, -1, 123, 93, 289, 290,
- 291, 292, 293, -1, -1, 296, 297, -1, -1, -1,
- 294, 295, 303, -1, -1, -1, 307, -1, 309, 310,
- 272, 273, 274, 275, 33, 91, 123, 36, 37, 38,
- -1, 40, 41, 42, 43, 44, 45, -1, 294, 295,
- -1, 281, 294, 295, -1, 285, 286, 287, 288, 58,
- 59, 6, -1, 8, 63, 64, -1, 123, 298, 299,
- 300, 301, 302, -1, 304, 305, -1, -1, 308, -1,
- -1, 311, 312, 313, -1, -1, 31, 32, -1, -1,
- -1, -1, 91, -1, 93, 41, -1, -1, 44, -1,
- -1, 91, 256, 257, 258, 259, 260, 261, -1, 263,
- 264, 265, 58, 59, -1, 269, -1, 63, 272, 273,
- 274, 275, -1, -1, 123, 279, 280, 126, 282, 283,
- 284, -1, -1, 123, -1, 289, 290, 291, 292, 293,
- -1, -1, 296, 297, -1, 91, -1, 93, -1, 303,
- -1, -1, -1, 307, 33, 309, 310, 36, 37, 38,
- -1, 40, 41, 42, 43, 44, 45, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 123, -1, 58,
- 59, -1, -1, -1, 63, 64, 272, 273, 274, 275,
- -1, 308, -1, -1, 311, 312, 313, -1, 285, 286,
- 287, 288, -1, -1, -1, -1, -1, -1, 294, -1,
- -1, -1, -1, -1, 93, 302, -1, 304, 305, -1,
- 41, 308, -1, 44, 311, 312, 313, -1, -1, 285,
- 286, 287, 288, -1, -1, -1, -1, 58, 59, -1,
- -1, -1, 63, 299, 300, 301, 302, 126, 304, 305,
- -1, -1, 308, -1, -1, 311, 312, 313, 257, 258,
- 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
- 269, -1, 93, 272, 273, 274, 275, -1, -1, -1,
- -1, 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, -1, 307, 308,
- 309, 310, 311, 312, 313, 305, -1, -1, 308, 91,
- -1, 311, 312, 313, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, -1, -1, 281, -1, -1, -1, 285,
- 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
- -1, 123, 298, 299, 300, 301, 302, -1, 304, 305,
- -1, -1, 308, -1, -1, 311, 312, 313, 91, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 257, 258,
- 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
+ 36, 86, 41, 36, 40, 44, 182, 59, 59, 41,
+ 93, 40, 59, 91, 91, 59, 257, 41, 257, 58,
+ 59, 41, 191, 41, 63, 59, 44, 91, 91, 59,
+ 329, 40, 46, 41, 93, 40, 93, 41, 257, 41,
+ 58, 59, 41, 57, 122, 63, 123, 61, 97, 98,
+ 99, 100, 101, 102, 93, 59, 41, 59, 41, 123,
+ 123, 360, 91, 44, 297, 298, 41, 41, 276, 277,
+ 40, 40, 278, 91, 40, 93, 326, 327, 0, 123,
+ 59, 331, 59, 36, 59, 59, 59, 40, 59, 123,
+ 123, 41, 106, 107, 123, 40, 40, 347, 123, 41,
+ 40, 351, 271, 59, 41, 123, 40, 123, 44, 59,
+ 260, 33, 257, 289, 36, 37, 38, 59, 40, 40,
+ 42, 43, 59, 45, 40, 93, 41, 40, 125, 143,
+ 144, 145, 146, 147, 148, 149, 305, 59, 91, 91,
+ 257, 36, 64, 192, 41, 266, 267, 268, 41, 270,
+ 271, 44, 91, 167, 168, 169, 170, 171, 172, 173,
+ 125, 41, 93, 298, 44, 58, 59, 40, 182, 91,
+ 123, 249, 186, 187, 41, 189, 254, 191, 58, 59,
+ 41, 350, 41, 63, 198, 0, 200, 201, 41, 41,
+ 41, 205, 40, 93, 41, 93, 59, 125, 59, 125,
+ 93, 123, 125, 125, 126, 125, 257, 41, 125, 59,
+ 41, 91, 123, 93, 297, 298, 41, 231, 33, 233,
+ 234, 36, 37, 38, 257, 40, 59, 42, 43, 262,
+ 45, 40, 93, 272, 273, 274, 275, 314, 297, 298,
+ 297, 298, 281, 123, 59, 297, 298, 41, 41, 64,
+ 297, 298, 337, 123, 272, 273, 274, 275, 297, 298,
+ 296, 300, 301, 281, 0, 297, 298, 123, 282, 287,
+ 288, 289, 290, 297, 298, 289, 91, 297, 298, 297,
+ 298, 59, 300, 301, 302, 303, 304, 305, 306, 297,
+ 298, 309, 41, 307, 312, 313, 314, 33, 297, 298,
+ 36, 37, 38, 41, 40, 258, 42, 43, 123, 45,
+ 125, 126, 297, 298, 297, 298, 297, 298, 297, 298,
+ 297, 298, 41, 59, 297, 298, 297, 298, 64, 297,
+ 298, 59, 346, 41, 256, 257, 258, 259, 260, 261,
+ 41, 263, 264, 265, 266, 267, 268, 269, 270, 271,
+ 272, 273, 274, 275, 59, 91, 8, 279, 280, 32,
+ 282, 283, 284, 285, 286, 125, 297, 298, 63, 291,
+ 292, 293, 294, 295, 296, 13, 144, 299, 307, 272,
+ 273, 274, 275, 346, 189, 96, 308, 123, 310, 311,
+ 126, -1, 272, 273, 274, 275, 91, 297, 298, 297,
+ 298, 281, -1, -1, 297, 298, 91, 287, 288, 289,
+ 290, 272, 273, 274, 275, -1, -1, 297, 298, -1,
+ 300, 301, 302, 303, 304, 305, 306, -1, 123, 309,
+ 91, -1, 312, 313, 314, -1, 297, 298, 123, -1,
+ -1, 256, 257, 258, 259, 260, 261, -1, 263, 264,
+ 265, 266, 267, 268, 269, 270, 271, 272, 273, 274,
+ 275, -1, 123, -1, 279, 280, -1, 282, 283, 284,
+ 285, 286, 272, 273, 274, 275, 291, 292, 293, 294,
+ 295, 296, 41, -1, 299, 44, 91, -1, -1, -1,
+ -1, -1, -1, 308, -1, 310, 311, 297, 298, 58,
+ 59, -1, -1, -1, 63, -1, 266, 267, 268, -1,
+ 270, 271, -1, -1, -1, -1, -1, -1, 123, -1,
+ 256, 257, 258, 259, 260, 261, 125, 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, -1, -1,
+ 91, -1, 308, 33, 310, 311, 36, 37, 38, -1,
+ 40, 41, 42, 43, 44, 45, 281, -1, -1, -1,
+ -1, -1, 287, 288, 289, 290, -1, -1, 58, 59,
+ -1, -1, 123, 63, 64, 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,
+ -1, 91, -1, 93, 33, -1, -1, 36, 37, 38,
+ -1, 40, 41, 42, 43, 44, 45, -1, 309, -1,
+ -1, 312, 313, 314, -1, -1, -1, -1, -1, 58,
+ 59, -1, -1, 123, 63, 64, 126, 266, 267, 268,
+ -1, 270, 271, -1, -1, -1, -1, -1, -1, 302,
+ 303, 304, -1, 306, 289, 290, -1, -1, -1, -1,
+ -1, 13, -1, 33, 93, -1, 36, 37, 38, -1,
+ 40, 306, 42, 43, 309, 45, -1, 312, 313, 314,
+ 333, -1, -1, 272, 273, 274, 275, 340, -1, 59,
+ 42, 344, 281, 45, 64, -1, -1, 126, 287, 288,
+ 289, 290, -1, -1, 357, 358, -1, -1, 297, 298,
+ -1, 300, 301, 302, 303, 304, 305, 306, -1, -1,
+ 309, 91, -1, 312, 313, 314, -1, -1, 41, 81,
+ -1, 44, -1, -1, -1, -1, 287, 288, 289, 290,
+ -1, -1, -1, 95, -1, -1, 59, -1, -1, 91,
+ -1, -1, -1, 123, 305, 306, 126, -1, 309, -1,
+ -1, 312, 313, 314, -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, 141,
+ 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, 178, -1, 257, 258,
+ 259, 260, 261, 185, 263, 264, 265, -1, -1, -1,
269, -1, -1, 272, 273, 274, 275, -1, -1, -1,
- 123, 280, 281, 282, 283, 284, 285, 286, 287, 288,
+ -1, 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, -1, 307, 308,
- 309, 310, 311, 312, 313, 33, 48, 49, 36, 37,
- 38, -1, 40, -1, 42, 43, -1, 45, -1, -1,
- -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
- 281, 59, -1, -1, 285, 286, 64, 288, -1, -1,
- 82, -1, -1, 294, 295, -1, 88, 298, 299, 300,
- 301, 302, -1, 304, -1, -1, -1, -1, -1, -1,
- -1, 33, -1, 91, 36, 37, 38, -1, 40, -1,
- 42, 43, -1, 45, 116, -1, -1, -1, -1, -1,
- -1, 123, -1, 285, 286, 287, 288, 59, -1, -1,
- -1, -1, 64, -1, -1, 123, -1, -1, 126, 301,
- 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
- 312, 313, -1, -1, -1, -1, -1, 33, -1, 91,
- 36, 37, 38, -1, 40, -1, 42, 43, -1, 45,
- -1, -1, -1, -1, 287, 288, -1, -1, -1, -1,
- -1, -1, 184, -1, -1, -1, -1, -1, 64, -1,
- -1, 123, 305, -1, 126, 308, -1, -1, 311, 312,
- 313, -1, -1, -1, 41, -1, -1, 44, -1, -1,
- -1, -1, -1, -1, -1, 91, -1, 26, -1, -1,
- 33, 58, 59, 36, 37, 38, -1, 40, -1, 42,
- 43, -1, 45, 42, -1, -1, -1, -1, 47, -1,
- 49, -1, -1, -1, -1, -1, -1, 123, -1, -1,
- 126, 64, 61, 62, 63, 64, 93, -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, -1, 107, -1,
- -1, 289, 290, 291, 292, 293, -1, -1, 296, 297,
- 123, -1, -1, 126, 91, 303, -1, -1, -1, 307,
- -1, 309, 310, -1, 256, 257, 258, 259, 260, 261,
- -1, 263, 264, 265, -1, -1, -1, 269, -1, -1,
- 272, 273, 274, 275, -1, -1, 123, 279, 280, -1,
- 282, 283, 284, -1, -1, -1, -1, 289, 290, 291,
- 292, 293, -1, -1, 296, 297, -1, -1, -1, -1,
- 91, 303, -1, -1, -1, 307, -1, 309, 310, -1,
- -1, 257, 258, 259, 260, 261, 262, 263, 264, 265,
- 41, -1, -1, 269, -1, -1, -1, -1, -1, -1,
- -1, -1, 123, -1, 280, -1, 282, 283, 284, -1,
- -1, -1, 63, 289, 290, 291, 292, 293, -1, -1,
- 296, 297, -1, -1, -1, -1, -1, 303, -1, -1,
- -1, 307, -1, 309, 310, 272, 273, 274, 275, -1,
- 91, -1, -1, -1, 257, 258, 259, 260, 261, -1,
- 263, 264, 265, -1, -1, -1, 269, 294, 295, -1,
- -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
- 283, 284, 123, -1, -1, -1, 289, 290, 291, 292,
- 293, -1, -1, 296, 297, -1, -1, -1, -1, -1,
- 303, -1, -1, -1, 307, 33, 309, 310, 36, 37,
- 38, -1, 40, -1, 42, 43, -1, 45, 285, 286,
- 287, 288, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 59, -1, 300, 301, 302, 64, 304, 305, -1,
- -1, 308, -1, -1, 311, 312, 313, -1, -1, -1,
+ 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, 91,
+ 43, 291, 292, 293, 294, 295, 296, 33, 51, 299,
+ 36, 37, 38, 123, 40, -1, 42, 43, 308, 45,
+ 310, 311, -1, -1, -1, 287, -1, 289, 290, -1,
+ -1, 123, -1, 59, -1, -1, -1, -1, 64, 272,
+ 273, 274, 275, 305, 306, -1, -1, 309, 91, -1,
+ 312, 313, 314, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 33, 297, 91, 36, 37, 38, -1,
+ 40, 114, 42, 43, 26, 45, -1, -1, -1, 122,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 33, -1, 91, 36, 37, 38, -1, 40, -1,
- 42, 43, -1, 45, 285, 286, 287, 288, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 64, 304, 305, -1, -1, 308, 126, -1,
- 311, 312, 313, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 33, -1, 91,
- 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
+ -1, 43, 44, -1, 64, -1, -1, 123, 50, -1,
+ 126, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 62, 63, 64, 65, -1, -1, -1, -1, -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,
- 281, -1, -1, -1, 285, 286, 287, 288, 64, -1,
- -1, 123, -1, -1, 126, -1, -1, 298, 299, 300,
- 301, 302, -1, 304, 305, -1, -1, 308, -1, -1,
- 311, 312, 313, -1, -1, 91, -1, -1, -1, -1,
- 33, -1, -1, 36, 37, 38, -1, 40, -1, 42,
- 43, -1, 45, -1, -1, -1, -1, -1, -1, -1,
+ 64, -1, -1, 123, -1, 107, 126, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 126, 64, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 257,
- 258, 259, 260, 261, -1, 263, 264, 265, 91, -1,
- 93, 269, -1, -1, -1, 91, -1, -1, -1, -1,
- -1, -1, 280, -1, 282, 283, 284, -1, -1, -1,
- -1, 289, 290, 291, 292, 293, -1, 63, 296, 297,
- -1, -1, -1, 126, -1, 303, -1, 123, -1, 307,
- -1, 309, 310, -1, -1, 257, 258, 259, 260, 261,
- -1, 263, 264, 265, -1, 91, -1, 269, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 280, -1,
- 282, 283, 284, -1, -1, -1, -1, 289, 290, 291,
- 292, 293, -1, -1, 296, 297, 91, 123, -1, -1,
- -1, 303, -1, 41, -1, 307, 44, 309, 310, -1,
+ -1, -1, -1, -1, -1, -1, -1, 91, -1, 289,
+ 290, -1, 33, -1, -1, 36, 37, 38, -1, 40,
+ -1, 42, 43, -1, 45, 305, 306, 289, -1, 309,
+ -1, -1, 312, 313, 314, -1, 249, -1, -1, 123,
+ -1, 254, 126, 64, 306, -1, -1, 309, -1, -1,
+ 312, 313, 314, -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, 91, 123, 299, -1, 126, -1, -1, -1, -1,
+ -1, -1, 308, 41, 310, 311, 44, 257, 258, 259,
+ 260, 261, 262, 263, 264, 265, -1, -1, -1, 269,
+ -1, -1, -1, 123, -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, 91, -1, -1, -1, 41, 308, -1,
+ 310, 311, -1, 257, 258, 259, 260, 261, -1, 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, -1,
+ -1, -1, -1, -1, -1, -1, 257, 258, 259, 260,
+ 261, -1, 263, 264, 265, -1, -1, -1, 269, 123,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 280,
+ -1, 282, 283, 284, 285, 286, -1, -1, -1, 91,
+ 291, 292, 293, 294, 295, 296, 33, -1, 299, 36,
+ 37, 38, -1, 40, -1, 42, 43, 308, 45, 310,
+ 311, -1, -1, -1, -1, -1, -1, 287, 288, 289,
+ 290, 123, 59, -1, -1, -1, -1, 64, -1, -1,
+ -1, 301, 302, 303, 304, 305, 306, -1, -1, 309,
+ -1, -1, 312, 313, 314, -1, -1, -1, -1, -1,
+ -1, -1, 33, -1, 91, 36, 37, 38, -1, 40,
+ 41, 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, 33, -1,
+ 91, 36, 37, 38, -1, 40, -1, 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, -1, -1, 91, 33, 93, -1,
+ 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 64, -1,
+ -1, 126, 304, 305, 306, -1, -1, 309, -1, -1,
+ 312, 313, 314, -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, -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,
- 58, 59, -1, 269, -1, 63, -1, -1, 123, -1,
- -1, -1, -1, -1, 280, -1, 282, 283, 284, -1,
- -1, -1, -1, 289, 290, 291, 292, 293, -1, -1,
- 296, 297, -1, -1, -1, 93, -1, 303, -1, -1,
- -1, 307, -1, 309, 310, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 257, 258, 259, 260, 261, -1,
- 263, 264, 265, -1, 33, -1, 269, 36, 37, 38,
- -1, 40, -1, 42, 43, -1, 45, 280, -1, 282,
- 283, 284, -1, -1, -1, -1, 289, 290, 291, 292,
- 293, 287, 288, 296, 297, 64, -1, -1, -1, -1,
- 303, -1, -1, -1, 307, -1, 309, 310, 304, 305,
- -1, -1, 308, -1, -1, 311, 312, 313, -1, -1,
- 33, -1, 91, 36, 37, 38, -1, 40, 41, 42,
- 43, -1, 45, -1, -1, 281, -1, -1, -1, 285,
- 286, 287, 288, -1, -1, -1, -1, -1, -1, -1,
- -1, 64, 298, 299, 300, 301, 302, 126, 304, 305,
- -1, -1, 308, -1, -1, 311, 312, 313, -1, -1,
- 285, -1, 287, 288, -1, -1, 33, -1, 91, 36,
- 37, 38, -1, 40, 41, 42, 43, -1, 45, 304,
- 305, -1, -1, 308, -1, -1, 311, 312, 313, -1,
- -1, -1, -1, -1, -1, -1, -1, 64, -1, -1,
- -1, -1, -1, 126, 272, 273, 274, 275, -1, -1,
- -1, -1, -1, 281, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 91, -1, 294, 295, -1, 33,
- 298, 299, 36, 37, 38, -1, 40, 41, 42, 43,
- -1, 45, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 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, -1, -1, -1, -1, -1, -1, -1,
- -1, 280, -1, 282, 283, 284, -1, -1, -1, -1,
- 289, 290, 291, 292, 293, -1, -1, 296, 297, -1,
- -1, -1, 126, -1, 303, -1, 41, -1, 307, 44,
- 309, 310, -1, -1, 257, 258, 259, 260, 261, -1,
- 263, 264, 265, 58, 59, -1, 269, -1, 63, -1,
- -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
- 283, 284, -1, -1, -1, -1, 289, 290, 291, 292,
- 293, -1, -1, 296, 297, -1, 91, -1, 93, -1,
- 303, -1, 41, -1, 307, 44, 309, 310, -1, -1,
- 257, 258, 259, 260, 261, -1, 263, 264, 265, 58,
- 59, -1, 269, -1, 63, -1, -1, -1, 123, -1,
- -1, -1, -1, 280, -1, 282, 283, 284, -1, -1,
- -1, -1, 289, 290, 291, 292, 293, -1, -1, 296,
- 297, -1, 91, -1, 93, -1, 303, -1, -1, -1,
- 307, -1, 309, 310, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 257, 258, 259, 260, 261, -1, 263,
- 264, 265, -1, 33, 123, 269, 36, 37, 38, -1,
- 40, 41, 42, 43, -1, 45, 280, -1, 282, 283,
- 284, -1, -1, -1, -1, 289, 290, 291, 292, 293,
- -1, -1, 296, 297, 64, -1, 25, 26, -1, 303,
- -1, -1, -1, 307, -1, 309, 310, -1, 37, -1,
- -1, -1, -1, 42, 43, -1, -1, -1, 47, 33,
- 49, 91, 36, 37, 38, -1, 40, -1, 42, 43,
- -1, 45, 61, 62, 63, 64, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 64, -1, -1, -1, -1, -1, 126, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
- 285, 286, 287, 288, -1, -1, -1, 91, 107, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
- 305, -1, 41, 308, -1, 44, 311, 312, 313, -1,
- -1, -1, -1, 41, -1, -1, 44, -1, -1, 58,
- 59, -1, 126, 272, 273, 274, 275, -1, -1, -1,
- 58, 59, 281, -1, -1, 63, 285, 286, 287, 288,
- -1, -1, -1, -1, -1, 294, 295, -1, 167, 298,
- 299, 300, 301, 302, 93, 304, 305, -1, 41, 308,
- -1, 44, 311, 312, 313, 93, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 58, 59, -1, -1, -1,
- 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 123, -1, 257, 258, 259,
- 260, 261, -1, 263, 264, 265, -1, -1, 91, 269,
- 93, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 280, -1, 282, 283, 284, -1, -1, -1, -1, 289,
- 290, 291, 292, 293, -1, -1, 296, 297, -1, -1,
- -1, -1, -1, 303, -1, 41, -1, 307, 44, 309,
- 310, -1, -1, 257, 258, 259, 260, 261, -1, 263,
- 264, 265, 58, 59, -1, 269, -1, 63, -1, -1,
- -1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
- 284, -1, -1, -1, -1, 289, 290, 291, 292, 293,
- -1, -1, 296, 297, -1, -1, -1, 93, -1, 303,
- 41, -1, -1, 307, -1, 309, 310, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 58, 59, -1,
- -1, -1, 63, -1, -1, -1, -1, 123, -1, -1,
+ 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, -1, -1, 281, 33, -1, 91,
+ 36, 37, 38, 288, 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,
- -1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
- 91, -1, 93, 281, -1, 294, 295, 285, 286, 287,
- 288, -1, -1, -1, -1, -1, 294, 295, -1, -1,
- 298, 299, 300, 301, 302, -1, 304, 305, -1, -1,
- 308, -1, 123, 311, 312, 313, -1, -1, -1, 272,
- 273, 274, 275, -1, -1, -1, -1, -1, 281, -1,
- -1, -1, 285, 286, 287, 288, -1, -1, -1, -1,
- -1, 294, 295, -1, 41, 298, 299, 300, 301, 302,
- -1, 304, 305, -1, -1, 308, -1, -1, 311, 312,
- 313, 58, 59, -1, -1, -1, 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, 91, -1, 93, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, -1, -1, 281, -1, -1, -1, 285,
- 286, 287, 288, -1, -1, -1, 123, -1, 294, 295,
- -1, -1, 298, 299, 300, 301, 302, -1, 304, 305,
- 41, -1, 308, 44, -1, 311, 312, 313, -1, -1,
- -1, 41, -1, -1, 44, -1, -1, 58, 59, -1,
- -1, 272, 273, 274, 275, -1, -1, -1, 58, 59,
- 281, -1, -1, 63, 285, 286, 287, 288, -1, -1,
- -1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
- 301, 302, 93, 304, 305, -1, -1, 308, -1, -1,
- 311, 312, 313, 93, 41, -1, -1, 44, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 58, 59, -1, -1, -1, 63, -1, -1, -1,
- -1, -1, -1, 123, -1, -1, -1, -1, -1, -1,
- -1, -1, -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, -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, -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, 126,
+ 91, -1, -1, -1, 41, -1, 308, 44, 310, 311,
+ -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
+ -1, 58, 59, 269, -1, -1, 63, -1, -1, -1,
+ -1, -1, 123, -1, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
+ 296, -1, -1, 299, 91, -1, 93, -1, -1, -1,
+ -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, -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, -1, 299, 41, -1, -1, 44, -1, 93, -1,
+ -1, 308, -1, 310, 311, -1, -1, -1, -1, -1,
+ 58, 59, -1, -1, -1, 63, 287, 288, 289, 290,
+ -1, -1, -1, -1, -1, -1, -1, -1, 123, -1,
+ -1, 302, 303, 304, 305, 306, -1, -1, 309, -1,
+ -1, 312, 313, 314, -1, 93, -1, -1, -1, -1,
-1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- -1, -1, -1, -1, 281, -1, 123, -1, 285, 286,
- 287, 288, -1, -1, -1, 41, -1, 294, 295, 93,
- -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
- -1, 308, 58, 59, 311, 312, 313, 63, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 123,
- -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
- 44, -1, -1, -1, -1, 91, -1, 93, -1, -1,
- -1, -1, -1, -1, 58, 59, -1, -1, -1, 63,
+ 41, -1, -1, -1, 281, -1, -1, -1, -1, -1,
+ 287, 288, 289, 290, -1, 123, -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, -1, -1, -1, -1, -1, -1, -1,
- -1, 272, 273, 274, 275, -1, -1, 123, -1, -1,
- -1, -1, 272, 273, 274, 275, -1, -1, -1, 93,
- -1, 281, -1, 294, 295, 285, 286, 287, 288, -1,
- -1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
- 300, 301, 302, -1, 304, 305, -1, -1, 308, -1,
- -1, 311, 312, 313, -1, 41, -1, -1, 44, -1,
- -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- -1, -1, 58, 59, 281, -1, -1, 63, 285, 286,
- 287, 288, -1, -1, -1, -1, -1, 294, 295, -1,
- -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
- -1, 308, -1, -1, 311, 312, 313, 93, 272, 273,
- 274, 275, -1, -1, -1, 41, -1, 281, 44, -1,
- -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
- 294, 295, 58, 59, 298, 299, 300, 301, 302, -1,
- 304, 305, -1, -1, 308, -1, -1, 311, 312, 313,
- -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, -1, -1, 281, -1, 93, -1, 285,
- 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
- -1, 63, 298, 299, 300, 301, 302, -1, 304, 305,
- -1, -1, 308, -1, -1, 311, 312, 313, 272, 273,
- 274, 275, -1, -1, -1, -1, -1, 281, -1, 91,
- -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
- 294, 295, -1, -1, 298, 299, 300, 301, 302, 41,
- 304, 305, 44, -1, 308, -1, -1, 311, 312, 313,
- -1, 123, -1, -1, -1, -1, 58, 59, -1, -1,
- -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
+ 91, -1, 93, -1, 41, -1, -1, -1, -1, -1,
+ -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
+ -1, 58, 59, 269, -1, -1, 63, -1, -1, -1,
+ -1, -1, 123, -1, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
+ 296, -1, -1, 299, 91, -1, 93, -1, -1, -1,
+ 41, -1, 308, 44, 310, 311, -1, 272, 273, 274,
+ 275, -1, -1, -1, -1, -1, 281, 58, 59, -1,
+ -1, -1, 287, 288, 289, 290, 123, -1, -1, -1,
+ -1, -1, 297, 298, -1, 300, 301, 302, 303, 304,
+ 305, 306, -1, -1, 309, -1, -1, 312, 313, 314,
+ -1, -1, 93, -1, 272, 273, 274, 275, -1, 41,
+ -1, -1, 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, 25,
+ 26, 309, -1, -1, 312, 313, 314, -1, -1, -1,
+ -1, 37, -1, -1, -1, -1, -1, 43, 44, 45,
+ -1, 93, -1, -1, 50, -1, -1, -1, -1, -1,
+ -1, 272, 273, 274, 275, -1, 62, 63, 64, 65,
+ 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
+ -1, 123, 41, -1, -1, 44, 297, 298, -1, 300,
+ 301, 302, 303, 304, 305, 306, -1, -1, 309, 58,
+ 59, 312, 313, 314, 63, -1, -1, -1, -1, -1,
+ -1, 107, -1, -1, -1, 272, 273, 274, 275, -1,
+ -1, -1, -1, -1, 281, -1, -1, -1, -1, -1,
+ 287, 288, 289, 290, 93, -1, 41, -1, -1, -1,
+ 297, 298, -1, 300, 301, 302, 303, 304, 305, 306,
+ -1, -1, 309, 58, 59, 312, 313, 314, 63, -1,
+ -1, -1, -1, -1, 123, -1, -1, -1, -1, -1,
+ 166, 272, 273, 274, 275, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 41, -1, 91, 44, 93, -1,
+ -1, -1, -1, -1, 190, -1, 297, 298, -1, 300,
+ -1, 58, 59, -1, -1, -1, 63, -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, -1, -1, -1, -1, 41, -1, -1, 44,
- -1, 93, -1, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, 58, 59, 281, -1, -1, 63, 285,
- 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
- -1, -1, 298, 299, 300, 301, 302, -1, 304, 305,
- 41, -1, 308, 44, -1, 311, 312, 313, 93, -1,
+ 272, 273, 274, 275, -1, 41, 93, -1, 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, 123, 309, -1, -1,
+ 312, 313, 314, -1, -1, -1, -1, -1, -1, -1,
+ 41, -1, -1, 44, -1, -1, -1, 93, -1, -1,
-1, -1, -1, -1, -1, -1, -1, 58, 59, -1,
- -1, -1, 63, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
- 44, -1, -1, -1, -1, -1, -1, -1, 294, 295,
- -1, -1, 93, -1, 58, 59, -1, -1, -1, 63,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 41, -1, -1, 44, -1, 281,
- -1, -1, -1, 285, 286, 287, 288, -1, -1, 93,
- -1, 58, 59, -1, -1, -1, 63, 299, 300, 301,
- 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
- 312, 313, 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,
- 272, 273, 274, 275, -1, -1, -1, -1, -1, 281,
- -1, -1, -1, 285, 286, 287, 288, -1, -1, -1,
- -1, -1, 294, 295, 93, -1, 298, 299, 300, 301,
- 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
- 312, 313, -1, -1, -1, -1, -1, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
- 285, 286, 287, 288, -1, -1, -1, -1, -1, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
- 305, 41, -1, 308, 44, -1, 311, 312, 313, -1,
- -1, 272, 273, 274, 275, -1, -1, -1, 58, 59,
- 281, -1, -1, 63, 285, 286, 287, 288, -1, -1,
- -1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
- 301, 302, -1, 304, 305, -1, -1, 308, 272, 273,
- 274, 275, -1, 93, -1, -1, -1, 281, -1, -1,
- -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
- 294, 295, -1, -1, 298, 299, 300, 301, 302, -1,
- 304, 305, -1, -1, 308, 272, 273, 274, 275, -1,
- -1, -1, -1, -1, 281, -1, -1, -1, 285, 286,
- 287, 288, -1, -1, -1, -1, -1, 294, 295, -1,
- -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
+ -1, -1, 63, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
- -1, -1, 281, -1, -1, -1, 285, 286, 287, 288,
- 41, -1, -1, 44, -1, 294, 295, -1, -1, 298,
- 299, 300, 301, 302, -1, 304, 305, 58, 59, -1,
+ -1, -1, 281, -1, -1, -1, -1, -1, 287, 288,
+ 289, 290, 93, -1, 41, -1, -1, 44, 297, 298,
+ -1, 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, -1, 272, 273, 274,
+ 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
+ -1, -1, 287, 288, 289, 290, 93, -1, -1, -1,
+ -1, -1, 297, 298, -1, 300, 301, 302, 303, 304,
+ 305, 306, -1, -1, 309, -1, -1, 312, 313, 314,
+ -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
+ 41, -1, -1, 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, -1, -1,
+ -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
+ -1, 41, 93, -1, 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, -1,
+ -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
+ 281, -1, -1, 93, -1, -1, 287, 288, 289, 290,
+ -1, -1, 41, -1, -1, 44, 297, 298, -1, 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, -1, 272, 273, 274, 275, -1,
+ 41, -1, -1, 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, -1, 41,
+ -1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
+ 41, -1, 93, 44, -1, -1, 58, 59, -1, -1,
+ -1, 63, -1, -1, -1, -1, -1, 58, 59, -1,
-1, -1, 63, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 41, -1, -1, 44,
+ -1, 272, 273, 274, 275, -1, 41, -1, -1, 44,
+ 281, 93, -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, 312, 313, 314, -1, -1, -1, -1, -1, -1,
+ -1, -1, 272, 273, 274, 275, -1, 41, 93, -1,
+ 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, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 93, 58, 59, -1, -1, -1, 63, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 41, -1, -1, 44, -1, -1, -1, -1, 93, -1,
- -1, -1, 272, 273, 274, 275, -1, 58, 59, -1,
- -1, 281, 63, -1, -1, 285, 286, 287, 288, -1,
- -1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
- 300, 301, 302, 41, 304, 305, 44, -1, -1, -1,
- -1, -1, 93, -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, 41,
- -1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 93, 58, 59, -1, -1,
+ -1, -1, -1, 41, -1, -1, 44, -1, -1, 93,
+ -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
+ 58, 59, 281, -1, -1, 63, -1, -1, 287, 288,
+ 289, 290, -1, -1, -1, -1, -1, -1, 297, 298,
+ -1, 300, 301, 302, 303, 304, 305, 306, -1, -1,
+ 309, 272, 273, 274, 275, 93, -1, -1, -1, -1,
+ 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
+ -1, -1, -1, -1, -1, -1, 297, 298, -1, 300,
+ 301, 302, 303, 304, 305, 306, -1, -1, -1, -1,
+ 272, 273, 274, 275, -1, 41, -1, -1, 44, 281,
+ -1, 272, 273, 274, 275, 287, 288, 289, 290, -1,
+ 281, -1, 58, 59, -1, 297, 298, 63, 300, 301,
+ 302, 303, 304, 305, 306, -1, 297, 298, -1, 300,
+ 301, 302, 303, 304, -1, -1, -1, 272, 273, 274,
+ 275, -1, 41, -1, -1, 44, 281, 93, -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, -1, -1, -1, -1, 41, -1,
+ -1, 44, -1, -1, -1, -1, -1, -1, 272, 273,
+ 274, 275, -1, -1, 93, 58, 59, 281, -1, -1,
+ 63, -1, -1, 287, 288, 289, 290, -1, -1, -1,
+ -1, -1, -1, 297, 298, -1, 300, 301, 302, 303,
+ 304, 305, 306, 41, -1, -1, 44, -1, -1, -1,
+ 93, -1, -1, -1, 272, 273, 274, 275, -1, -1,
+ 58, 59, -1, 281, -1, 63, -1, -1, -1, 287,
+ 288, 289, 290, -1, -1, -1, -1, -1, -1, 297,
+ 298, -1, 300, 301, 302, 303, 304, 305, 306, 41,
+ -1, -1, 44, -1, -1, 93, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 58, 59, -1, -1,
-1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 41, -1, -1, 44,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 93, -1, 58, 59, -1, -1, -1, 63, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
- 281, -1, -1, -1, 285, 286, 287, 288, 93, -1,
- -1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
- 301, 302, -1, 304, 305, -1, -1, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
- 285, 286, 287, 288, 41, -1, -1, 44, -1, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
- 305, 58, 59, -1, -1, -1, 63, -1, -1, -1,
- -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
- 281, -1, -1, -1, 285, 286, 287, 288, -1, -1,
- -1, -1, -1, 294, 295, -1, 93, 298, 299, 300,
- 301, 302, 41, 304, 305, 44, -1, -1, -1, -1,
- -1, -1, -1, -1, 272, 273, 274, 275, -1, 58,
- 59, -1, -1, 281, 63, -1, -1, 285, 286, 287,
- 288, -1, -1, -1, -1, -1, 294, 295, -1, -1,
- 298, 299, 300, 301, 302, -1, 304, 305, -1, -1,
- 272, 273, 274, 275, 93, -1, -1, -1, -1, 281,
- -1, -1, -1, 285, 286, 287, 288, -1, -1, -1,
- -1, -1, 294, 295, -1, -1, 298, 299, 300, 301,
- 302, 41, 304, -1, 44, -1, -1, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, 58, 59,
- 285, 286, -1, 63, -1, -1, -1, -1, -1, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, 41, 304,
- -1, 44, -1, -1, -1, -1, -1, -1, 41, -1,
- -1, 44, -1, 93, -1, 58, 59, -1, -1, -1,
- 63, -1, -1, -1, -1, 58, 59, -1, -1, -1,
- 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, 41, -1, -1, 44, -1, -1,
- 93, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- 93, 58, 59, -1, 281, -1, 63, -1, 285, 286,
- -1, -1, -1, -1, -1, -1, 41, 294, 295, 44,
- -1, 298, 299, 300, 301, 302, 41, -1, -1, 44,
- -1, -1, -1, 58, 59, -1, 93, -1, 63, -1,
- -1, -1, -1, 58, 59, -1, -1, -1, 63, -1,
- -1, -1, -1, 272, 273, 274, 275, -1, -1, 58,
- -1, -1, 281, -1, 63, -1, 285, 286, 93, -1,
- -1, -1, -1, -1, -1, 294, 295, -1, 93, 298,
- 299, 300, 301, 302, -1, -1, -1, -1, -1, -1,
- -1, -1, 91, -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, 123, -1, -1, -1, -1, -1,
- -1, -1, 272, 273, 274, 275, -1, -1, -1, -1,
- -1, 281, -1, -1, -1, 285, 286, -1, -1, -1,
- -1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
- 300, 301, 302, -1, -1, -1, -1, -1, -1, 272,
- 273, 274, 275, -1, -1, -1, -1, -1, 281, 272,
- 273, 274, 275, 286, -1, -1, -1, -1, 281, -1,
- -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
- -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
- -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
+ -1, 93, -1, -1, -1, -1, 272, 273, 274, 275,
+ -1, 58, 59, -1, -1, 281, 63, -1, -1, -1,
+ -1, 287, 288, 289, 290, -1, -1, -1, -1, -1,
+ -1, 297, 298, -1, 300, 301, 302, 303, 304, 305,
+ 306, 41, -1, -1, 44, -1, 93, -1, -1, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, 58, 59,
+ -1, -1, 281, 63, -1, -1, -1, -1, 287, 288,
+ 289, 290, -1, -1, -1, -1, -1, 41, 297, 298,
+ 44, 300, 301, 302, 303, 304, 305, 306, -1, 272,
+ 273, 274, 275, 93, 58, 59, -1, -1, 281, 63,
+ -1, -1, -1, -1, 287, 288, 289, 290, -1, -1,
+ -1, -1, -1, -1, 297, 298, -1, 300, 301, 302,
+ 303, 304, 305, 41, -1, -1, 44, -1, -1, 93,
+ -1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
+ 58, 59, -1, 281, -1, 63, -1, -1, -1, 287,
+ 288, -1, 290, -1, -1, -1, -1, -1, -1, 297,
+ 298, -1, 300, 301, 302, 303, 304, 305, 41, -1,
+ -1, 44, -1, -1, -1, 93, -1, -1, -1, -1,
+ 272, 273, 274, 275, -1, 58, 59, -1, -1, 281,
+ 63, -1, 91, -1, -1, 287, 288, -1, -1, -1,
+ 41, -1, -1, 44, -1, 297, 298, -1, 300, 301,
+ 302, 303, 304, 305, -1, -1, -1, 58, 59, -1,
+ 93, -1, 63, -1, 123, 272, 273, 274, 275, -1,
-1, -1, -1, -1, 281, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 294, 295, -1,
- -1, 298, 299, 300, 301, 302, -1, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, 294,
- 295, -1, -1, 298, 299, 300, 301, -1, -1, 294,
- 295, -1, 281, 298, 299, 300, 285, 286, 287, 288,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 298,
- 299, 300, 301, 302, -1, 304, 305, 30, -1, 308,
- -1, -1, 311, 312, 313, 38, -1, -1, -1, -1,
- 43, 44, -1, -1, -1, -1, -1, 50, 51, 52,
- 53, 54, 55, -1, -1, 58, 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, -1, -1, -1, -1, -1, 90, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 287, 288, 41, -1, -1, 44, -1, -1, -1, -1,
+ 297, 298, 93, 300, 301, 302, 303, 304, -1, 58,
+ 59, -1, 41, -1, 63, 44, -1, -1, -1, -1,
+ -1, -1, 272, 273, 274, 275, -1, -1, -1, 58,
+ 59, 281, -1, -1, -1, 58, -1, 287, 288, 41,
+ 63, -1, 44, -1, 93, -1, -1, 297, 298, -1,
+ 300, 301, 302, 303, 304, -1, 58, 59, 272, 273,
+ 274, 275, -1, -1, 93, -1, -1, 281, 91, -1,
+ -1, -1, -1, 287, 288, 41, -1, -1, 44, -1,
+ -1, -1, -1, 297, 298, -1, 300, 301, 302, 303,
+ 304, 93, 58, 59, -1, -1, -1, -1, -1, -1,
+ 123, -1, -1, -1, 272, 273, 274, 275, -1, -1,
+ -1, -1, -1, 281, -1, -1, -1, -1, -1, 287,
+ 288, -1, -1, -1, -1, -1, -1, 93, -1, 297,
+ 298, 63, 300, 301, 302, 303, 304, -1, 287, 288,
+ 289, 290, -1, -1, -1, -1, -1, -1, -1, 272,
+ 273, 274, 275, -1, 303, 304, 305, 306, 281, 91,
+ 309, -1, -1, 312, 313, 314, -1, -1, -1, -1,
+ -1, -1, -1, -1, 297, 298, -1, 300, 301, 302,
+ 303, 272, 273, 274, 275, -1, -1, -1, -1, -1,
+ 281, 123, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 297, 298, -1, 300,
+ 301, 302, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, 297, 298,
+ -1, 300, -1, -1, -1, -1, -1, -1, 281, -1,
+ -1, -1, -1, -1, 287, 288, 289, 290, 297, 298,
+ 272, 273, 274, 275, -1, -1, -1, 300, 301, 302,
+ 303, 304, 305, 306, -1, -1, 309, -1, -1, 312,
+ 313, 314, -1, -1, -1, 297, 298, -1, -1, -1,
+ -1, -1, -1, -1, 30, -1, 272, 273, 274, 275,
+ -1, -1, 38, -1, -1, -1, 42, -1, -1, 45,
+ -1, -1, -1, -1, -1, -1, 52, 53, 54, 55,
+ 56, 297, 298, 59, 60, -1, -1, -1, -1, -1,
+ 66, -1, -1, -1, -1, -1, -1, -1, -1, 281,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
+ -1, -1, -1, -1, -1, -1, -1, 93, -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,
- 143, -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, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 150, 151, 152, 153, 154, 155,
+ 156, 157, 158, 159, 160, 161, 162, 163, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 175,
-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,
@@ -1108,16 +1058,16 @@ dEXT short yycheck[] = { 13,
-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, 256, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 253, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 284,
+ -1, -1, -1, -1, -1, -1, -1, -1, 284,
};
#define YYFINAL 1
#ifndef YYDEBUG
#define YYDEBUG 0
#endif
-#define YYMAXTOKEN 313
+#define YYMAXTOKEN 314
#if YYDEBUG
dEXT 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,
@@ -1130,9 +1080,9 @@ dEXT char * yyname[] = {
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","RELOP","EQOP",
-"MULOP","ADDOP","DOLSHARP","DO","LOCAL","HASHBRACK","NOAMP","OROP","ANDOP",
-"NOTOP","LSTOP","ASSIGNOP","OROR","ANDAND","BITOROP","BITANDOP","UNIOP",
+"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",
};
@@ -1142,6 +1092,8 @@ dEXT char * yyrule[] = {
"prog : $$1 lineseq",
"block : '{' remember lineseq '}'",
"remember :",
+"mblock : '{' mremember lineseq '}'",
+"mremember :",
"lineseq :",
"lineseq : lineseq decl",
"lineseq : lineseq line",
@@ -1154,44 +1106,52 @@ dEXT char * yyrule[] = {
"sideff : expr IF expr",
"sideff : expr UNLESS expr",
"sideff : expr WHILE expr",
-"sideff : expr UNTIL expr",
+"sideff : expr UNTIL iexpr",
"else :",
-"else : ELSE block",
-"else : ELSIF '(' expr ')' block else",
-"cond : IF '(' expr ')' block else",
-"cond : UNLESS '(' expr ')' block else",
-"cond : IF block block else",
-"cond : UNLESS block block 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 '(' texpr ')' block cont",
-"loop : label UNTIL '(' expr ')' block cont",
-"loop : label WHILE block block cont",
-"loop : label UNTIL block block cont",
-"loop : label FOR scalar '(' expr ')' block cont",
-"loop : label FOR '(' expr ')' block cont",
-"loop : label FOR '(' nexpr ';' texpr ';' nexpr ')' 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 startsub WORD block",
-"format : FORMAT startsub block",
-"subrout : SUB startsub WORD proto block",
-"subrout : SUB startsub WORD proto ';'",
+"format : FORMAT startformsub formname block",
+"formname : WORD",
+"formname :",
+"subrout : SUB startsub subname proto subbody",
+"startsub :",
+"startanonsub :",
+"startformsub :",
+"subname : WORD",
"proto :",
"proto : THING",
-"startsub :",
+"subbody : block",
+"subbody : ';'",
"package : PACKAGE WORD ';'",
"package : PACKAGE ';'",
-"use : USE startsub WORD listexpr ';'",
+"$$2 :",
+"use : USE startsub $$2 WORD WORD listexpr ';'",
"expr : expr ANDOP expr",
"expr : expr OROP expr",
"expr : argexpr",
@@ -1205,7 +1165,8 @@ dEXT char * yyrule[] = {
"listop : FUNCMETH indirob '(' listexprcom ')'",
"listop : LSTOP listexpr",
"listop : FUNC '(' listexprcom ')'",
-"listop : LSTOPSUB startsub block listexpr",
+"$$3 :",
+"listop : LSTOPSUB startanonsub block $$3 listexpr",
"method : METHOD",
"method : scalar",
"term : term ASSIGNOP term",
@@ -1231,14 +1192,14 @@ dEXT char * yyrule[] = {
"term : term POSTDEC",
"term : PREINC term",
"term : PREDEC term",
-"term : LOCAL term",
+"term : local term",
"term : '(' expr ')'",
"term : '(' ')'",
"term : '[' expr ']'",
"term : '[' ']'",
"term : HASHBRACK expr ';' '}'",
"term : HASHBRACK ';' '}'",
-"term : ANONSUB startsub proto block",
+"term : ANONSUB startanonsub proto block",
"term : scalar",
"term : star '{' expr ';' '}'",
"term : star",
@@ -1266,6 +1227,8 @@ dEXT char * yyrule[] = {
"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",
@@ -1287,6 +1250,9 @@ dEXT char * yyrule[] = {
"listexprcom :",
"listexprcom : expr",
"listexprcom : expr ','",
+"local : LOCAL",
+"local : MY",
+"my_scalar : scalar",
"amper : '&' indirob",
"scalar : '$' indirob",
"ary : '@' indirob",
@@ -1319,9 +1285,9 @@ dEXT int yyerrflag;
dEXT int yychar;
dEXT YYSTYPE yyval;
dEXT YYSTYPE yylval;
-#line 571 "perly.y"
+#line 631 "perly.y"
/* PROGRAM */
-#line 1394 "y_tab.c"
+#line 1360 "perly.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
@@ -1365,7 +1331,9 @@ yyparse()
int retval = 0;
#if YYDEBUG
register char *yys;
+# ifndef getenv
extern char *getenv();
+# endif
#endif
struct ysv *ysave = (struct ysv*)safemalloc(sizeof(struct ysv));
@@ -1413,7 +1381,7 @@ yyloop:
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate,
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
#endif
@@ -1423,7 +1391,7 @@ yyloop:
{
#if YYDEBUG
if (yydebug)
- fprintf(stderr, "yydebug: state %d, shifting to state %d\n",
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n",
yystate, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
@@ -1478,7 +1446,7 @@ yyinrecovery:
{
#if YYDEBUG
if (yydebug)
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: state %d, error recovery shifting to state %d\n",
*yyssp, yytable[yyn]);
#endif
@@ -1508,7 +1476,7 @@ yyinrecovery:
{
#if YYDEBUG
if (yydebug)
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: error recovery discarding state %d\n",
*yyssp);
#endif
@@ -1527,7 +1495,7 @@ yyinrecovery:
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: state %d, error recovery discards token %d (%s)\n",
yystate, yychar, yys);
}
@@ -1538,7 +1506,7 @@ yyinrecovery:
yyreduce:
#if YYDEBUG
if (yydebug)
- fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n",
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
yym = yylen[yyn];
@@ -1546,7 +1514,7 @@ yyreduce:
switch (yyn)
{
case 1:
-#line 84 "perly.y"
+#line 86 "perly.y"
{
#if defined(YYDEBUG) && defined(DEBUGGING)
yydebug = (debug & 1);
@@ -1555,38 +1523,50 @@ case 1:
}
break;
case 2:
-#line 91 "perly.y"
+#line 93 "perly.y"
{ newPROG(yyvsp[0].opval); }
break;
case 3:
-#line 95 "perly.y"
-{ yyval.opval = block_end(yyvsp[-3].ival,yyvsp[-2].ival,yyvsp[-1].opval); }
+#line 97 "perly.y"
+{ if (copline > (line_t)yyvsp[-3].ival)
+ copline = yyvsp[-3].ival;
+ yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
case 4:
-#line 99 "perly.y"
-{ yyval.ival = block_start(); }
+#line 103 "perly.y"
+{ yyval.ival = block_start(TRUE); }
break;
case 5:
-#line 103 "perly.y"
-{ yyval.opval = Nullop; }
+#line 107 "perly.y"
+{ if (copline > (line_t)yyvsp[-3].ival)
+ copline = yyvsp[-3].ival;
+ yyval.opval = block_end(yyvsp[-2].ival, yyvsp[-1].opval); }
break;
case 6:
-#line 105 "perly.y"
-{ yyval.opval = yyvsp[-1].opval; }
+#line 113 "perly.y"
+{ yyval.ival = block_start(FALSE); }
break;
case 7:
-#line 107 "perly.y"
+#line 117 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 8:
+#line 119 "perly.y"
+{ yyval.opval = yyvsp[-1].opval; }
+break;
+case 9:
+#line 121 "perly.y"
{ yyval.opval = append_list(OP_LINESEQ,
(LISTOP*)yyvsp[-1].opval, (LISTOP*)yyvsp[0].opval);
pad_reset_pending = TRUE;
if (yyvsp[-1].opval && yyvsp[0].opval) hints |= HINT_BLOCK_SCOPE; }
break;
-case 8:
-#line 114 "perly.y"
+case 10:
+#line 128 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); }
break;
-case 10:
-#line 117 "perly.y"
+case 12:
+#line 131 "perly.y"
{ if (yyvsp[-1].pval != Nullch) {
yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0));
}
@@ -1596,467 +1576,501 @@ case 10:
}
expect = XSTATE; }
break;
-case 11:
-#line 126 "perly.y"
+case 13:
+#line 140 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval, yyvsp[-1].opval);
expect = XSTATE; }
break;
-case 12:
-#line 131 "perly.y"
-{ yyval.opval = Nullop; }
-break;
-case 13:
-#line 133 "perly.y"
-{ yyval.opval = yyvsp[0].opval; }
-break;
case 14:
-#line 135 "perly.y"
-{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); }
+#line 145 "perly.y"
+{ yyval.opval = Nullop; }
break;
case 15:
-#line 137 "perly.y"
-{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); }
+#line 147 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
break;
case 16:
-#line 139 "perly.y"
-{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); }
+#line 149 "perly.y"
+{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 17:
-#line 141 "perly.y"
-{ yyval.opval = newLOOPOP(OPf_PARENS, 1, invert(scalar(yyvsp[0].opval)), yyvsp[-2].opval);}
+#line 151 "perly.y"
+{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[0].opval, yyvsp[-2].opval); }
break;
case 18:
-#line 145 "perly.y"
-{ yyval.opval = Nullop; }
+#line 153 "perly.y"
+{ yyval.opval = newLOOPOP(OPf_PARENS, 1, scalar(yyvsp[0].opval), yyvsp[-2].opval); }
break;
case 19:
-#line 147 "perly.y"
-{ yyval.opval = scope(yyvsp[0].opval); }
+#line 155 "perly.y"
+{ yyval.opval = newLOOPOP(OPf_PARENS, 1, yyvsp[0].opval, yyvsp[-2].opval);}
break;
case 20:
-#line 149 "perly.y"
-{ copline = yyvsp[-5].ival;
- yyval.opval = newSTATEOP(0, 0,
- newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval));
- hints |= HINT_BLOCK_SCOPE; }
+#line 159 "perly.y"
+{ yyval.opval = Nullop; }
break;
case 21:
-#line 156 "perly.y"
-{ copline = yyvsp[-5].ival;
- yyval.opval = newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval); }
+#line 161 "perly.y"
+{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 22:
-#line 159 "perly.y"
+#line 163 "perly.y"
{ copline = yyvsp[-5].ival;
- yyval.opval = newCONDOP(0,
- invert(scalar(yyvsp[-3].opval)), scope(yyvsp[-1].opval), yyvsp[0].opval); }
+ yyval.opval = newSTATEOP(0, Nullch,
+ newCONDOP(0, yyvsp[-3].opval, scope(yyvsp[-1].opval), yyvsp[0].opval));
+ hints |= HINT_BLOCK_SCOPE; }
break;
case 23:
-#line 163 "perly.y"
-{ copline = yyvsp[-3].ival;
- deprecate("if BLOCK BLOCK");
- yyval.opval = newCONDOP(0, scope(yyvsp[-2].opval), scope(yyvsp[-1].opval), yyvsp[0].opval); }
+#line 170 "perly.y"
+{ 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 24:
-#line 167 "perly.y"
-{ copline = yyvsp[-3].ival;
- deprecate("unless BLOCK BLOCK");
- yyval.opval = newCONDOP(0, invert(scalar(scope(yyvsp[-2].opval))),
- scope(yyvsp[-1].opval), yyvsp[0].opval); }
+#line 174 "perly.y"
+{ 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 174 "perly.y"
+#line 180 "perly.y"
{ yyval.opval = Nullop; }
break;
case 26:
-#line 176 "perly.y"
+#line 182 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 27:
-#line 180 "perly.y"
-{ copline = yyvsp[-5].ival;
- yyval.opval = newSTATEOP(0, yyvsp[-6].pval,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval) ); }
+#line 186 "perly.y"
+{ 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 28:
-#line 185 "perly.y"
-{ copline = yyvsp[-5].ival;
- yyval.opval = newSTATEOP(0, yyvsp[-6].pval,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- invert(scalar(yyvsp[-3].opval)), yyvsp[-1].opval, yyvsp[0].opval) ); }
+#line 192 "perly.y"
+{ 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 190 "perly.y"
-{ copline = yyvsp[-3].ival;
- yyval.opval = newSTATEOP(0, yyvsp[-4].pval,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- scope(yyvsp[-2].opval), yyvsp[-1].opval, yyvsp[0].opval) ); }
+#line 198 "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 30:
-#line 195 "perly.y"
-{ copline = yyvsp[-3].ival;
- yyval.opval = newSTATEOP(0, yyvsp[-4].pval,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- invert(scalar(scope(yyvsp[-2].opval))), yyvsp[-1].opval, yyvsp[0].opval)); }
+#line 201 "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 31:
-#line 200 "perly.y"
-{ yyval.opval = newFOROP(0, yyvsp[-7].pval, yyvsp[-6].ival, mod(yyvsp[-5].opval, OP_ENTERLOOP),
- yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); }
+#line 205 "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 32:
-#line 203 "perly.y"
-{ yyval.opval = newFOROP(0, yyvsp[-6].pval, yyvsp[-5].ival, Nullop, yyvsp[-3].opval, yyvsp[-1].opval, yyvsp[0].opval); }
+#line 209 "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)));
+ copline = yyvsp[-9].ival;
+ yyval.opval = block_end(yyvsp[-7].ival, newSTATEOP(0, yyvsp[-10].pval, forop)); }
break;
case 33:
-#line 206 "perly.y"
-{ copline = yyvsp[-8].ival;
- yyval.opval = append_elem(OP_LINESEQ,
- newSTATEOP(0, yyvsp[-9].pval, scalar(yyvsp[-6].opval)),
- newSTATEOP(0, yyvsp[-9].pval,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- scalar(yyvsp[-4].opval), yyvsp[0].opval, scalar(yyvsp[-2].opval)) )); }
+#line 217 "perly.y"
+{ yyval.opval = newSTATEOP(0, yyvsp[-2].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ NOLINE, Nullop, yyvsp[-1].opval, yyvsp[0].opval)); }
break;
case 34:
-#line 213 "perly.y"
-{ yyval.opval = newSTATEOP(0,
- yyvsp[-2].pval, newWHILEOP(0, 1, (LOOP*)Nullop,
- Nullop, yyvsp[-1].opval, yyvsp[0].opval)); }
-break;
-case 35:
-#line 219 "perly.y"
+#line 223 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 37:
-#line 224 "perly.y"
+case 36:
+#line 228 "perly.y"
{ (void)scan_num("1"); yyval.opval = yylval.opval; }
break;
+case 38:
+#line 233 "perly.y"
+{ yyval.opval = invert(scalar(yyvsp[0].opval)); }
+break;
case 39:
-#line 229 "perly.y"
-{ yyval.pval = Nullch; }
+#line 237 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 40:
+#line 241 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 41:
-#line 234 "perly.y"
-{ yyval.ival = 0; }
+#line 245 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 42:
-#line 236 "perly.y"
-{ yyval.ival = 0; }
+#line 249 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
break;
case 43:
-#line 238 "perly.y"
-{ yyval.ival = 0; }
-break;
-case 44:
-#line 240 "perly.y"
-{ yyval.ival = 0; }
+#line 253 "perly.y"
+{ yyval.pval = Nullch; }
break;
case 45:
-#line 244 "perly.y"
-{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
+#line 258 "perly.y"
+{ yyval.ival = 0; }
break;
case 46:
-#line 246 "perly.y"
-{ newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); }
+#line 260 "perly.y"
+{ yyval.ival = 0; }
break;
case 47:
-#line 250 "perly.y"
-{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
+#line 262 "perly.y"
+{ yyval.ival = 0; }
break;
case 48:
-#line 252 "perly.y"
-{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, Nullop); expect = XSTATE; }
+#line 264 "perly.y"
+{ yyval.ival = 0; }
break;
case 49:
-#line 256 "perly.y"
-{ yyval.opval = Nullop; }
+#line 268 "perly.y"
+{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
+break;
+case 50:
+#line 271 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
break;
case 51:
-#line 261 "perly.y"
-{ yyval.ival = start_subparse(); }
+#line 272 "perly.y"
+{ yyval.opval = Nullop; }
break;
case 52:
-#line 265 "perly.y"
-{ package(yyvsp[-1].opval); }
+#line 276 "perly.y"
+{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
case 53:
-#line 267 "perly.y"
-{ package(Nullop); }
+#line 280 "perly.y"
+{ yyval.ival = start_subparse(FALSE, 0); }
break;
case 54:
-#line 271 "perly.y"
-{ utilize(yyvsp[-4].ival, yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval); }
+#line 284 "perly.y"
+{ yyval.ival = start_subparse(FALSE, CVf_ANON); }
break;
case 55:
-#line 275 "perly.y"
-{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
+#line 288 "perly.y"
+{ yyval.ival = start_subparse(TRUE, 0); }
break;
case 56:
-#line 277 "perly.y"
+#line 291 "perly.y"
+{ char *name = SvPVx(((SVOP*)yyvsp[0].opval)->op_sv, na);
+ if (strEQ(name, "BEGIN") || strEQ(name, "END"))
+ CvUNIQUE_on(compcv);
+ yyval.opval = yyvsp[0].opval; }
+break;
+case 57:
+#line 298 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 59:
+#line 302 "perly.y"
+{ yyval.opval = yyvsp[0].opval; }
+break;
+case 60:
+#line 303 "perly.y"
+{ yyval.opval = Nullop; expect = XSTATE; }
+break;
+case 61:
+#line 307 "perly.y"
+{ package(yyvsp[-1].opval); }
+break;
+case 62:
+#line 309 "perly.y"
+{ package(Nullop); }
+break;
+case 63:
+#line 313 "perly.y"
+{ CvUNIQUE_on(compcv); /* It's a BEGIN {} */ }
+break;
+case 64:
+#line 315 "perly.y"
+{ utilize(yyvsp[-6].ival, yyvsp[-5].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
+break;
+case 65:
+#line 319 "perly.y"
+{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
+break;
+case 66:
+#line 321 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 58:
-#line 282 "perly.y"
+case 68:
+#line 326 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
-case 59:
-#line 284 "perly.y"
+case 69:
+#line 328 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 61:
-#line 289 "perly.y"
+case 71:
+#line 333 "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 62:
-#line 292 "perly.y"
+case 72:
+#line 336 "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 63:
-#line 295 "perly.y"
+case 73:
+#line 339 "perly.y"
{ yyval.opval = convert(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST,
- prepend_elem(OP_LIST, yyvsp[-5].opval, yyvsp[-1].opval),
+ prepend_elem(OP_LIST, scalar(yyvsp[-5].opval), yyvsp[-1].opval),
newUNOP(OP_METHOD, 0, yyvsp[-3].opval))); }
break;
-case 64:
-#line 300 "perly.y"
+case 74:
+#line 344 "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 65:
-#line 305 "perly.y"
+case 75:
+#line 349 "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 66:
-#line 310 "perly.y"
+case 76:
+#line 354 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 67:
-#line 312 "perly.y"
+case 77:
+#line 356 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
-case 68:
-#line 314 "perly.y"
+case 78:
+#line 358 "perly.y"
+{ yyvsp[0].opval = newANONSUB(yyvsp[-1].ival, 0, yyvsp[0].opval); }
+break;
+case 79:
+#line 360 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST,
- prepend_elem(OP_LIST, newANONSUB(yyvsp[-2].ival, 0, yyvsp[-1].opval), yyvsp[0].opval),
- yyvsp[-3].opval)); }
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval), yyvsp[-4].opval)); }
break;
-case 71:
-#line 325 "perly.y"
+case 82:
+#line 370 "perly.y"
{ yyval.opval = newASSIGNOP(OPf_STACKED, yyvsp[-2].opval, yyvsp[-1].ival, yyvsp[0].opval); }
break;
-case 72:
-#line 327 "perly.y"
+case 83:
+#line 372 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 73:
-#line 329 "perly.y"
+case 84:
+#line 374 "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 74:
-#line 333 "perly.y"
+case 85:
+#line 378 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 75:
-#line 335 "perly.y"
+case 86:
+#line 380 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 76:
-#line 337 "perly.y"
+case 87:
+#line 382 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 77:
-#line 339 "perly.y"
+case 88:
+#line 384 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 78:
-#line 341 "perly.y"
+case 89:
+#line 386 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 79:
-#line 343 "perly.y"
+case 90:
+#line 388 "perly.y"
{ yyval.opval = newBINOP(yyvsp[-1].ival, 0, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval)); }
break;
-case 80:
-#line 345 "perly.y"
+case 91:
+#line 390 "perly.y"
{ yyval.opval = newRANGE(yyvsp[-1].ival, scalar(yyvsp[-2].opval), scalar(yyvsp[0].opval));}
break;
-case 81:
-#line 347 "perly.y"
+case 92:
+#line 392 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 82:
-#line 349 "perly.y"
+case 93:
+#line 394 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 83:
-#line 351 "perly.y"
+case 94:
+#line 396 "perly.y"
{ yyval.opval = newCONDOP(0, yyvsp[-4].opval, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 84:
-#line 353 "perly.y"
+case 95:
+#line 398 "perly.y"
{ yyval.opval = bind_match(yyvsp[-1].ival, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 85:
-#line 356 "perly.y"
+case 96:
+#line 401 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
-case 86:
-#line 358 "perly.y"
+case 97:
+#line 403 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 87:
-#line 360 "perly.y"
+case 98:
+#line 405 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
-case 88:
-#line 362 "perly.y"
+case 99:
+#line 407 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
-case 89:
-#line 364 "perly.y"
+case 100:
+#line 409 "perly.y"
{ yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
break;
-case 90:
-#line 366 "perly.y"
+case 101:
+#line 411 "perly.y"
{ yyval.opval = newUNOP(OP_POSTINC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTINC)); }
break;
-case 91:
-#line 369 "perly.y"
+case 102:
+#line 414 "perly.y"
{ yyval.opval = newUNOP(OP_POSTDEC, 0,
mod(scalar(yyvsp[-1].opval), OP_POSTDEC)); }
break;
-case 92:
-#line 372 "perly.y"
+case 103:
+#line 417 "perly.y"
{ yyval.opval = newUNOP(OP_PREINC, 0,
mod(scalar(yyvsp[0].opval), OP_PREINC)); }
break;
-case 93:
-#line 375 "perly.y"
+case 104:
+#line 420 "perly.y"
{ yyval.opval = newUNOP(OP_PREDEC, 0,
mod(scalar(yyvsp[0].opval), OP_PREDEC)); }
break;
-case 94:
-#line 378 "perly.y"
+case 105:
+#line 423 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
-case 95:
-#line 380 "perly.y"
+case 106:
+#line 425 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
-case 96:
-#line 382 "perly.y"
+case 107:
+#line 427 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
-case 97:
-#line 384 "perly.y"
+case 108:
+#line 429 "perly.y"
{ yyval.opval = newANONLIST(yyvsp[-1].opval); }
break;
-case 98:
-#line 386 "perly.y"
+case 109:
+#line 431 "perly.y"
{ yyval.opval = newANONLIST(Nullop); }
break;
-case 99:
-#line 388 "perly.y"
+case 110:
+#line 433 "perly.y"
{ yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
-case 100:
-#line 390 "perly.y"
+case 111:
+#line 435 "perly.y"
{ yyval.opval = newANONHASH(Nullop); }
break;
-case 101:
-#line 392 "perly.y"
+case 112:
+#line 437 "perly.y"
{ yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
-case 102:
-#line 394 "perly.y"
+case 113:
+#line 439 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 103:
-#line 396 "perly.y"
+case 114:
+#line 441 "perly.y"
{ yyval.opval = newBINOP(OP_GELEM, 0, newGVREF(0,yyvsp[-4].opval), yyvsp[-2].opval); }
break;
-case 104:
-#line 398 "perly.y"
+case 115:
+#line 443 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 105:
-#line 400 "perly.y"
+case 116:
+#line 445 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0, oopsAV(yyvsp[-3].opval), scalar(yyvsp[-1].opval)); }
break;
-case 106:
-#line 402 "perly.y"
+case 117:
+#line 447 "perly.y"
{ yyval.opval = newBINOP(OP_AELEM, 0,
ref(newAVREF(yyvsp[-4].opval),OP_RV2AV),
scalar(yyvsp[-1].opval));}
break;
-case 107:
-#line 406 "perly.y"
+case 118:
+#line 451 "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 108:
-#line 410 "perly.y"
+case 119:
+#line 455 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 109:
-#line 412 "perly.y"
+case 120:
+#line 457 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 110:
-#line 414 "perly.y"
+case 121:
+#line 459 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
-case 111:
-#line 416 "perly.y"
+case 122:
+#line 461 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0, oopsHV(yyvsp[-4].opval), jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
-case 112:
-#line 419 "perly.y"
+case 123:
+#line 464 "perly.y"
{ yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-5].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
-case 113:
-#line 424 "perly.y"
+case 124:
+#line 469 "perly.y"
{ assertref(yyvsp[-4].opval); yyval.opval = newBINOP(OP_HELEM, 0,
ref(newHVREF(yyvsp[-4].opval),OP_RV2HV),
jmaybe(yyvsp[-2].opval));
expect = XOPERATOR; }
break;
-case 114:
-#line 429 "perly.y"
+case 125:
+#line 474 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
-case 115:
-#line 431 "perly.y"
+case 126:
+#line 476 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
-case 116:
-#line 433 "perly.y"
+case 127:
+#line 478 "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 117:
-#line 439 "perly.y"
+case 128:
+#line 484 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
@@ -2064,38 +2078,38 @@ case 117:
ref(oopsHV(yyvsp[-4].opval), OP_HSLICE)));
expect = XOPERATOR; }
break;
-case 118:
-#line 446 "perly.y"
+case 129:
+#line 491 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 119:
-#line 448 "perly.y"
+case 130:
+#line 493 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
break;
-case 120:
-#line 450 "perly.y"
+case 131:
+#line 495 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
-case 121:
-#line 452 "perly.y"
+case 132:
+#line 497 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[-1].opval, scalar(yyvsp[-3].opval))); }
break;
-case 122:
-#line 455 "perly.y"
+case 133:
+#line 500 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
-case 123:
-#line 458 "perly.y"
+case 134:
+#line 503 "perly.y"
{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); }
break;
-case 124:
-#line 460 "perly.y"
+case 135:
+#line 505 "perly.y"
{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
break;
-case 125:
-#line 462 "perly.y"
+case 136:
+#line 507 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
@@ -2104,8 +2118,8 @@ case 125:
scalar(yyvsp[-2].opval)
)),Nullop)); dep();}
break;
-case 126:
-#line 470 "perly.y"
+case 137:
+#line 515 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
append_elem(OP_LIST,
@@ -2115,139 +2129,162 @@ case 126:
scalar(yyvsp[-3].opval)
)))); dep();}
break;
-case 127:
-#line 479 "perly.y"
+case 138:
+#line 524 "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 128:
-#line 483 "perly.y"
+case 139:
+#line 528 "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 129:
-#line 488 "perly.y"
+case 140:
+#line 533 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ newCVREF(0, scalar(yyvsp[-3].opval))); }
+break;
+case 141:
+#line 536 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, yyvsp[-1].opval,
+ newCVREF(0, scalar(yyvsp[-4].opval)))); }
+break;
+case 142:
+#line 540 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
hints |= HINT_BLOCK_SCOPE; }
break;
-case 130:
-#line 491 "perly.y"
+case 143:
+#line 543 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
-case 131:
-#line 493 "perly.y"
+case 144:
+#line 545 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
-case 132:
-#line 495 "perly.y"
+case 145:
+#line 547 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
-case 133:
-#line 497 "perly.y"
+case 146:
+#line 549 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 134:
-#line 499 "perly.y"
+case 147:
+#line 551 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 135:
-#line 501 "perly.y"
+case 148:
+#line 553 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, yyvsp[0].opval, scalar(yyvsp[-1].opval))); }
break;
-case 136:
-#line 504 "perly.y"
+case 149:
+#line 556 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
-case 137:
-#line 506 "perly.y"
+case 150:
+#line 558 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
-case 138:
-#line 508 "perly.y"
-{ yyval.opval = newUNOP(OP_ENTERSUB, 0,
+case 151:
+#line 560 "perly.y"
+{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED,
scalar(yyvsp[0].opval)); }
break;
-case 139:
-#line 511 "perly.y"
+case 152:
+#line 563 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
-case 140:
-#line 513 "perly.y"
+case 153:
+#line 565 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
-case 141:
-#line 515 "perly.y"
+case 154:
+#line 567 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
-case 142:
-#line 517 "perly.y"
+case 155:
+#line 569 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
-case 145:
-#line 523 "perly.y"
+case 158:
+#line 575 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 146:
-#line 525 "perly.y"
+case 159:
+#line 577 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 147:
-#line 529 "perly.y"
+case 160:
+#line 581 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 148:
-#line 531 "perly.y"
+case 161:
+#line 583 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 149:
-#line 533 "perly.y"
+case 162:
+#line 585 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
-case 150:
-#line 537 "perly.y"
+case 163:
+#line 588 "perly.y"
+{ yyval.ival = 0; }
+break;
+case 164:
+#line 589 "perly.y"
+{ yyval.ival = 1; }
+break;
+case 165:
+#line 593 "perly.y"
+{ in_my = 0; yyval.opval = my(yyvsp[0].opval); }
+break;
+case 166:
+#line 597 "perly.y"
{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
break;
-case 151:
-#line 541 "perly.y"
+case 167:
+#line 601 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
-case 152:
-#line 545 "perly.y"
+case 168:
+#line 605 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
-case 153:
-#line 549 "perly.y"
+case 169:
+#line 609 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
-case 154:
-#line 553 "perly.y"
+case 170:
+#line 613 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
-case 155:
-#line 557 "perly.y"
+case 171:
+#line 617 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
-case 156:
-#line 561 "perly.y"
+case 172:
+#line 621 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
-case 157:
-#line 563 "perly.y"
+case 173:
+#line 623 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
-case 158:
-#line 565 "perly.y"
+case 174:
+#line 625 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
-case 159:
-#line 568 "perly.y"
+case 175:
+#line 628 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-#line 2236 "y_tab.c"
+#line 2271 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
@@ -2257,7 +2294,7 @@ break;
{
#if YYDEBUG
if (yydebug)
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: after reduction, shifting from state 0 to state %d\n",
YYFINAL);
#endif
@@ -2273,7 +2310,7 @@ break;
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(stderr, "yydebug: state %d, reading %d (%s)\n",
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
#endif
@@ -2288,7 +2325,7 @@ break;
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
- fprintf(stderr,
+ PerlIO_printf(Perl_debug_log,
"yydebug: after reduction, shifting from state %d to state %d\n",
*yyssp, yystate);
#endif
diff --git a/gnu/usr.bin/perl/vms/perly_h.vms b/gnu/usr.bin/perl/vms/perly_h.vms
index c6ec3a41ad5..ebeaaf735a3 100644
--- a/gnu/usr.bin/perl/vms/perly_h.vms
+++ b/gnu/usr.bin/perl/vms/perly_h.vms
@@ -1,4 +1,4 @@
-/* Postprocessed by vms_yfix.pl 1.1 to add VMS declarations of globals */
+/* Postprocessed by vms_yfix.pl 1.11 to add VMS declarations of globals */
#define WORD 257
#define METHOD 258
#define FUNCMETH 259
@@ -27,35 +27,36 @@
#define FUNC0 282
#define FUNC1 283
#define FUNC 284
-#define RELOP 285
-#define EQOP 286
-#define MULOP 287
-#define ADDOP 288
-#define DOLSHARP 289
-#define DO 290
-#define LOCAL 291
-#define HASHBRACK 292
-#define NOAMP 293
-#define OROP 294
-#define ANDOP 295
-#define NOTOP 296
-#define LSTOP 297
-#define ASSIGNOP 298
-#define OROR 299
-#define ANDAND 300
-#define BITOROP 301
-#define BITANDOP 302
-#define UNIOP 303
-#define SHIFTOP 304
-#define MATCHOP 305
-#define UMINUS 306
-#define REFGEN 307
-#define POWOP 308
-#define PREINC 309
-#define PREDEC 310
-#define POSTINC 311
-#define POSTDEC 312
-#define ARROW 313
+#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;
diff --git a/gnu/usr.bin/perl/vms/sockadapt.c b/gnu/usr.bin/perl/vms/sockadapt.c
index 08251d6bdfe..b63e4c937bc 100644
--- a/gnu/usr.bin/perl/vms/sockadapt.c
+++ b/gnu/usr.bin/perl/vms/sockadapt.c
@@ -1,28 +1,84 @@
/* sockadapt.c
*
* Author: Charles Bailey bailey@genetics.upenn.edu
- * Last Revised: 29-Jan-1996
+ * Last Revised: 4-Mar-1997
*
* This file should contain stubs for any of the TCP/IP functions perl5
* requires which are not supported by your TCP/IP stack. These stubs
* can attempt to emulate the routine in question, or can just return
* an error status or cause perl to die.
*
- * This version is set up for perl5 with socketshr 0.9D TCP/IP support.
+ * This version is set up for perl5 with UCX (or emulation) via
+ * the DECCRTL or SOCKETSHR 0.9D.
*/
#include "EXTERN.h"
#include "perl.h"
+
#if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000)
+# define __sockadapt_my_hostent_t __struct_hostent_ptr32
# define __sockadapt_my_netent_t __struct_netent_ptr32
+# define __sockadapt_my_servent_t __struct_servent_ptr32
# define __sockadapt_my_addr_t __in_addr_t
# define __sockadapt_my_name_t const char *
#else
+# define __sockadapt_my_hostent_t struct hostent *
# define __sockadapt_my_netent_t struct netent *
+# define __sockadapt_my_servent_t struct servent *
# define __sockadapt_my_addr_t long
# define __sockadapt_my_name_t char *
#endif
+/* We have these on VMS 7.0 and above, or on Dec C 5.6 if it's providing */
+/* the 7.0 DECC RTL */
+#if ((((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)) && defined(DECCRTL_SOCKETS))
+#else
+void setnetent(int stayopen) {
+ croak("Function \"setnetent\" not implemented in this version of perl");
+}
+void endnetent() {
+ croak("Function \"endnetent\" not implemented in this version of perl");
+}
+#endif
+
+#if defined(DECCRTL_SOCKETS)
+ /* Use builtin socket interface in DECCRTL and
+ * UCX emulation in whatever TCP/IP stack is present.
+ */
+
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#else
+ void sethostent(int stayopen) {
+ croak("Function \"sethostent\" not implemented in this version of perl");
+ }
+ void endhostent() {
+ croak("Function \"endhostent\" not implemented in this version of perl");
+ }
+ void setprotoent(int stayopen) {
+ croak("Function \"setprotoent\" not implemented in this version of perl");
+ }
+ void endprotoent() {
+ croak("Function \"endprotoent\" not implemented in this version of perl");
+ }
+ void setservent(int stayopen) {
+ croak("Function \"setservent\" not implemented in this version of perl");
+ }
+ void endservent() {
+ croak("Function \"endservent\" not implemented in this version of perl");
+ }
+ __sockadapt_my_hostent_t gethostent() {
+ croak("Function \"gethostent\" not implemented in this version of perl");
+ return (__sockadapt_my_hostent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
+ }
+ __sockadapt_my_servent_t getservent() {
+ croak("Function \"getservent\" not implemented in this version of perl");
+ return (__sockadapt_my_servent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
+ }
+#endif
+
+#else
+ /* Work around things missing/broken in SOCKETSHR. */
+
__sockadapt_my_netent_t getnetbyaddr( __sockadapt_my_addr_t net, int type) {
croak("Function \"getnetbyaddr\" not implemented in this version of perl");
return (struct netent *)NULL; /* Avoid MISSINGRETURN warning, not reached */
@@ -33,11 +89,29 @@ __sockadapt_my_netent_t getnetbyname( __sockadapt_my_name_t name) {
}
__sockadapt_my_netent_t getnetent() {
croak("Function \"getnetent\" not implemented in this version of perl");
- return (struct netent *)NULL; /* Avoid MISSINGRETURN warning, not reached */
+ return (__sockadapt_my_netent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
}
-void setnetent() {
- croak("Function \"setnetent\" not implemented in this version of perl");
-}
-void endnetent() {
- croak("Function \"endnetent\" not implemented in this version of perl");
+
+/* Some TCP/IP implementations seem to return success, when getpeername()
+ * is called on a UDP socket, but the port and in_addr are all zeroes.
+ */
+
+int my_getpeername(int sock, struct sockaddr *addr, int *addrlen) {
+ static 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";
+ int rslt;
+
+ rslt = si_getpeername(sock, addr, addrlen);
+
+ /* Just pass an error back up the line */
+ if (rslt) return rslt;
+
+ /* If the call succeeded, make sure we don't have a zeroed port/addr */
+ if (addr->sa_family == AF_INET &&
+ !memcmp((char *)addr + sizeof(u_short), nowhere,
+ sizeof(u_short) + sizeof(struct in_addr))) {
+ rslt = -1;
+ SETERRNO(ENOTCONN,SS$_CLEARED);
+ }
+ return rslt;
}
+#endif /* SOCKETSHR stuff */
diff --git a/gnu/usr.bin/perl/vms/sockadapt.h b/gnu/usr.bin/perl/vms/sockadapt.h
index 18f4002f127..7f9150a5795 100644
--- a/gnu/usr.bin/perl/vms/sockadapt.h
+++ b/gnu/usr.bin/perl/vms/sockadapt.h
@@ -2,7 +2,7 @@
*
* Authors: Charles Bailey bailey@genetics.upenn.edu
* David Denholm denholm@conmat.phys.soton.ac.uk
- * Last Revised: 17-Mar-1995
+ * Last Revised: 4-Mar-1997
*
* This file should include any other header files and procide any
* declarations, typedefs, and prototypes needed by perl for TCP/IP
@@ -11,15 +11,39 @@
* This version is set up for perl5 with socketshr 0.9D TCP/IP support.
*/
-/* SocketShr doesn't support these routines, but the DECC RTL contains
- * stubs with these names, designed to be used with the UCX socket
- * library. We avoid linker collisions by substituting new names.
- */
-#define getnetbyaddr no_getnetbyaddr
-#define getnetbyname no_getnetbyname
-#define getnetent no_getnetent
-#define setnetent no_setnetent
-#define endnetent no_endnetent
+#ifndef __SOCKADAPT_INCLUDED
+#define __SOCKADAPT_INCLUDED 1
+
+#if defined(DECCRTL_SOCKETS)
+ /* Use builtin socket interface in DECCRTL and
+ * UCX emulation in whatever TCP/IP stack is present.
+ * Provide prototypes for missing routines; stubs are
+ * in sockadapt.c.
+ */
+# include <socket.h>
+# include <inet.h>
+# include <in.h>
+# include <netdb.h>
+#if ((__VMS_VER >= 70000000) && (__DECC_VER >= 50200000)) || (__CRTL_VER >= 70000000)
+#else
+ void sethostent(int);
+ void endhostent(void);
+ void setnetent(int);
+ void endnetent(void);
+ void setprotoent(int);
+ void endprotoent(void);
+ void setservent(int);
+ void endservent(void);
+#endif
+# if defined(__DECC) && defined(__DECC_VER) && (__DECC_VER >= 50200000)
+# define Sock_size_t unsigned int
+# endif
+
+#else
+ /* Pull in SOCKETSHR's header, and set up structures for
+ * gcc, whose basic header file set doesn't include the
+ * TCP/IP stuff.
+ */
#ifdef __GNU_CC__
@@ -109,7 +133,7 @@ struct netent {
struct netent *getnetbyaddr( long net, int type);
struct netent *getnetbyname( char *name);
struct netent *getnetent();
-void setnetent();
+void setnetent(int);
void endnetent();
#else /* !__GNU_CC__ */
@@ -122,14 +146,24 @@ void endnetent();
#include <in.h>
#include <inet.h>
#include <netdb.h>
-/* However, we don't have these two in the system headers. */
-void setnetent();
-void endnetent();
+/* SocketShr doesn't support these routines, but the DECC RTL contains
+ * stubs with these names, designed to be used with the UCX socket
+ * library. We avoid linker collisions by substituting new names.
+ */
+#define getnetbyaddr no_getnetbyaddr
+#define getnetbyname no_getnetbyname
+#define getnetent no_getnetent
+#define setnetent no_setnetent
+#define endnetent no_endnetent
#endif
+/* We don't have these two in the system headers. */
+void setnetent(int);
+void endnetent();
+
#include <socketshr.h>
-/* socketshr.h from SocketShr 0.9D doesn't alias fileno; it's comments say
+/* socketshr.h from SocketShr 0.9D doesn't alias fileno; its comments say
* that the CRTL version works OK. This isn't the case, at least with
* VAXC, so we use the SocketShr version.
* N.B. This means that sockadapt.h must be included *after* stdio.h.
@@ -140,3 +174,14 @@ void endnetent();
#endif
#define fileno si_fileno
int si_fileno(FILE *);
+
+
+/* Catch erroneous results for UDP sockets -- see sockadapt.c */
+#ifdef getpeername
+# undef getpeername
+#endif
+#define getpeername my_getpeername
+int my_getpeername _((int, struct sockaddr *, int *));
+
+#endif /* SOCKETSHR stuff */
+#endif /* include guard */
diff --git a/gnu/usr.bin/perl/vms/test.com b/gnu/usr.bin/perl/vms/test.com
index 05ff0bba6c7..114cb24a405 100644
--- a/gnu/usr.bin/perl/vms/test.com
+++ b/gnu/usr.bin/perl/vms/test.com
@@ -6,6 +6,7 @@ $
$! A little basic setup
$ On Error Then Goto wrapup
$ olddef = F$Environment("Default")
+$ oldmsg = F$Environment("Message")
$ If F$Search("t.dir").nes.""
$ Then
$ Set Default [.t]
@@ -18,14 +19,17 @@ $ Write Sys$Error "Can't find test directory"
$ Exit 44
$ EndIf
$ EndIf
+$ Set Message /Facility/Severity/Identification/Text
$
+$ exe = ".Exe"
+$ If p1.nes."" Then exe = p1
$! Pick up a copy of perl to use for the tests
$ Delete/Log/NoConfirm Perl.;*
-$ Copy/Log/NoConfirm [-]Perl.Exe []Perl.
+$ Copy/Log/NoConfirm [-]Perl'exe' []Perl.
$
$! Make the environment look a little friendlier to tests which assume Unix
$ cat = "Type"
-$ Macro/NoDebug/Object=Echo.Obj Sys$Input
+$ Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input
.title echo
.psect data,wrt,noexe
dsc:
@@ -65,14 +69,14 @@ $ Macro/NoDebug/Object=Echo.Obj Sys$Input
movl #1,r0
ret
.end echo
-$ Link/NoTrace Echo.Obj;
+$ Link/NoMap/NoTrace/Exe=Echo.Exe Echo.Obj;
$ Delete/Log/NoConfirm Echo.Obj;*
$ echo = "$" + F$Parse("Echo.Exe")
$
$! And do it
$ testdir = "Directory/NoHead/NoTrail/Column=1"
-$ Define/User Perlshr Sys$Disk:[-]PerlShr.Exe
-$ MCR Sys$Disk:[]Perl. "''p1'" "''p2'" "''p3'" "''p4'" "''p5'" "''p6'"
+$ Define/User Perlshr Sys$Disk:[-]PerlShr'exe'
+$ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p2'" "''p3'" "''p4'" "''p5'" "''p6'"
$ Deck/Dollar=$$END-OF-TEST$$
# $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $
# Modified for VMS 30-Sep-1994 Charles Bailey bailey@genetics.upenn.edu
@@ -81,12 +85,25 @@ $ Deck/Dollar=$$END-OF-TEST$$
# most of the constructs we'll be testing for.
# skip those tests we know will fail entirely or cause perl to hang bacause
-# of Unixisms
-@compexcl=('cpp.t','script.t');
+# of Unixisms in the tests. (The Perl operators being tested may work fine,
+# but the tests may use other operators which don't.)
+use Config;
+
+@compexcl=('cpp.t');
@ioexcl=('argv.t','dup.t','fs.t','inplace.t','pipe.t');
@libexcl=('anydbm.t','db-btree.t','db-hash.t','db-recno.t',
- 'gdbm.t','ndbm.t','odbm.t','sdbm.t','posix.t','soundex.t');
-@opexcl=('exec.t','fork.t','glob.t','magic.t','misc.t','stat.t');
+ 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_sel.t', 'io_sock.t',
+ 'ndbm.t','odbm.t','open2.t','open3.t','posix.t',
+ 'sdbm.t');
+
+# Note: POSIX is not part of basic build, but can be built
+# separately if you're using DECC
+# io_xs.t tests the new_tmpfile routine, which doesn't work with the
+# VAXCRTL, since the file can't be stat()d, an Perl's do_open()
+# insists on stat()ing a file descriptor before it'll use it.
+push(@libexcl,'io_xs.t') if $Config{'vms_cc_type'} ne 'decc';
+
+@opexcl=('exec.t','fork.t','glob.t','groups.t','magic.t','misc.t','stat.t');
@exclist=(@compexcl,@ioexcl,@libexcl,@opexcl);
foreach $file (@exclist) { $skip{$file}++; }
@@ -131,6 +148,8 @@ while ($test = shift) {
close(script);
if (/#!..perl(.*)/) {
$switch = $1;
+ # Add "" to protect uppercase switches on command line
+ $switch =~ s/-(\S*[A-Z]\S*)/"-$1"/g;
} else {
$switch = '';
}
@@ -162,8 +181,13 @@ while ($test = shift) {
}
$next = $next - 1;
if ($ok && $next == $max) {
- print "${te}ok\n";
- $good = $good + 1;
+ if ($max) {
+ print "${te}ok\n";
+ $good = $good + 1;
+ } else {
+ print "${te}skipping test on this platform\n";
+ $files -= 1;
+ }
} else {
$next += 1;
print "${te}FAILED on test $next\n";
@@ -196,4 +220,5 @@ $$END-OF-TEST$$
$ wrapup:
$ If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;*
$ Set Default &olddef
+$ Set Message 'oldmsg'
$ Exit
diff --git a/gnu/usr.bin/perl/vms/vms.c b/gnu/usr.bin/perl/vms/vms.c
index 150747f52d2..f22579066d0 100644
--- a/gnu/usr.bin/perl/vms/vms.c
+++ b/gnu/usr.bin/perl/vms/vms.c
@@ -2,8 +2,8 @@
*
* VMS-specific routines for perl5
*
- * Last revised: 21-Jun-1996 by Charles Bailey bailey@genetics.upenn.edu
- * Version: 5.2.2
+ * Last revised: 11-Apr-1997 by Charles Bailey bailey@genetics.upenn.edu
+ * Version: 5.3.97c
*/
#include <acedef.h>
@@ -28,11 +28,23 @@
#include <shrdef.h>
#include <ssdef.h>
#include <starlet.h>
-#include <stsdef.h>
+#include <strdef.h>
+#include <str$routines.h>
#include <syidef.h>
#include <uaidef.h>
#include <uicdef.h>
+/* Older versions of ssdef.h don't have these */
+#ifndef SS$_INVFILFOROP
+# define SS$_INVFILFOROP 3930
+#endif
+#ifndef SS$_NOSUCHOBJECT
+# define SS$_NOSUCHOBJECT 2696
+#endif
+
+/* Don't replace system definitions of vfork, getenv, and stat,
+ * code below needs to get to the underlying CRTL routines. */
+#define DONT_MASK_RTL_CALLS
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
@@ -75,6 +87,9 @@ my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
{LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
{0, 0, 0, 0}};
+ if (!lnm || idx > LNM$_MAX_INDEX) {
+ set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
+ }
if (!eqv) eqv = __my_trnlnm_eqv;
lnmlst[1].bufadr = (void *)eqv;
lnmdsc.dsc$a_pointer = lnm;
@@ -85,7 +100,7 @@ my_trnlnm(char *lnm, char *eqv, unsigned long int idx)
}
else if (retsts & 1) {
eqv[eqvlen] = '\0';
- return 1;
+ return eqvlen;
}
_ckvmssts(retsts); /* Must be an error */
return 0; /* Not reached, assuming _ckvmssts() bails out */
@@ -105,8 +120,9 @@ char *
my_getenv(char *lnm)
{
static char __my_getenv_eqv[LNM$C_NAMLENGTH+1];
- char uplnm[LNM$C_NAMLENGTH], *cp1, *cp2;
+ char uplnm[LNM$C_NAMLENGTH+1], *cp1, *cp2;
unsigned long int idx = 0;
+ int trnsuccess;
for (cp1 = lnm, cp2= uplnm; *cp1; cp1++, cp2++) *cp2 = _toupper(*cp1);
*cp2 = '\0';
@@ -119,9 +135,10 @@ my_getenv(char *lnm)
*cp2 = '\0';
idx = strtoul(cp2+1,NULL,0);
}
- if (my_trnlnm(uplnm,__my_getenv_eqv,idx)) {
- return __my_getenv_eqv;
- }
+ trnsuccess = my_trnlnm(uplnm,__my_getenv_eqv,idx);
+ /* If we had a translation index, we're only interested in lnms */
+ if (!trnsuccess && cp2 != NULL) return Nullch;
+ if (trnsuccess) return __my_getenv_eqv;
else {
unsigned long int retsts;
struct dsc$descriptor_s symdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
@@ -137,7 +154,7 @@ my_getenv(char *lnm)
_ckvmssts(retsts);
}
/* Try for CRTL emulation of a Unix/POSIX name */
- else return getenv(lnm);
+ else return getenv(uplnm);
}
}
return Nullch;
@@ -145,6 +162,70 @@ my_getenv(char *lnm)
} /* end of my_getenv() */
/*}}}*/
+static FILE *safe_popen(char *, char *);
+
+/*{{{ void prime_env_iter() */
+void
+prime_env_iter(void)
+/* Fill the %ENV associative array with all logical names we can
+ * find, in preparation for iterating over it.
+ */
+{
+ static int primed = 0; /* XXX Not thread-safe!!! */
+ HV *envhv = GvHVn(envgv);
+ FILE *sholog;
+ char eqv[LNM$C_NAMLENGTH+1],*start,*end;
+ STRLEN eqvlen;
+ SV *oldrs, *linesv, *eqvsv;
+
+ if (primed) return;
+ /* Perform a dummy fetch as an lval to insure that the hash table is
+ * set up. Otherwise, the hv_store() will turn into a nullop */
+ (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
+ /* Also, set up the four "special" keys that the CRTL defines,
+ * whether or not underlying logical names exist. */
+ (void) hv_fetch(envhv,"HOME",4,TRUE);
+ (void) hv_fetch(envhv,"TERM",4,TRUE);
+ (void) hv_fetch(envhv,"PATH",4,TRUE);
+ (void) hv_fetch(envhv,"USER",4,TRUE);
+
+ /* Now, go get the logical names */
+ if ((sholog = safe_popen("$ Show Logical *","r")) == Nullfp)
+ _ckvmssts(vaxc$errno);
+ /* We use Perl's sv_gets to read from the pipe, since safe_popen is
+ * tied to Perl's I/O layer, so it may not return a simple FILE * */
+ oldrs = rs;
+ rs = newSVpv("\n",1);
+ linesv = newSVpv("",0);
+ while (1) {
+ if ((start = sv_gets(linesv,sholog,0)) == Nullch) {
+ my_pclose(sholog);
+ SvREFCNT_dec(linesv); SvREFCNT_dec(rs); rs = oldrs;
+ primed = 1;
+ return;
+ }
+ while (*start != '"' && *start != '=' && *start) start++;
+ if (*start != '"') continue;
+ for (end = ++start; *end && *end != '"'; end++) ;
+ if (*end) *end = '\0';
+ else end = Nullch;
+ if ((eqvlen = my_trnlnm(start,eqv,0)) == 0) {
+ if (vaxc$errno == SS$_NOLOGNAM || vaxc$errno == SS$_IVLOGNAM) {
+ if (dowarn)
+ warn("Ill-formed logical name |%s| in prime_env_iter",start);
+ continue;
+ }
+ else _ckvmssts(vaxc$errno);
+ }
+ else {
+ eqvsv = newSVpv(eqv,eqvlen);
+ hv_store(envhv,start,(end ? end - start : strlen(start)),eqvsv,0);
+ }
+ }
+} /* end of prime_env_iter */
+/*}}}*/
+
+
/*{{{ void my_setenv(char *lnm, char *eqv)*/
void
my_setenv(char *lnm,char *eqv)
@@ -244,6 +325,7 @@ my_crypt(const char *textpasswd, const char *usrname)
/*}}}*/
+static char *do_rmsexpand(char *, char *, int, char *, unsigned);
static char *do_fileify_dirspec(char *, char *, int);
static char *do_tovmsspec(char *, char *, int);
@@ -253,7 +335,7 @@ do_rmdir(char *name)
{
char dirfile[NAM$C_MAXRSS+1];
int retval;
- struct stat st;
+ struct mystat st;
if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1;
if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1;
@@ -275,7 +357,7 @@ do_rmdir(char *name)
int
kill_file(char *name)
{
- char vmsname[NAM$C_MAXRSS+1];
+ char vmsname[NAM$C_MAXRSS+1], rspec[NAM$C_MAXRSS+1];
unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
@@ -296,20 +378,41 @@ kill_file(char *name)
lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
- if (!remove(name)) return 0; /* Can we just get rid of it? */
+ /* Expand the input spec using RMS, since the CRTL remove() and
+ * system services won't do this by themselves, so we may miss
+ * a file "hiding" behind a logical name or search list. */
+ if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
+ if (do_rmsexpand(vmsname,rspec,1,NULL,0) == NULL) return -1;
+ if (!remove(rspec)) return 0; /* Can we just get rid of it? */
+ /* If not, can changing protections help? */
+ if (vaxc$errno != RMS$_PRV) return -1;
/* No, so we get our own UIC to use as a rights identifier,
* and the insert an ACE at the head of the ACL which allows us
* to delete the file.
*/
_ckvmssts(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
- if (do_tovmsspec(name,vmsname,0) == NULL) return -1;
- fildsc.dsc$w_length = strlen(vmsname);
- fildsc.dsc$a_pointer = vmsname;
+ fildsc.dsc$w_length = strlen(rspec);
+ fildsc.dsc$a_pointer = rspec;
cxt = 0;
newace.myace$l_ident = oldace.myace$l_ident;
if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
- set_errno(EVMSERR);
+ switch (aclsts) {
+ case RMS$_FNF:
+ case RMS$_DNF:
+ case RMS$_DIR:
+ case SS$_NOSUCHOBJECT:
+ set_errno(ENOENT); break;
+ case RMS$_DEV:
+ set_errno(ENODEV); break;
+ case RMS$_SYN:
+ case SS$_INVFILFOROP:
+ set_errno(EINVAL); break;
+ case RMS$_PRV:
+ set_errno(EACCES); break;
+ default:
+ _ckvmssts(aclsts);
+ }
set_vaxc_errno(aclsts);
return -1;
}
@@ -334,10 +437,13 @@ kill_file(char *name)
}
yourroom:
- if (rmsts) {
- fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
- if (aclsts & 1) aclsts = fndsts;
- }
+ fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
+ /* We just deleted it, so of course it's not there. Some versions of
+ * VMS seem to return success on the unlock operation anyhow (after all
+ * the unlock is successful), but others don't.
+ */
+ if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
+ if (aclsts & 1) aclsts = fndsts;
if (!(aclsts & 1)) {
set_errno(EVMSERR);
set_vaxc_errno(aclsts);
@@ -349,163 +455,28 @@ kill_file(char *name)
} /* end of kill_file() */
/*}}}*/
-/* my_utime - update modification time of a file
- * calling sequence is identical to POSIX utime(), but under
- * VMS only the modification time is changed; ODS-2 does not
- * maintain access times. Restrictions differ from the POSIX
- * definition in that the time can be changed as long as the
- * caller has permission to execute the necessary IO$_MODIFY $QIO;
- * no separate checks are made to insure that the caller is the
- * owner of the file or has special privs enabled.
- * Code here is based on Joe Meadows' FILE utility.
- */
-/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
- * to VMS epoch (01-JAN-1858 00:00:00.00)
- * in 100 ns intervals.
- */
-static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
-
-/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
-int my_utime(char *file, struct utimbuf *utimes)
+/*{{{int my_mkdir(char *,Mode_t)*/
+int
+my_mkdir(char *dir, Mode_t mode)
{
- register int i;
- long int bintime[2], len = 2, lowbit, unixtime,
- secscale = 10000000; /* seconds --> 100 ns intervals */
- unsigned long int chan, iosb[2], retsts;
- char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
- struct FAB myfab = cc$rms_fab;
- struct NAM mynam = cc$rms_nam;
-#if defined (__DECC) && defined (__VAX)
- /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
- * at least through VMS V6.1, which causes a type-conversion warning.
- */
-# pragma message save
-# pragma message disable cvtdiftypes
-#endif
- struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
- struct fibdef myfib;
-#if defined (__DECC) && defined (__VAX)
- /* This should be right after the declaration of myatr, but due
- * to a bug in VAX DEC C, this takes effect a statement early.
- */
-# pragma message restore
-#endif
- struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
- devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
- fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
+ STRLEN dirlen = strlen(dir);
- if (file == NULL || *file == '\0') {
- set_errno(ENOENT);
- set_vaxc_errno(LIB$_INVARG);
- return -1;
- }
- if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
-
- if (utimes != NULL) {
- /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
- * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
- * Since time_t is unsigned long int, and lib$emul takes a signed long int
- * as input, we force the sign bit to be clear by shifting unixtime right
- * one bit, then multiplying by an extra factor of 2 in lib$emul().
- */
- lowbit = (utimes->modtime & 1) ? secscale : 0;
- unixtime = (long int) utimes->modtime;
- unixtime >> 1; secscale << 1;
- retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
- if (!(retsts & 1)) {
- set_errno(EVMSERR);
- set_vaxc_errno(retsts);
- return -1;
- }
- retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
- if (!(retsts & 1)) {
- set_errno(EVMSERR);
- set_vaxc_errno(retsts);
- return -1;
- }
- }
- else {
- /* Just get the current time in VMS format directly */
- retsts = sys$gettim(bintime);
- if (!(retsts & 1)) {
- set_errno(EVMSERR);
- set_vaxc_errno(retsts);
- return -1;
- }
- }
-
- myfab.fab$l_fna = vmsspec;
- myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
- myfab.fab$l_nam = &mynam;
- mynam.nam$l_esa = esa;
- mynam.nam$b_ess = (unsigned char) sizeof esa;
- mynam.nam$l_rsa = rsa;
- mynam.nam$b_rss = (unsigned char) sizeof rsa;
-
- /* Look for the file to be affected, letting RMS parse the file
- * specification for us as well. I have set errno using only
- * values documented in the utime() man page for VMS POSIX.
+ /* CRTL mkdir() doesn't tolerate trailing /, since that implies
+ * null file name/type. However, it's commonplace under Unix,
+ * so we'll allow it for a gain in portability.
*/
- retsts = sys$parse(&myfab,0,0);
- if (!(retsts & 1)) {
- set_vaxc_errno(retsts);
- if (retsts == RMS$_PRV) set_errno(EACCES);
- else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
- else set_errno(EVMSERR);
- return -1;
- }
- retsts = sys$search(&myfab,0,0);
- if (!(retsts & 1)) {
- set_vaxc_errno(retsts);
- if (retsts == RMS$_PRV) set_errno(EACCES);
- else if (retsts == RMS$_FNF) set_errno(ENOENT);
- else set_errno(EVMSERR);
- return -1;
+ if (dir[dirlen-1] == '/') {
+ char *newdir = savepvn(dir,dirlen-1);
+ int ret = mkdir(newdir,mode);
+ Safefree(newdir);
+ return ret;
}
-
- devdsc.dsc$w_length = mynam.nam$b_dev;
- devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
-
- retsts = sys$assign(&devdsc,&chan,0,0);
- if (!(retsts & 1)) {
- set_vaxc_errno(retsts);
- if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
- else if (retsts == SS$_NOPRIV) set_errno(EACCES);
- else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
- else set_errno(EVMSERR);
- return -1;
- }
-
- fnmdsc.dsc$a_pointer = mynam.nam$l_name;
- fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
-
- memset((void *) &myfib, 0, sizeof myfib);
-#ifdef __DECC
- for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
- for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
- /* This prevents the revision time of the file being reset to the current
- * time as a result of our IO$_MODIFY $QIO. */
- myfib.fib$l_acctl = FIB$M_NORECORD;
-#else
- for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
- for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
- myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
-#endif
- retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
- _ckvmssts(sys$dassgn(chan));
- if (retsts & 1) retsts = iosb[0];
- if (!(retsts & 1)) {
- set_vaxc_errno(retsts);
- if (retsts == SS$_NOPRIV) set_errno(EACCES);
- else set_errno(EVMSERR);
- return -1;
- }
-
- return 0;
-} /* end of my_utime() */
+ else return mkdir(dir,mode);
+} /* end of my_mkdir */
/*}}}*/
+
static void
create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
{
@@ -532,7 +503,7 @@ create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
struct pipe_details
{
struct pipe_details *next;
- FILE *fp; /* stdio file pointer to pipe mailbox */
+ PerlIO *fp; /* stdio file pointer to pipe mailbox */
int pid; /* PID of subprocess */
int mode; /* == 'r' if pipe open for reading */
int done; /* subprocess has completed */
@@ -555,7 +526,8 @@ static int waitpid_asleep = 0;
static unsigned long int
pipe_exit_routine()
{
- unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT, sts;
+ unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
+ int sts;
while (open_pipes != NULL) {
if (!open_pipes->done) { /* Tap them gently on the shoulder . . .*/
@@ -564,7 +536,8 @@ pipe_exit_routine()
}
if (!open_pipes->done) /* We tried to be nice . . . */
_ckvmssts(sys$delprc(&open_pipes->pid,0));
- if (!((sts = my_pclose(open_pipes->fp))&1)) retsts = sts;
+ if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
+ else if (!(sts & 1)) retsts = sts;
}
return retsts;
}
@@ -584,9 +557,8 @@ popen_completion_ast(struct pipe_details *thispipe)
}
}
-/*{{{ FILE *my_popen(char *cmd, char *mode)*/
-FILE *
-my_popen(char *cmd, char *mode)
+static FILE *
+safe_popen(char *cmd, char *mode)
{
static int handler_set_up = FALSE;
char mbxname[64];
@@ -606,13 +578,13 @@ my_popen(char *cmd, char *mode)
return Nullfp;
}
- New(7001,info,1,struct pipe_details);
+ New(1301,info,1,struct pipe_details);
/* create mailbox */
create_mbx(&chan,&namdsc);
/* open a FILE* onto it */
- info->fp=fopen(mbxname, mode);
+ info->fp = PerlIO_open(mbxname, mode);
/* give up other channel onto it */
_ckvmssts(sys$dassgn(chan));
@@ -644,7 +616,18 @@ my_popen(char *cmd, char *mode)
forkprocess = info->pid;
return info->fp;
+} /* end of safe_popen */
+
+
+/*{{{ FILE *my_popen(char *cmd, char *mode)*/
+FILE *
+my_popen(char *cmd, char *mode)
+{
+ TAINT_ENV();
+ TAINT_PROPER("popen");
+ return safe_popen(cmd,mode);
}
+
/*}}}*/
/*{{{ I32 my_pclose(FILE *fp)*/
@@ -656,11 +639,35 @@ I32 my_pclose(FILE *fp)
for (info = open_pipes; info != NULL; last = info, info = info->next)
if (info->fp == fp) break;
- if (info == NULL)
- /* get here => no such pipe open */
- croak("No such pipe open");
+ if (info == NULL) { /* no such pipe open */
+ set_errno(ECHILD); /* quoth POSIX */
+ set_vaxc_errno(SS$_NONEXPR);
+ return -1;
+ }
- fclose(info->fp);
+ /* If we were writing to a subprocess, insure that someone reading from
+ * the mailbox gets an EOF. It looks like a simple fclose() doesn't
+ * produce an EOF record in the mailbox. */
+ if (info->mode != 'r') {
+ char devnam[NAM$C_MAXRSS+1], *cp;
+ unsigned long int chan, iosb[2], retsts, retsts2;
+ struct dsc$descriptor devdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, devnam};
+
+ if (fgetname(info->fp,devnam)) {
+ /* It oughta be a mailbox, so fgetname should give just the device
+ * name, but just in case . . . */
+ if ((cp = strrchr(devnam,':')) != NULL) *(cp+1) = '\0';
+ devdsc.dsc$w_length = strlen(devnam);
+ _ckvmssts(sys$assign(&devdsc,&chan,0,0));
+ retsts = sys$qiow(0,chan,IO$_WRITEOF,iosb,0,0,0,0,0,0,0,0);
+ if (retsts & 1) retsts = iosb[0];
+ retsts2 = sys$dassgn(chan); /* Be sure to deassign the channel */
+ if (retsts & 1) retsts = retsts2;
+ _ckvmssts(retsts);
+ }
+ else _ckvmssts(vaxc$errno); /* Should never happen */
+ }
+ PerlIO_close(info->fp);
if (info->done) retsts = info->completion;
else waitpid(info->pid,(int *) &retsts,0);
@@ -675,9 +682,9 @@ I32 my_pclose(FILE *fp)
} /* end of my_pclose() */
/* sort-of waitpid; use only with popen() */
-/*{{{unsigned long int waitpid(unsigned long int pid, int *statusp, int flags)*/
-unsigned long int
-waitpid(unsigned long int pid, int *statusp, int flags)
+/*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
+Pid_t
+my_waitpid(Pid_t pid, int *statusp, int flags)
{
struct pipe_details *info;
@@ -734,6 +741,14 @@ my_gconvert(double val, int ndig, int trail, char *buf)
char *loc;
loc = buf ? buf : __gcvtbuf;
+
+#ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
+ if (val < 1) {
+ sprintf(loc,"%.*g",ndig,val);
+ return loc;
+ }
+#endif
+
if (val) {
if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
return gcvt(val,ndig,loc);
@@ -746,6 +761,129 @@ my_gconvert(double val, int ndig, int trail, char *buf)
}
/*}}}*/
+
+/*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
+/* Shortcut for common case of simple calls to $PARSE and $SEARCH
+ * to expand file specification. Allows for a single default file
+ * specification and a simple mask of options. If outbuf is non-NULL,
+ * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
+ * the resultant file specification is placed. If outbuf is NULL, the
+ * resultant file specification is placed into a static buffer.
+ * The third argument, if non-NULL, is taken to be a default file
+ * specification string. The fourth argument is unused at present.
+ * rmesexpand() returns the address of the resultant string if
+ * successful, and NULL on error.
+ */
+static char *do_tounixspec(char *, char *, int);
+
+static char *
+do_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
+{
+ static char __rmsexpand_retbuf[NAM$C_MAXRSS+1];
+ char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1];
+ char esa[NAM$C_MAXRSS], *cp, *out = NULL;
+ struct FAB myfab = cc$rms_fab;
+ struct NAM mynam = cc$rms_nam;
+ STRLEN speclen;
+ unsigned long int retsts, haslower = 0, isunix = 0;
+
+ if (!filespec || !*filespec) {
+ set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
+ return NULL;
+ }
+ if (!outbuf) {
+ if (ts) out = New(1319,outbuf,NAM$C_MAXRSS+1,char);
+ else outbuf = __rmsexpand_retbuf;
+ }
+ if ((isunix = (strchr(filespec,'/') != NULL))) {
+ if (do_tovmsspec(filespec,vmsfspec,0) == NULL) return NULL;
+ filespec = vmsfspec;
+ }
+
+ myfab.fab$l_fna = filespec;
+ myfab.fab$b_fns = strlen(filespec);
+ myfab.fab$l_nam = &mynam;
+
+ if (defspec && *defspec) {
+ if (strchr(defspec,'/') != NULL) {
+ if (do_tovmsspec(defspec,tmpfspec,0) == NULL) return NULL;
+ defspec = tmpfspec;
+ }
+ myfab.fab$l_dna = defspec;
+ myfab.fab$b_dns = strlen(defspec);
+ }
+
+ mynam.nam$l_esa = esa;
+ mynam.nam$b_ess = sizeof esa;
+ mynam.nam$l_rsa = outbuf;
+ mynam.nam$b_rss = NAM$C_MAXRSS;
+
+ retsts = sys$parse(&myfab,0,0);
+ if (!(retsts & 1)) {
+ if (retsts == RMS$_DNF || retsts == RMS$_DIR ||
+ retsts == RMS$_DEV || retsts == RMS$_DEV) {
+ mynam.nam$b_nop |= NAM$M_SYNCHK;
+ retsts = sys$parse(&myfab,0,0);
+ if (retsts & 1) goto expanded;
+ }
+ if (out) Safefree(out);
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else if (retsts == RMS$_DEV) set_errno(ENODEV);
+ else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
+ else set_errno(EVMSERR);
+ return NULL;
+ }
+ retsts = sys$search(&myfab,0,0);
+ if (!(retsts & 1) && retsts != RMS$_FNF) {
+ if (out) Safefree(out);
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else set_errno(EVMSERR);
+ return NULL;
+ }
+
+ /* If the input filespec contained any lowercase characters,
+ * downcase the result for compatibility with Unix-minded code. */
+ expanded:
+ for (out = myfab.fab$l_fna; *out; out++)
+ if (islower(*out)) { haslower = 1; break; }
+ if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; }
+ else { out = esa; speclen = mynam.nam$b_esl; }
+ if (!(mynam.nam$l_fnb & NAM$M_EXP_VER) &&
+ (!defspec || !*defspec || !strchr(myfab.fab$l_dna,';')))
+ speclen = mynam.nam$l_ver - out;
+ /* If we just had a directory spec on input, $PARSE "helpfully"
+ * adds an empty name and type for us */
+ if (mynam.nam$l_name == mynam.nam$l_type &&
+ mynam.nam$l_ver == mynam.nam$l_type + 1 &&
+ !(mynam.nam$l_fnb & NAM$M_EXP_NAME))
+ speclen = mynam.nam$l_name - out;
+ out[speclen] = '\0';
+ if (haslower) __mystrtolower(out);
+
+ /* Have we been working with an expanded, but not resultant, spec? */
+ /* Also, convert back to Unix syntax if necessary. */
+ if (!mynam.nam$b_rsl) {
+ if (isunix) {
+ if (do_tounixspec(esa,outbuf,0) == NULL) return NULL;
+ }
+ else strcpy(outbuf,esa);
+ }
+ else if (isunix) {
+ if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL;
+ strcpy(outbuf,tmpfspec);
+ }
+ return outbuf;
+}
+/*}}}*/
+/* External entry points */
+char *rmsexpand(char *spec, char *buf, char *def, unsigned opt)
+{ return do_rmsexpand(spec,buf,0,def,opt); }
+char *rmsexpand_ts(char *spec, char *buf, char *def, unsigned opt)
+{ return do_rmsexpand(spec,buf,1,def,opt); }
+
+
/*
** The following routines are provided to make life easier when
** converting among VMS-style and Unix-style directory specifications.
@@ -780,13 +918,11 @@ my_gconvert(double val, int ndig, int trail, char *buf)
** found in the Perl standard distribution.
*/
-static char *do_tounixspec(char *, char *, int);
-
/*{{{ char *fileify_dirspec[_ts](char *path, char *buf)*/
static char *do_fileify_dirspec(char *dir,char *buf,int ts)
{
static char __fileify_retbuf[NAM$C_MAXRSS+1];
- unsigned long int dirlen, retlen, addmfd = 0;
+ unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
char *retspec, *cp1, *cp2, *lastdir;
char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
@@ -822,7 +958,24 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
dir[dirlen-1] = ']';
}
- if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
+ if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
+ /* If we've got an explicit filename, we can just shuffle the string. */
+ if (*(cp1+1)) hasfilename = 1;
+ /* Similarly, we can just back up a level if we've got multiple levels
+ of explicit directories in a VMS spec which ends with directories. */
+ else {
+ for (cp2 = cp1; cp2 > dir; cp2--) {
+ if (*cp2 == '.') {
+ *cp2 = *cp1; *cp1 = '\0';
+ hasfilename = 1;
+ break;
+ }
+ if (*cp2 == '[' || *cp2 == '<') break;
+ }
+ }
+ }
+
+ if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
if (dir[0] == '.') {
if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
return do_fileify_dirspec("[]",buf,ts);
@@ -849,25 +1002,22 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
} while ((cp1 = strstr(cp1,"/.")) != NULL);
}
else {
- if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
+ if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
+ !(lastdir = cp1 = strrchr(dir,']')) &&
+ !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
- if (toupper(*(cp2+1)) == 'D' && /* Yep. Is it .dir? */
- toupper(*(cp2+2)) == 'I' &&
- toupper(*(cp2+3)) == 'R') {
- if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
- if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
- set_errno(ENOTDIR); /* Bzzt. */
- set_vaxc_errno(RMS$_DIR);
- return NULL;
- }
- }
- dirlen = cp2 - dir;
- }
- else { /* There's a type, and it's not .dir. Bzzt. */
- set_errno(ENOTDIR);
+ int ver; char *cp3;
+ if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
+ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
+ !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
+ (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
+ (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
+ (ver || *cp3)))))) {
+ set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
}
+ dirlen = cp2 - dir;
}
}
/* If we lead off with a device or rooted logical, add the MFD
@@ -883,7 +1033,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
}
retlen = dirlen + (addmfd ? 13 : 6);
if (buf) retspec = buf;
- else if (ts) New(7009,retspec,retlen+1,char);
+ else if (ts) New(1309,retspec,retlen+1,char);
else retspec = __fileify_retbuf;
if (addmfd) {
dirlen = lastdir - dir;
@@ -964,7 +1114,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
if (dirnam.nam$l_fnb & NAM$M_EXP_NAME) {
/* They provided at least the name; we added the type, if necessary, */
if (buf) retspec = buf; /* in sys$parse() */
- else if (ts) New(7011,retspec,dirnam.nam$b_esl+1,char);
+ else if (ts) New(1311,retspec,dirnam.nam$b_esl+1,char);
else retspec = __fileify_retbuf;
strcpy(retspec,esa);
return retspec;
@@ -983,7 +1133,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
/* There's more than one directory in the path. Just roll back. */
*cp1 = term;
if (buf) retspec = buf;
- else if (ts) New(7011,retspec,retlen+7,char);
+ else if (ts) New(1311,retspec,retlen+7,char);
else retspec = __fileify_retbuf;
strcpy(retspec,esa);
}
@@ -998,7 +1148,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
}
retlen = dirnam.nam$b_esl - 9; /* esa - '][' - '].DIR;1' */
if (buf) retspec = buf;
- else if (ts) New(7012,retspec,retlen+16,char);
+ else if (ts) New(1312,retspec,retlen+16,char);
else retspec = __fileify_retbuf;
cp1 = strstr(esa,"][");
dirlen = cp1 - esa;
@@ -1026,7 +1176,7 @@ static char *do_fileify_dirspec(char *dir,char *buf,int ts)
}
else { /* This is a top-level dir. Add the MFD to the path. */
if (buf) retspec = buf;
- else if (ts) New(7012,retspec,retlen+16,char);
+ else if (ts) New(1312,retspec,retlen+16,char);
else retspec = __fileify_retbuf;
cp1 = esa;
cp2 = retspec;
@@ -1073,7 +1223,7 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
/* Trap simple rooted lnms, and return lnm:[000000] */
if (!strcmp(trndir+trnlen-2,".]")) {
if (buf) retpath = buf;
- else if (ts) New(7018,retpath,strlen(dir)+10,char);
+ else if (ts) New(1318,retpath,strlen(dir)+10,char);
else retpath = __pathify_retbuf;
strcpy(retpath,dir);
strcat(retpath,":[000000]");
@@ -1082,30 +1232,38 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
}
dir = trndir;
- if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
+ if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
if (*dir == '.' && (*(dir+1) == '\0' ||
(*(dir+1) == '.' && *(dir+2) == '\0')))
retlen = 2 + (*(dir+1) != '\0');
else {
- if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
- if ((cp2 = strchr(cp1,'.')) && (*(cp2+1) != '.' && *(cp2+1) != '\0')) {
- if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
- toupper(*(cp2+2)) == 'I' && /* Trim it off. */
- toupper(*(cp2+3)) == 'R') {
- retlen = cp2 - dir + 1;
- }
- else { /* Some other file type. Bzzt. */
+ if ( !(cp1 = strrchr(dir,'/')) &&
+ !(cp1 = strrchr(dir,']')) &&
+ !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
+ if ((cp2 = strchr(cp1,'.')) != NULL &&
+ (*(cp2-1) != '/' || /* Trailing '.', '..', */
+ !(*(cp2+1) == '\0' || /* or '...' are dirs. */
+ (*(cp2+1) == '.' && *(cp2+2) == '\0') ||
+ (*(cp2+1) == '.' && *(cp2+2) == '.' && *(cp2+3) == '\0')))) {
+ int ver; char *cp3;
+ if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
+ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
+ !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
+ (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
+ (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
+ (ver || *cp3)))))) {
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
}
+ retlen = cp2 - dir + 1;
}
else { /* No file type present. Treat the filename as a directory. */
retlen = strlen(dir) + 1;
}
}
if (buf) retpath = buf;
- else if (ts) New(7013,retpath,retlen+1,char);
+ else if (ts) New(1313,retpath,retlen+1,char);
else retpath = __pathify_retbuf;
strncpy(retpath,dir,retlen-1);
if (retpath[retlen-2] != '/') { /* If the path doesn't already end */
@@ -1120,13 +1278,37 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
struct FAB dirfab = cc$rms_fab;
struct NAM savnam, dirnam = cc$rms_nam;
+ /* If we've got an explicit filename, we can just shuffle the string. */
+ if ( ( (cp1 = strrchr(dir,']')) != NULL ||
+ (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
+ if ((cp2 = strchr(cp1,'.')) != NULL) {
+ int ver; char *cp3;
+ if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
+ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
+ !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
+ (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
+ (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
+ (ver || *cp3)))))) {
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
+ return NULL;
+ }
+ }
+ else { /* No file type, so just draw name into directory part */
+ for (cp2 = cp1; *cp2; cp2++) ;
+ }
+ *cp2 = *cp1;
+ *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
+ *cp1 = '.';
+ /* We've now got a VMS 'path'; fall through */
+ }
dirfab.fab$b_fns = strlen(dir);
dirfab.fab$l_fna = dir;
if (dir[dirfab.fab$b_fns-1] == ']' ||
dir[dirfab.fab$b_fns-1] == '>' ||
dir[dirfab.fab$b_fns-1] == ':') { /* It's already a VMS 'path' */
if (buf) retpath = buf;
- else if (ts) New(7014,retpath,strlen(dir)+1,char);
+ else if (ts) New(1314,retpath,strlen(dir)+1,char);
else retpath = __pathify_retbuf;
strcpy(retpath,dir);
return retpath;
@@ -1183,7 +1365,7 @@ static char *do_pathify_dirspec(char *dir,char *buf, int ts)
*(dirnam.nam$l_type + 1) = '\0';
retlen = dirnam.nam$l_type - esa + 2;
if (buf) retpath = buf;
- else if (ts) New(7014,retpath,retlen,char);
+ else if (ts) New(1314,retpath,retlen,char);
else retpath = __pathify_retbuf;
strcpy(retpath,esa);
/* $PARSE may have upcased filespec, so convert output to lower
@@ -1205,7 +1387,7 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
{
static char __tounixspec_retbuf[NAM$C_MAXRSS+1];
char *dirend, *rslt, *cp1, *cp2, *cp3, tmp[NAM$C_MAXRSS+1];
- int devlen, dirlen, retlen = NAM$C_MAXRSS+1, dashes = 0;
+ int devlen, dirlen, retlen = NAM$C_MAXRSS+1, expand = 0;
if (spec == NULL) return NULL;
if (strlen(spec) > NAM$C_MAXRSS) return NULL;
@@ -1215,9 +1397,13 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
cp1 = strchr(spec,'[');
if (!cp1) cp1 = strchr(spec,'<');
if (cp1) {
- for (cp1++; *cp1 == '-'; cp1++) dashes++; /* VMS '-' ==> Unix '../' */
+ for (cp1++; *cp1; cp1++) {
+ if (*cp1 == '-') expand++; /* VMS '-' ==> Unix '../' */
+ if (*cp1 == '.' && *(cp1+1) == '.' && *(cp1+2) == '.')
+ { expand++; cp1 +=2; } /* VMS '...' ==> Unix '/.../' */
+ }
}
- New(7015,rslt,retlen+2+2*dashes,char);
+ New(1315,rslt,retlen+2+2*expand,char);
}
else rslt = __tounixspec_retbuf;
if (strchr(spec,'/') != NULL) {
@@ -1240,11 +1426,10 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
else { /* the VMS spec begins with directories */
cp2++;
if (*cp2 == ']' || *cp2 == '>') {
- strcpy(rslt,"./");
+ *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
return rslt;
}
- else if ( *cp2 != '.' && *cp2 != '-') {
- *(cp1++) = '/'; /* add the implied device into the Unix spec */
+ else if ( *cp2 != '.' && *cp2 != '-') { /* add the implied device */
if (getcwd(tmp,sizeof tmp,1) == NULL) {
if (ts) Safefree(rslt);
return NULL;
@@ -1255,26 +1440,36 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
*(cp3++) = '\0';
if (strchr(cp3,']') != NULL) break;
} while (((cp3 = my_getenv(tmp)) != NULL) && strcpy(tmp,cp3));
- cp3 = tmp;
- while (*cp3) *(cp1++) = *(cp3++);
- *(cp1++) = '/';
- if (ts &&
+ if (ts && !buf &&
((devlen = strlen(tmp)) + (dirlen = strlen(cp2)) + 1 > retlen)) {
- int offset = cp1 - rslt;
-
retlen = devlen + dirlen;
- Renew(rslt,retlen+1+2*dashes,char);
- cp1 = rslt + offset;
+ Renew(rslt,retlen+1+2*expand,char);
+ cp1 = rslt;
+ }
+ cp3 = tmp;
+ *(cp1++) = '/';
+ while (*cp3) {
+ *(cp1++) = *(cp3++);
+ if (cp1 - rslt > NAM$C_MAXRSS && !ts && !buf) return NULL; /* No room */
}
+ *(cp1++) = '/';
+ }
+ else if ( *cp2 == '.') {
+ if (*(cp2+1) == '.' && *(cp2+2) == '.') {
+ *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
+ cp2 += 3;
+ }
+ else cp2++;
}
- else if (*cp2 == '.') cp2++;
}
for (; cp2 <= dirend; cp2++) {
if (*cp2 == ':') {
*(cp1++) = '/';
if (*(cp2+1) == '[') cp2++;
}
- else if (*cp2 == ']' || *cp2 == '>') *(cp1++) = '/';
+ else if (*cp2 == ']' || *cp2 == '>') {
+ if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
+ }
else if (*cp2 == '.') {
*(cp1++) = '/';
if (*(cp2+1) == ']' || *(cp2+1) == '>') {
@@ -1283,6 +1478,10 @@ static char *do_tounixspec(char *spec, char *buf, int ts)
if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
*(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
}
+ else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
+ *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
+ cp2 += 2;
+ }
}
else if (*cp2 == '-') {
if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
@@ -1320,7 +1519,7 @@ static char *do_tovmsspec(char *path, char *buf, int ts) {
if (path == NULL) return NULL;
if (buf) rslt = buf;
- else if (ts) New(7016,rslt,strlen(path)+9,char);
+ else if (ts) New(1316,rslt,strlen(path)+9,char);
else rslt = __tovmsspec_retbuf;
if (strpbrk(path,"]:>") ||
(dirend = strrchr(path,'/')) == NULL) {
@@ -1332,9 +1531,10 @@ static char *do_tovmsspec(char *path, char *buf, int ts) {
else strcpy(rslt,path);
return rslt;
}
- if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.."? */
+ if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
if (!*(dirend+2)) dirend +=2;
if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
+ if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
}
cp1 = rslt;
cp2 = path;
@@ -1343,7 +1543,7 @@ static char *do_tovmsspec(char *path, char *buf, int ts) {
int islnm, rooted;
STRLEN trnend;
- while (*(++cp2) == '/') ; /* Skip multiple /s */
+ while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
*cp1 = '\0';
islnm = my_trnlnm(rslt,trndev,0);
@@ -1383,6 +1583,12 @@ static char *do_tovmsspec(char *path, char *buf, int ts) {
*(cp1++) = '-'; /* "../" --> "-" */
cp2 += 3;
}
+ else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
+ (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
+ *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
+ if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
+ cp2 += 4;
+ }
if (cp2 > dirend) cp2 = dirend;
}
else *(cp1++) = '.';
@@ -1410,6 +1616,16 @@ static char *do_tovmsspec(char *path, char *buf, int ts) {
cp2 += 2;
if (cp2 == dirend) break;
}
+ else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
+ (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
+ if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
+ *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
+ if (!*(cp2+3)) {
+ *(cp1++) = '.'; /* Simulate trailing '/' */
+ cp2 += 2; /* for loop will incr this to == dirend */
+ }
+ else cp2 += 3; /* Trailing '/' was there, so skip it, too */
+ }
else *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
}
else {
@@ -1445,7 +1661,7 @@ static char *do_tovmspath(char *path, char *buf, int ts) {
if (buf) return buf;
else if (ts) {
vmslen = strlen(vmsified);
- New(7017,cp,vmslen+1,char);
+ New(1317,cp,vmslen+1,char);
memcpy(cp,vmsified,vmslen);
cp[vmslen] = '\0';
return cp;
@@ -1474,7 +1690,7 @@ static char *do_tounixpath(char *path, char *buf, int ts) {
if (buf) return buf;
else if (ts) {
unixlen = strlen(unixified);
- New(7017,cp,unixlen+1,char);
+ New(1317,cp,unixlen+1,char);
memcpy(cp,unixified,unixlen);
cp[unixlen] = '\0';
return cp;
@@ -1543,7 +1759,7 @@ static int background_process(int argc, char **argv);
static void pipe_and_fork(char **cmargv);
/*{{{ void getredirection(int *ac, char ***av)*/
-void
+static void
getredirection(int *ac, char ***av)
/*
* Process vms redirection arg's. Exit if any error is seen.
@@ -1604,7 +1820,7 @@ getredirection(int *ac, char ***av)
{
if (j+1 >= argc)
{
- fprintf(stderr,"No input file after < on command line");
+ PerlIO_printf(Perl_debug_log,"No input file after < on command line");
exit(LIB$_WRONUMARG);
}
in = argv[++j];
@@ -1619,7 +1835,7 @@ getredirection(int *ac, char ***av)
{
if (j+1 >= argc)
{
- fprintf(stderr,"No output file after > on command line");
+ PerlIO_printf(Perl_debug_log,"No output file after > on command line");
exit(LIB$_WRONUMARG);
}
out = argv[++j];
@@ -1639,7 +1855,7 @@ getredirection(int *ac, char ***av)
out = 1 + ap;
if (j >= argc)
{
- fprintf(stderr,"No output file after > or >> on command line");
+ PerlIO_printf(Perl_debug_log,"No output file after > or >> on command line");
exit(LIB$_WRONUMARG);
}
continue;
@@ -1661,7 +1877,7 @@ getredirection(int *ac, char ***av)
err = 2 + ap;
if (j >= argc)
{
- fprintf(stderr,"No output file after 2> or 2>> on command line");
+ PerlIO_printf(Perl_debug_log,"No output file after 2> or 2>> on command line");
exit(LIB$_WRONUMARG);
}
continue;
@@ -1670,7 +1886,7 @@ getredirection(int *ac, char ***av)
{
if (j+1 >= argc)
{
- fprintf(stderr,"No command into which to pipe on command line");
+ PerlIO_printf(Perl_debug_log,"No command into which to pipe on command line");
exit(LIB$_WRONUMARG);
}
cmargc = argc-(j+1);
@@ -1692,7 +1908,7 @@ getredirection(int *ac, char ***av)
* Allocate and fill in the new argument vector, Some Unix's terminate
* the list with an extra null pointer.
*/
- New(7002, argv, item_count+1, char *);
+ New(1302, argv, item_count+1, char *);
*av = argv;
for (j = 0; j < item_count; ++j, list_head = list_head->next)
argv[j] = list_head->value;
@@ -1701,7 +1917,7 @@ getredirection(int *ac, char ***av)
{
if (out != NULL)
{
- fprintf(stderr,"'|' and '>' may not both be specified on command line");
+ PerlIO_printf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
exit(LIB$_INVARGORD);
}
pipe_and_fork(cmargv);
@@ -1720,7 +1936,7 @@ getredirection(int *ac, char ***av)
/* Input from a pipe, reopen it in binary mode to disable */
/* carriage control processing. */
- fgetname(stdin, mbxname,1);
+ PerlIO_getname(stdin, mbxname);
mbxnam.dsc$a_pointer = mbxname;
mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
@@ -1734,38 +1950,41 @@ getredirection(int *ac, char ***av)
freopen(mbxname, "rb", stdin);
if (errno != 0)
{
- fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
+ PerlIO_printf(Perl_debug_log,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
exit(vaxc$errno);
}
}
if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
{
- fprintf(stderr,"Can't open input file %s as stdin",in);
+ PerlIO_printf(Perl_debug_log,"Can't open input file %s as stdin",in);
exit(vaxc$errno);
}
if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
{
- fprintf(stderr,"Can't open output file %s as stdout",out);
+ PerlIO_printf(Perl_debug_log,"Can't open output file %s as stdout",out);
exit(vaxc$errno);
}
if (err != NULL) {
FILE *tmperr;
if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
{
- fprintf(stderr,"Can't open error file %s as stderr",err);
+ PerlIO_printf(Perl_debug_log,"Can't open error file %s as stderr",err);
exit(vaxc$errno);
}
fclose(tmperr);
- if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
+ if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
{
exit(vaxc$errno);
}
}
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "Arglist:\n");
+ PerlIO_printf(Perl_debug_log, "Arglist:\n");
for (j = 0; j < *ac; ++j)
- fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
+ PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
#endif
+ /* Clear errors we may have hit expanding wildcards, so they don't
+ show up in Perl's $! later */
+ set_errno(0); set_vaxc_errno(1);
} /* end of getredirection() */
/*}}}*/
@@ -1776,11 +1995,11 @@ static void add_item(struct list_item **head,
{
if (*head == 0)
{
- New(7003,*head,1,struct list_item);
+ New(1303,*head,1,struct list_item);
*tail = *head;
}
else {
- New(7004,(*tail)->next,1,struct list_item);
+ New(1304,(*tail)->next,1,struct list_item);
*tail = (*tail)->next;
}
(*tail)->value = value;
@@ -1805,7 +2024,7 @@ $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
$DESCRIPTOR(resultspec, "");
unsigned long int zero = 0, sts;
- if (strcspn(item, "*%") == strlen(item))
+ if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
{
add_item(head, tail, item, count);
return;
@@ -1834,7 +2053,7 @@ unsigned long int zero = 0, sts;
char *string;
char *c;
- New(7005,string,resultspec.dsc$w_length+1,char);
+ New(1305,string,resultspec.dsc$w_length+1,char);
strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
string[resultspec.dsc$w_length] = '\0';
if (NULL == had_version)
@@ -1852,7 +2071,7 @@ unsigned long int zero = 0, sts;
for (c = string; *c; ++c)
if (isupper(*c))
*c = tolower(*c);
- if (isunix) trim_unixpath(string,item);
+ if (isunix) trim_unixpath(string,item,1);
add_item(head, tail, string, count);
++expcount;
}
@@ -1862,22 +2081,24 @@ unsigned long int zero = 0, sts;
switch (sts)
{
case RMS$_FNF:
+ case RMS$_DNF:
case RMS$_DIR:
set_errno(ENOENT); break;
case RMS$_DEV:
set_errno(ENODEV); break;
+ case RMS$_FNM:
case RMS$_SYN:
set_errno(EINVAL); break;
case RMS$_PRV:
set_errno(EACCES); break;
default:
- _ckvmssts(sts);
+ _ckvmssts_noperl(sts);
}
}
if (expcount == 0)
add_item(head, tail, item, count);
- _ckvmssts(lib$sfree1_dd(&resultspec));
- _ckvmssts(lib$find_file_end(&context));
+ _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
+ _ckvmssts_noperl(lib$find_file_end(&context));
}
static int child_st[2];/* Event Flag set when child process completes */
@@ -1891,7 +2112,7 @@ short iosb[4];
if (0 == child_st[0])
{
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
+ PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
#endif
fflush(stdout); /* Have to flush pipe for binary data to */
/* terminate properly -- <tp@mccall.com> */
@@ -1906,7 +2127,7 @@ short iosb[4];
static void sig_child(int chan)
{
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "Child Completion AST\n");
+ PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
#endif
if (child_st[0] == 0)
child_st[0] = 1;
@@ -1942,19 +2163,19 @@ static void pipe_and_fork(char **cmargv)
create_mbx(&child_chan,&mbxdsc);
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
- fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
+ PerlIO_printf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
+ PerlIO_printf(Perl_debug_log, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
#endif
- _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
- 0, &pid, child_st, &zero, sig_child,
- &child_chan));
+ _ckvmssts_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
+ 0, &pid, child_st, &zero, sig_child,
+ &child_chan));
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
+ PerlIO_printf(Perl_debug_log, "Subprocess's Pid = %08X\n", pid);
#endif
sys$dclexh(&exit_block);
if (NULL == freopen(mbxname, "wb", stdout))
{
- fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
+ PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
}
}
@@ -1979,19 +2200,19 @@ unsigned long int flags = 17, one = 1, retsts;
}
value.dsc$a_pointer = command;
value.dsc$w_length = strlen(value.dsc$a_pointer);
- _ckvmssts(lib$set_symbol(&cmd, &value));
+ _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
- _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
+ _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
}
else {
- _ckvmssts(retsts);
+ _ckvmssts_noperl(retsts);
}
#ifdef ARGPROC_DEBUG
- fprintf(stderr, "%s\n", command);
+ PerlIO_printf(Perl_debug_log, "%s\n", command);
#endif
sprintf(pidstring, "%08X", pid);
- fprintf(stderr, "%s\n", pidstring);
+ PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
pidstr.dsc$a_pointer = pidstring;
pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
lib$set_symbol(&pidsymbol, &pidstr);
@@ -2000,6 +2221,34 @@ unsigned long int flags = 17, one = 1, retsts;
/*}}}*/
/***** End of code taken from Mark Pizzolato's argproc.c package *****/
+
+/* OS-specific initialization at image activation (not thread startup) */
+/*{{{void vms_image_init(int *, char ***)*/
+void
+vms_image_init(int *argcp, char ***argvp)
+{
+ unsigned long int *mask, iosb[2], i;
+ unsigned short int dummy;
+ union prvdef iprv;
+ struct itmlst_3 jpilist[2] = { {sizeof iprv, JPI$_IMAGPRIV, &iprv, &dummy},
+ { 0, 0, 0, 0} };
+
+ _ckvmssts(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
+ _ckvmssts(iosb[0]);
+ mask = (unsigned long int *) &iprv; /* Quick change of view */;
+ for (i = 0; i < (sizeof iprv + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i++) {
+ if (mask[i]) { /* Running image installed with privs? */
+ _ckvmssts(sys$setprv(0,&iprv,0,NULL)); /* Turn 'em off. */
+ tainting = TRUE;
+ break;
+ }
+ }
+ getredirection(argcp,argvp);
+ return;
+}
+/*}}}*/
+
+
/* trim_unixpath()
* Trim Unix-style prefix off filespec, so it looks like what a shell
* glob expansion would return (i.e. from specified prefix on, not
@@ -2007,23 +2256,26 @@ unsigned long int flags = 17, one = 1, retsts;
* of whether input filespec was VMS-style or Unix-style.
*
* fspec is filespec to be trimmed, and wildspec is wildcard spec used to
- * determine prefix (both may be in VMS or Unix syntax).
+ * determine prefix (both may be in VMS or Unix syntax). opts is a bit
+ * vector of options; at present, only bit 0 is used, and if set tells
+ * trim unixpath to try the current default directory as a prefix when
+ * presented with a possibly ambiguous ... wildcard.
*
* Returns !=0 on success, with trimmed filespec replacing contents of
* fspec, and 0 on failure, with contents of fpsec unchanged.
*/
-/*{{{int trim_unixpath(char *fspec, char *wildspec)*/
+/*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
int
-trim_unixpath(char *fspec, char *wildspec)
+trim_unixpath(char *fspec, char *wildspec, int opts)
{
char unixified[NAM$C_MAXRSS+1], unixwild[NAM$C_MAXRSS+1],
- *template, *base, *cp1, *cp2;
- register int tmplen, reslen = 0;
+ *template, *base, *end, *cp1, *cp2;
+ register int tmplen, reslen = 0, dirs = 0;
if (!wildspec || !fspec) return 0;
if (strpbrk(wildspec,"]>:") != NULL) {
if (do_tounixspec(wildspec,unixwild,0) == NULL) return 0;
- else template = unixified;
+ else template = unixwild;
}
else template = wildspec;
if (strpbrk(fspec,"]>:") != NULL) {
@@ -2045,63 +2297,112 @@ trim_unixpath(char *fspec, char *wildspec)
return 1;
}
- /* Find prefix to template consisting of path elements without wildcards */
- if ((cp1 = strpbrk(template,"*%?")) == NULL)
- for (cp1 = template; *cp1; cp1++) ;
- else while (cp1 > template && *cp1 != '/') cp1--;
- for (cp2 = base; *cp2; cp2++) ; /* Find end of resultant filespec */
-
- /* Wildcard was in first element, so we don't have a reliable string to
- * match against. Guess where to trim resultant filespec by counting
- * directory levels in the Unix template. (We could do this instead of
- * string matching in all cases, since Unix doesn't have a ... wildcard
- * that can expand into multiple levels of subdirectory, but we try for
- * the string match so our caller can interpret foo/.../bar.* as
- * [.foo...]bar.* if it wants, and only get burned if there was a
- * wildcard in the first word (in which case, caveat caller). */
- if (cp1 == template) {
- int subdirs = 0;
- for ( ; *cp1; cp1++) if (*cp1 == '/') subdirs++;
- /* need to back one more '/' than in template, to pick up leading dirname */
- subdirs++;
- while (cp2 > base) {
- if (*cp2 == '/') subdirs--;
- if (!subdirs) break; /* quit without decrement when we hit last '/' */
- cp2--;
- }
- /* ran out of directories on resultant; allow for already trimmed
- * resultant, which hits start of string looking for leading '/' */
- if (subdirs && (cp2 != base || subdirs != 1)) return 0;
- /* Move past leading '/', if there is one */
- base = cp2 + (*cp2 == '/' ? 1 : 0);
- tmplen = strlen(base);
- if (reslen && tmplen > reslen) return 0; /* not enough space */
- memmove(fspec,base,tmplen+1); /* copy result to fspec, with trailing NUL */
+ for (end = base; *end; end++) ; /* Find end of resultant filespec */
+ if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
+ for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
+ for (cp1 = end ;cp1 >= base; cp1--)
+ if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
+ { cp1++; break; }
+ if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
return 1;
}
- /* We have a prefix string of complete directory names, so we
- * try to find it on the resultant filespec */
- else {
- tmplen = cp1 - template;
- if (!memcmp(base,template,tmplen)) { /* Nothing before prefix; we're done */
- if (reslen) { /* we converted to Unix syntax; copy result over */
- tmplen = cp2 - base;
- if (tmplen > reslen) return 0; /* not enough space */
- memmove(fspec,base,tmplen+1); /* Copy trimmed spec + trailing NUL */
+ else {
+ char tpl[NAM$C_MAXRSS+1], lcres[NAM$C_MAXRSS+1];
+ char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
+ int ells = 1, totells, segdirs, match;
+ struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, tpl},
+ resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
+
+ while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
+ totells = ells;
+ for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
+ if (ellipsis == template && opts & 1) {
+ /* Template begins with an ellipsis. Since we can't tell how many
+ * directory names at the front of the resultant to keep for an
+ * arbitrary starting point, we arbitrarily choose the current
+ * default directory as a starting point. If it's there as a prefix,
+ * clip it off. If not, fall through and act as if the leading
+ * ellipsis weren't there (i.e. return shortest possible path that
+ * could match template).
+ */
+ if (getcwd(tpl, sizeof tpl,0) == NULL) return 0;
+ for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
+ if (_tolower(*cp1) != _tolower(*cp2)) break;
+ segdirs = dirs - totells; /* Min # of dirs we must have left */
+ for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
+ if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
+ memcpy(fspec,cp2+1,end - cp2);
+ return 1;
}
- return 1;
}
- for ( ; cp2 - base > tmplen; base++) {
- if (*base != '/') continue;
- if (!memcmp(base + 1,template,tmplen)) break;
+ /* First off, back up over constant elements at end of path */
+ if (dirs) {
+ for (front = end ; front >= base; front--)
+ if (*front == '/' && !dirs--) { front++; break; }
}
-
- if (cp2 - base == tmplen) return 0; /* Not there - not good */
- base++; /* Move past leading '/' */
- if (reslen && cp2 - base > reslen) return 0; /* not enough space */
- /* Copy down remaining portion of filespec, including trailing NUL */
- memmove(fspec,base,cp2 - base + 1);
+ for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcend + sizeof lcend;
+ cp1++,cp2++) *cp2 = _tolower(*cp1); /* Make lc copy for match */
+ if (cp1 != '\0') return 0; /* Path too long. */
+ lcend = cp2;
+ *cp2 = '\0'; /* Pick up with memcpy later */
+ lcfront = lcres + (front - base);
+ /* Now skip over each ellipsis and try to match the path in front of it. */
+ while (ells--) {
+ for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
+ if (*(cp1) == '.' && *(cp1+1) == '.' &&
+ *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
+ if (cp1 < template) break; /* template started with an ellipsis */
+ if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
+ ellipsis = cp1; continue;
+ }
+ wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
+ nextell = cp1;
+ for (segdirs = 0, cp2 = tpl;
+ cp1 <= ellipsis - 1 && cp2 <= tpl + sizeof tpl;
+ cp1++, cp2++) {
+ if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
+ else *cp2 = _tolower(*cp1); /* else lowercase for match */
+ if (*cp2 == '/') segdirs++;
+ }
+ if (cp1 != ellipsis - 1) return 0; /* Path too long */
+ /* Back up at least as many dirs as in template before matching */
+ for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
+ if (*cp1 == '/' && !segdirs--) { cp1++; break; }
+ for (match = 0; cp1 > lcres;) {
+ resdsc.dsc$a_pointer = cp1;
+ if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
+ match++;
+ if (match == 1) lcfront = cp1;
+ }
+ for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
+ }
+ if (!match) return 0; /* Can't find prefix ??? */
+ if (match > 1 && opts & 1) {
+ /* This ... wildcard could cover more than one set of dirs (i.e.
+ * a set of similar dir names is repeated). If the template
+ * contains more than 1 ..., upstream elements could resolve the
+ * ambiguity, but it's not worth a full backtracking setup here.
+ * As a quick heuristic, clip off the current default directory
+ * if it's present to find the trimmed spec, else use the
+ * shortest string that this ... could cover.
+ */
+ char def[NAM$C_MAXRSS+1], *st;
+
+ if (getcwd(def, sizeof def,0) == NULL) return 0;
+ for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
+ if (_tolower(*cp1) != _tolower(*cp2)) break;
+ segdirs = dirs - totells; /* Min # of dirs we must have left */
+ for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
+ if (*cp1 == '\0' && *cp2 == '/') {
+ memcpy(fspec,cp2+1,end - cp2);
+ return 1;
+ }
+ /* Nope -- stick with lcfront from above and keep going. */
+ }
+ }
+ memcpy(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
return 1;
+ ellipsis = nextell;
}
} /* end of trim_unixpath() */
@@ -2111,7 +2412,6 @@ trim_unixpath(char *fspec, char *wildspec)
/*
* VMS readdir() routines.
* Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
- * This code has no copyright.
*
* 21-Jul-1994 Charles Bailey bailey@genetics.upenn.edu
* Minor modifications to original routines.
@@ -2131,12 +2431,12 @@ opendir(char *name)
char dir[NAM$C_MAXRSS+1];
/* Get memory for the handle, and the pattern. */
- New(7006,dd,1,DIR);
+ New(1306,dd,1,DIR);
if (do_tovmspath(name,dir,0) == NULL) {
Safefree((char *)dd);
return(NULL);
}
- New(7007,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
+ New(1307,dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
/* Fill in the fields; mainly playing with the descriptor. */
(void)sprintf(dd->pattern, "%s*.*",dir);
@@ -2195,7 +2495,7 @@ collectversions(dd)
/* Add the version wildcard, ignoring the "*.*" put on before */
i = strlen(dd->pattern);
- New(7008,text,i + e->d_namlen + 3,char);
+ New(1308,text,i + e->d_namlen + 3,char);
(void)strcpy(text, dd->pattern);
(void)sprintf(&text[i - 3], "%s;*", e->d_name);
@@ -2525,6 +2825,8 @@ vms_do_exec(char *cmd)
{ /* no vfork - act VMSish */
unsigned long int retsts;
+ TAINT_ENV();
+ TAINT_PROPER("exec");
if ((retsts = setup_cmddsc(cmd,1)) & 1)
retsts = lib$do_command(&VMScmd);
@@ -2558,6 +2860,8 @@ do_spawn(char *cmd)
{
unsigned long int substs, hadcmd = 1;
+ TAINT_ENV();
+ TAINT_PROPER("spawn");
if (!cmd || !*cmd) {
hadcmd = 0;
_ckvmssts(lib$spawn(0,0,0,0,0,0,&substs,0,0,0,0,0,0));
@@ -2604,6 +2908,22 @@ my_fwrite(void *src, size_t itmsz, size_t nitm, FILE *dest)
} /* end of my_fwrite() */
/*}}}*/
+/*{{{ int my_flush(FILE *fp)*/
+int
+my_flush(FILE *fp)
+{
+ int res;
+ if ((res = fflush(fp)) == 0) {
+#ifdef VMS_DO_SOCKETS
+ struct mystat s;
+ if (Fstat(fileno(fp), &s) == 0 && !S_ISSOCK(s.st_mode))
+#endif
+ res = fsync(fileno(fp));
+ }
+ return res;
+}
+/*}}}*/
+
/*
* Here are replacements for the following Unix routines in the VMS environment:
* getpwuid Get information for a particular UIC or UID
@@ -2749,7 +3069,7 @@ struct passwd *my_getpwnam(char *name)
{
struct dsc$descriptor_s name_desc;
union uicdef uic;
- unsigned long int status, stat;
+ unsigned long int status, sts;
__pwdcache = __passwd_empty;
if (!fillpasswd(name, &__pwdcache)) {
@@ -2758,17 +3078,17 @@ struct passwd *my_getpwnam(char *name)
name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
name_desc.dsc$b_class= DSC$K_CLASS_S;
name_desc.dsc$a_pointer= (char *) name;
- if ((stat = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
+ if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
__pwdcache.pw_uid= uic.uic$l_uic;
__pwdcache.pw_gid= uic.uic$v_group;
}
else {
- if (stat == SS$_NOSUCHID || stat == SS$_IVIDENT || stat == RMS$_PRV) {
- set_vaxc_errno(stat);
- set_errno(stat == RMS$_PRV ? EACCES : EINVAL);
+ if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
+ set_vaxc_errno(sts);
+ set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
return NULL;
}
- else { _ckvmssts(stat); }
+ else { _ckvmssts(sts); }
}
}
strncpy(__pw_namecache, name, sizeof(__pw_namecache));
@@ -2857,57 +3177,297 @@ void my_endpwent()
}
/*}}}*/
-
-/* my_gmtime
- * If the CRTL has a real gmtime(), use it, else look for the logical
- * name SYS$TIMEZONE_DIFFERENTIAL used by the native UTC routines on
- * VMS >= 6.0. Can be manually defined under earlier versions of VMS
- * to translate to the number of seconds which must be added to UTC
- * to get to the local time of the system.
- * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
+#if __VMS_VER < 70000000 || __DECC_VER < 50200000
+/* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
+ * my_utime(), and flex_stat(), all of which operate on UTC unless
+ * VMSISH_TIMES is true.
*/
+/* method used to handle UTC conversions:
+ * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
+ */
+static int gmtime_emulation_type;
+/* number of secs to add to UTC POSIX-style time to get local time */
+static long int utc_offset_secs;
-/*{{{struct tm *my_gmtime(const time_t *time)*/
-/* We #defined 'gmtime' as 'my_gmtime' in vmsish.h. #undef it here
- * so we can call the CRTL's routine to see if it works.
+/* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
+ * in vmsish.h. #undef them here so we can call the CRTL routines
+ * directly.
*/
#undef gmtime
-struct tm *
-my_gmtime(const time_t *time)
+#undef localtime
+#undef time
+
+/* my_time(), my_localtime(), my_gmtime()
+ * By default traffic in UTC time values, suing CRTL gmtime() or
+ * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
+ * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
+ * Modified by Charles Bailey <bailey@genetics.upenn.edu>
+ */
+
+/*{{{time_t my_time(time_t *timep)*/
+time_t my_time(time_t *timep)
{
- static int gmtime_emulation_type;
- static time_t utc_offset_secs;
- char *p;
time_t when;
if (gmtime_emulation_type == 0) {
+ struct tm *tm_p;
+ time_t base = 15 * 86400; /* 15jan71; to avoid month ends */
+
gmtime_emulation_type++;
- when = 300000000;
- if (gmtime(&when) == NULL) { /* CRTL gmtime() is just a stub */
+ if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
+ char *off;
+
gmtime_emulation_type++;
- if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
+ if ((off = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL) {
gmtime_emulation_type++;
- else
- utc_offset_secs = (time_t) atol(p);
+ warn("no UTC offset information; assuming local time is UTC");
+ }
+ else { utc_offset_secs = atol(off); }
+ }
+ else { /* We've got a working gmtime() */
+ struct tm gmt, local;
+
+ gmt = *tm_p;
+ tm_p = localtime(&base);
+ local = *tm_p;
+ utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
+ utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
+ utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
+ utc_offset_secs += (local.tm_sec - gmt.tm_sec);
}
}
- switch (gmtime_emulation_type) {
- case 1:
- return gmtime(time);
- case 2:
- when = *time - utc_offset_secs;
- return localtime(&when);
- default:
- warn("gmtime not supported on this system");
- return NULL;
+ when = time(NULL);
+ if (
+# ifdef VMSISH_TIME
+ !VMSISH_TIME &&
+# endif
+ when != -1) when -= utc_offset_secs;
+ if (timep != NULL) *timep = when;
+ return when;
+
+} /* end of my_time() */
+/*}}}*/
+
+
+/*{{{struct tm *my_gmtime(const time_t *timep)*/
+struct tm *
+my_gmtime(const time_t *timep)
+{
+ char *p;
+ time_t when;
+
+ if (timep == NULL) {
+ set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
+ return NULL;
}
+ if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
+ if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
+
+ when = *timep;
+# ifdef VMSISH_TIME
+ if (VMSISH_TIME) when -= utc_offset_secs; /* Input was local time */
+# endif
+ /* CRTL localtime() wants local time as input, so does no tz correction */
+ return localtime(&when);
+
} /* end of my_gmtime() */
-/* Reset definition for later calls */
-#define gmtime(t) my_gmtime(t)
/*}}}*/
+/*{{{struct tm *my_localtime(const time_t *timep)*/
+struct tm *
+my_localtime(const time_t *timep)
+{
+ time_t when;
+
+ if (timep == NULL) {
+ set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
+ return NULL;
+ }
+ if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
+ if (gmtime_emulation_type == 0) (void) my_time(NULL); /* Init UTC */
+
+ when = *timep;
+# ifdef VMSISH_TIME
+ if (!VMSISH_TIME) when += utc_offset_secs; /* Input was UTC */
+# endif
+ /* CRTL localtime() wants local time as input, so does no tz correction */
+ return localtime(&when);
+
+} /* end of my_localtime() */
+/*}}}*/
+
+/* Reset definitions for later calls */
+#define gmtime(t) my_gmtime(t)
+#define localtime(t) my_localtime(t)
+#define time(t) my_time(t)
+
+#endif /* VMS VER < 7.0 || Dec C < 5.2
+
+/* my_utime - update modification time of a file
+ * calling sequence is identical to POSIX utime(), but under
+ * VMS only the modification time is changed; ODS-2 does not
+ * maintain access times. Restrictions differ from the POSIX
+ * definition in that the time can be changed as long as the
+ * caller has permission to execute the necessary IO$_MODIFY $QIO;
+ * no separate checks are made to insure that the caller is the
+ * owner of the file or has special privs enabled.
+ * Code here is based on Joe Meadows' FILE utility.
+ */
+
+/* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
+ * to VMS epoch (01-JAN-1858 00:00:00.00)
+ * in 100 ns intervals.
+ */
+static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
+
+/*{{{int my_utime(char *path, struct utimbuf *utimes)*/
+int my_utime(char *file, struct utimbuf *utimes)
+{
+ register int i;
+ long int bintime[2], len = 2, lowbit, unixtime,
+ secscale = 10000000; /* seconds --> 100 ns intervals */
+ unsigned long int chan, iosb[2], retsts;
+ char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
+ struct FAB myfab = cc$rms_fab;
+ struct NAM mynam = cc$rms_nam;
+#if defined (__DECC) && defined (__VAX)
+ /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
+ * at least through VMS V6.1, which causes a type-conversion warning.
+ */
+# pragma message save
+# pragma message disable cvtdiftypes
+#endif
+ struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
+ struct fibdef myfib;
+#if defined (__DECC) && defined (__VAX)
+ /* This should be right after the declaration of myatr, but due
+ * to a bug in VAX DEC C, this takes effect a statement early.
+ */
+# pragma message restore
+#endif
+ struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
+ devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
+ fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
+
+ if (file == NULL || *file == '\0') {
+ set_errno(ENOENT);
+ set_vaxc_errno(LIB$_INVARG);
+ return -1;
+ }
+ if (do_tovmsspec(file,vmsspec,0) == NULL) return -1;
+
+ if (utimes != NULL) {
+ /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
+ * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
+ * Since time_t is unsigned long int, and lib$emul takes a signed long int
+ * as input, we force the sign bit to be clear by shifting unixtime right
+ * one bit, then multiplying by an extra factor of 2 in lib$emul().
+ */
+ lowbit = (utimes->modtime & 1) ? secscale : 0;
+ unixtime = (long int) utimes->modtime;
+#if defined(VMSISH_TIME) && (__VMS_VER < 70000000 || __DECC_VER < 50200000)
+ if (!VMSISH_TIME) { /* Input was UTC; convert to local for sys svc */
+ if (!gmtime_emulation_type) (void) time(NULL); /* Initialize UTC */
+ unixtime += utc_offset_secs;
+ }
+# endif
+ unixtime >> 1; secscale << 1;
+ retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ }
+ else {
+ /* Just get the current time in VMS format directly */
+ retsts = sys$gettim(bintime);
+ if (!(retsts & 1)) {
+ set_errno(EVMSERR);
+ set_vaxc_errno(retsts);
+ return -1;
+ }
+ }
+
+ myfab.fab$l_fna = vmsspec;
+ myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
+ myfab.fab$l_nam = &mynam;
+ mynam.nam$l_esa = esa;
+ mynam.nam$b_ess = (unsigned char) sizeof esa;
+ mynam.nam$l_rsa = rsa;
+ mynam.nam$b_rss = (unsigned char) sizeof rsa;
+
+ /* Look for the file to be affected, letting RMS parse the file
+ * specification for us as well. I have set errno using only
+ * values documented in the utime() man page for VMS POSIX.
+ */
+ retsts = sys$parse(&myfab,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+ retsts = sys$search(&myfab,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == RMS$_PRV) set_errno(EACCES);
+ else if (retsts == RMS$_FNF) set_errno(ENOENT);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ devdsc.dsc$w_length = mynam.nam$b_dev;
+ devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
+
+ retsts = sys$assign(&devdsc,&chan,0,0);
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
+ else if (retsts == SS$_NOPRIV) set_errno(EACCES);
+ else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ fnmdsc.dsc$a_pointer = mynam.nam$l_name;
+ fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
+
+ memset((void *) &myfib, 0, sizeof myfib);
+#ifdef __DECC
+ for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
+ for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
+ /* This prevents the revision time of the file being reset to the current
+ * time as a result of our IO$_MODIFY $QIO. */
+ myfib.fib$l_acctl = FIB$M_NORECORD;
+#else
+ for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
+ for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
+ myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
+#endif
+ retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
+ _ckvmssts(sys$dassgn(chan));
+ if (retsts & 1) retsts = iosb[0];
+ if (!(retsts & 1)) {
+ set_vaxc_errno(retsts);
+ if (retsts == SS$_NOPRIV) set_errno(EACCES);
+ else set_errno(EVMSERR);
+ return -1;
+ }
+
+ return 0;
+} /* end of my_utime() */
+/*}}}*/
+
/*
* flex_stat, flex_fstat
* basic stat, but gets it right when asked to stat
@@ -2943,11 +3503,11 @@ my_gmtime(const time_t *time)
* on the first call.
*/
#define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
-static dev_t encode_dev (const char *dev)
+static mydev_t encode_dev (const char *dev)
{
int i;
unsigned long int f;
- dev_t enc;
+ mydev_t enc;
char c;
const char *q;
@@ -3011,14 +3571,15 @@ is_null_device(name)
/* Do the permissions allow some operation? Assumes statcache already set. */
/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
- * subset of the applicable information.
+ * subset of the applicable information. (We have to stick with struct
+ * stat instead of struct mystat in the prototype since we have to match
+ * the one in proto.h.)
*/
/*{{{I32 cando(I32 bit, I32 effective, struct stat *statbufp)*/
I32
cando(I32 bit, I32 effective, struct stat *statbufp)
{
- if (statbufp == &statcache)
- return cando_by_name(bit,effective,namecache);
+ if (statbufp == &statcache) return cando_by_name(bit,effective,namecache);
else {
char fname[NAM$C_MAXRSS+1];
unsigned long int retsts;
@@ -3027,13 +3588,13 @@ cando(I32 bit, I32 effective, struct stat *statbufp)
/* If the struct mystat is stale, we're OOL; stat() overwrites the
device name on successive calls */
- devdsc.dsc$a_pointer = statbufp->st_devnam;
- devdsc.dsc$w_length = strlen(statbufp->st_devnam);
+ devdsc.dsc$a_pointer = ((struct mystat *)statbufp)->st_devnam;
+ devdsc.dsc$w_length = strlen(((struct mystat *)statbufp)->st_devnam);
namdsc.dsc$a_pointer = fname;
namdsc.dsc$w_length = sizeof fname - 1;
- retsts = lib$fid_to_name(&devdsc,&(statbufp->st_ino),&namdsc,
- &namdsc.dsc$w_length,0,0);
+ retsts = lib$fid_to_name(&devdsc,&(((struct mystat *)statbufp)->st_ino),
+ &namdsc,&namdsc.dsc$w_length,0,0);
if (retsts & 1) {
fname[namdsc.dsc$w_length] = '\0';
return cando_by_name(bit,effective,fname);
@@ -3114,13 +3675,13 @@ cando_by_name(I32 bit, I32 effective, char *fname)
}
retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
-#ifndef SS$_NOSUCHOBJECT /* Older versions of ssdef.h don't have this */
-# define SS$_NOSUCHOBJECT 2696
-#endif
- if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
- retsts == RMS$_FNF || retsts == RMS$_DIR ||
- retsts == RMS$_DEV) {
- set_errno(retsts == SS$_NOPRIV ? EACCES : ENOENT); set_vaxc_errno(retsts);
+ if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
+ retsts == SS$_INVFILFOROP || retsts == RMS$_FNF ||
+ retsts == RMS$_DIR || retsts == RMS$_DEV) {
+ set_vaxc_errno(retsts);
+ if (retsts == SS$_NOPRIV) set_errno(EACCES);
+ else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
+ else set_errno(ENOENT);
return FALSE;
}
if (retsts == SS$_NORMAL) {
@@ -3144,34 +3705,41 @@ cando_by_name(I32 bit, I32 effective, char *fname)
/*}}}*/
-/*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
+/*{{{ int flex_fstat(int fd, struct mystat *statbuf)*/
int
-flex_fstat(int fd, struct stat *statbuf)
+flex_fstat(int fd, struct mystat *statbufp)
{
- char fspec[NAM$C_MAXRSS+1];
-
- if (!getname(fd,fspec,1)) return -1;
- return flex_stat(fspec,statbuf);
+ if (!fstat(fd,(stat_t *) statbufp)) {
+ if (statbufp == (struct mystat *) &statcache) *namecache == '\0';
+ statbufp->st_dev = encode_dev(statbufp->st_devnam);
+# ifdef VMSISH_TIME
+ if (!VMSISH_TIME) { /* Return UTC instead of local time */
+# else
+ if (1) {
+# endif
+#if __VMS_VER < 70000000 || __DECC_VER < 50200000
+ if (!gmtime_emulation_type) (void)time(NULL);
+ statbufp->st_mtime -= utc_offset_secs;
+ statbufp->st_atime -= utc_offset_secs;
+ statbufp->st_ctime -= utc_offset_secs;
+#endif
+ }
+ return 0;
+ }
+ return -1;
} /* end of flex_fstat() */
/*}}}*/
-/*{{{ int flex_stat(char *fspec, struct stat *statbufp)*/
-/* We defined 'stat' as 'mystat' in vmsish.h so that declarations of
- * 'struct stat' elsewhere in Perl would use our struct. We go back
- * to the system version here, since we're actually calling their
- * stat().
- */
-#undef stat
+/*{{{ int flex_stat(char *fspec, struct mystat *statbufp)*/
int
flex_stat(char *fspec, struct mystat *statbufp)
{
char fileified[NAM$C_MAXRSS+1];
- int retval,myretval;
- struct mystat tmpbuf;
+ int retval = -1;
-
- if (statbufp == &statcache) do_tovmsspec(fspec,namecache,0);
+ if (statbufp == (struct mystat *) &statcache)
+ do_tovmsspec(fspec,namecache,0);
if (is_null_device(fspec)) { /* Fake a stat() for the null device */
memset(statbufp,0,sizeof *statbufp);
statbufp->st_dev = encode_dev("_NLA0:");
@@ -3183,30 +3751,69 @@ flex_stat(char *fspec, struct mystat *statbufp)
return 0;
}
- if (do_fileify_dirspec(fspec,fileified,0) == NULL) myretval = -1;
- else {
- myretval = stat(fileified,(stat_t *) &tmpbuf);
- }
- retval = stat(fspec,(stat_t *) statbufp);
- if (!myretval) {
- if (retval == -1) {
- *statbufp = tmpbuf;
- retval = 0;
- }
- else if (!retval) { /* Dir with same name. Substitute it. */
- statbufp->st_mode &= ~S_IFDIR;
- statbufp->st_mode |= tmpbuf.st_mode & S_IFDIR;
+ /* Try for a directory name first. If fspec contains a filename without
+ * a type (e.g. sea:[dark.dark]water), and both sea:[wine.dark]water.dir
+ * and sea:[wine.dark]water. exist, we prefer the directory here.
+ * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
+ * not sea:[wine.dark]., if the latter exists. If the intended target is
+ * the file with null type, specify this by calling flex_stat() with
+ * a '.' at the end of fspec.
+ */
+ if (do_fileify_dirspec(fspec,fileified,0) != NULL) {
+ retval = stat(fileified,(stat_t *) statbufp);
+ if (!retval && statbufp == (struct mystat *) &statcache)
strcpy(namecache,fileified);
+ }
+ if (retval) retval = stat(fspec,(stat_t *) statbufp);
+ if (!retval) {
+ statbufp->st_dev = encode_dev(statbufp->st_devnam);
+# ifdef VMSISH_TIME
+ if (!VMSISH_TIME) { /* Return UTC instead of local time */
+# else
+ if (1) {
+# endif
+#if __VMS_VER < 70000000 || __DECC_VER < 50200000
+ if (!gmtime_emulation_type) (void)time(NULL);
+ statbufp->st_mtime -= utc_offset_secs;
+ statbufp->st_atime -= utc_offset_secs;
+ statbufp->st_ctime -= utc_offset_secs;
+#endif
}
}
- if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
return retval;
} /* end of flex_stat() */
-/* Reset definition for later calls */
-#define stat mystat
/*}}}*/
+/* Insures that no carriage-control translation will be done on a file. */
+/*{{{FILE *my_binmode(FILE *fp, char iotype)*/
+FILE *
+my_binmode(FILE *fp, char iotype)
+{
+ char filespec[NAM$C_MAXRSS], *acmode;
+ fpos_t pos;
+
+ if (!fgetname(fp,filespec)) return NULL;
+ if (iotype != '-' && fgetpos(fp,&pos) == -1) return NULL;
+ switch (iotype) {
+ case '<': case 'r': acmode = "rb"; break;
+ case '>': case 'w':
+ /* use 'a' instead of 'w' to avoid creating new file;
+ fsetpos below will take care of restoring file position */
+ case 'a': acmode = "ab"; break;
+ case '+': case '|': case 's': acmode = "rb+"; break;
+ case '-': acmode = fileno(fp) ? "ab" : "rb"; break;
+ default:
+ warn("Unrecognized iotype %c in my_binmode",iotype);
+ acmode = "rb+";
+ }
+ if (freopen(filespec,acmode,fp) == NULL) return NULL;
+ if (iotype != '-' && fsetpos(fp,&pos) == -1) return NULL;
+ return fp;
+} /* end of my_binmode() */
+/*}}}*/
+
+
/*{{{char *my_getlogin()*/
/* VMS cuserid == Unix getlogin, except calling sequence */
char *
@@ -3351,7 +3958,13 @@ rmscopy(char *spec_in, char *spec_out, int preserve_dates)
if (preserve_dates & 2) {
/* sys$close() will process xabrdt, not xabdat */
xabrdt = cc$rms_xabrdt;
+#ifndef __GNUC__
xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
+#else
+ /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
+ * is unsigned long[2], while DECC & VAXC use a struct */
+ memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
+#endif
fab_out.fab$l_xab = (void *) &xabrdt;
}
@@ -3412,49 +4025,18 @@ void
rmsexpand_fromperl(CV *cv)
{
dXSARGS;
- char esa[NAM$C_MAXRSS], rsa[NAM$C_MAXRSS], *cp, *out;
- struct FAB myfab = cc$rms_fab;
- struct NAM mynam = cc$rms_nam;
- STRLEN speclen;
- unsigned long int retsts, haslower = 0;
-
- myfab.fab$l_fna = SvPV(ST(0),speclen);
- myfab.fab$b_fns = speclen;
- myfab.fab$l_nam = &mynam;
-
- mynam.nam$l_esa = esa;
- mynam.nam$b_ess = sizeof esa;
- mynam.nam$l_rsa = rsa;
- mynam.nam$b_rss = sizeof rsa;
+ char *fspec, *defspec = NULL, *rslt;
- retsts = sys$parse(&myfab,0,0);
- if (!(retsts & 1)) {
- set_vaxc_errno(retsts);
- if (retsts == RMS$_PRV) set_errno(EACCES);
- else if (retsts == RMS$_DEV) set_errno(ENODEV);
- else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
- else set_errno(EVMSERR);
- XSRETURN_UNDEF;
- }
- retsts = sys$search(&myfab,0,0);
- if (!(retsts & 1) && retsts != RMS$_FNF) {
- set_vaxc_errno(retsts);
- if (retsts == RMS$_PRV) set_errno(EACCES);
- else set_errno(EVMSERR);
- XSRETURN_UNDEF;
- }
- /* If the input filespec contained any lowercase characters,
- * downcase the result for compatibility with Unix-minded code. */
- for (out = myfab.fab$l_fna; *out; out++)
- if (islower(*out)) { haslower = 1; break; }
- if (mynam.nam$b_rsl) { out = rsa; speclen = mynam.nam$b_rsl; }
- else { out = esa; speclen = mynam.nam$b_esl; }
- if (!(mynam.nam$l_fnb & NAM$M_EXP_VER))
- speclen = mynam.nam$l_type - out;
- out[speclen] = '\0';
- if (haslower) __mystrtolower(out);
+ if (!items || items > 2)
+ croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
+ fspec = SvPV(ST(0),na);
+ if (!fspec || !*fspec) XSRETURN_UNDEF;
+ if (items == 2) defspec = SvPV(ST(1),na);
- ST(0) = sv_2mortal(newSVpv(out, speclen));
+ rslt = do_rmsexpand(fspec,NULL,1,defspec,0);
+ ST(0) = sv_newmortal();
+ if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt));
+ XSRETURN(1);
}
void
@@ -3562,7 +4144,7 @@ candelete_fromperl(CV *cv)
}
}
- ST(0) = cando_by_name(S_IDUSR,0,fsp) ? &sv_yes : &sv_no;
+ ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
XSRETURN(1);
}
@@ -3615,7 +4197,7 @@ rmscopy_fromperl(CV *cv)
}
date_flag = (items == 3) ? SvIV(ST(2)) : 0;
- ST(0) = rmscopy(inp,outp,date_flag) ? &sv_yes : &sv_no;
+ ST(0) = boolSV(rmscopy(inp,outp,date_flag));
XSRETURN(1);
}
@@ -3624,7 +4206,7 @@ init_os_extras()
{
char* file = __FILE__;
- newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$");
+ newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
diff --git a/gnu/usr.bin/perl/vms/vms_yfix.pl b/gnu/usr.bin/perl/vms/vms_yfix.pl
index 33af914b25c..f57ea1d5150 100644
--- a/gnu/usr.bin/perl/vms/vms_yfix.pl
+++ b/gnu/usr.bin/perl/vms/vms_yfix.pl
@@ -6,10 +6,12 @@
# If it finds that the input files are already patches for VMS,
# it just copies the input to the output.
#
-# Revised 29-Jan-1996 by Charles Bailey bailey@genetics.upenn.edu
+# Revised 20-Dec-1996 by Charles Bailey bailey@genetics.upenn.edu
-$VERSION = '1.1';
+$VERSION = '1.11';
+push(@ARGV,(qw[ perly.c perly.h vms/perly_c.vms vms/perly_h.vms])[@ARGV..4])
+ if @ARGV < 4;
($cinfile,$hinfile,$coutfile,$houtfile) = @ARGV;
open C,$cinfile or die "Can't read $cinfile: $!\n";
@@ -21,6 +23,10 @@ while (<C>) {
# "y.tab.c" is illegal as a VMS filename; DECC 5.2/VAX preprocessor
# doesn't like this.
if ( s/^#line\s+(\d+)\s+"y.tab.c"/#line $1 "y_tab.c"/ ) { 1; }
+ elsif (/char \*getenv/) {
+ # accomodate old VAXC's macro susbstitution pecularities
+ $_ = "# ifndef getenv\n$_# endif\n";
+ }
else {
# add the dEXT tag to definitions of global vars, so we'll insert
# a globaldef when perly.c is compiled
diff --git a/gnu/usr.bin/perl/vms/vmsish.h b/gnu/usr.bin/perl/vms/vmsish.h
index 0685985d56e..2da1639baa4 100644
--- a/gnu/usr.bin/perl/vms/vmsish.h
+++ b/gnu/usr.bin/perl/vms/vmsish.h
@@ -2,8 +2,8 @@
*
* VMS-specific C header file for perl5.
*
- * Last revised: 01-Oct-1995 by Charles Bailey bailey@genetics.upenn.edu
- * Version: 5.1.6
+ * Last revised: 18-Feb-1997 by Charles Bailey bailey@genetics.upenn.edu
+ * Version: 5.3.28
*/
#ifndef __vmsish_h_included
@@ -13,23 +13,15 @@
#include <libdef.h> /* status codes for various places */
#include <rmsdef.h> /* at which errno and vaxc$errno are */
#include <ssdef.h> /* explicitly set in the perl source code */
+#include <stsdef.h> /* bitmasks for exit status testing */
/* Suppress compiler warnings from DECC for VMS-specific extensions:
- * GLOBALEXT, NOSHAREEXT: global[dr]ef declarations
- * ADDRCONSTEXT: initialization of data with non-constant values
- * (e.g. pointer fields of descriptors)
- */
-#ifdef __DECC
-# pragma message disable (GLOBALEXT,NOSHAREEXT,ADDRCONSTEXT)
-#endif
-
-/* Suppress compiler warnings from DECC for VMS-specific extensions:
- * GLOBALEXT, NOSHAREEXT: global[dr]ef declarations
+ * GLOBALEXT, NOSHAREEXT, READONLYEXT: global[dr]ef declarations
* ADDRCONSTEXT,NEEDCONSTEXT: initialization of data with non-constant values
* (e.g. pointer fields of descriptors)
*/
#ifdef __DECC
-# pragma message disable (GLOBALEXT,NOSHAREEXT,ADDRCONSTEXT,NEEDCONSTEXT)
+# pragma message disable (GLOBALEXT,NOSHAREEXT,READONLYEXT,ADDRCONSTEXT,NEEDCONSTEXT)
#endif
/* DEC's C compilers and gcc use incompatible definitions of _to(upp|low)er() */
@@ -60,17 +52,46 @@
#include <unixio.h>
#include <unixlib.h>
#include <file.h> /* it's not <sys/file.h>, so don't use I_SYS_FILE */
+#if defined(__DECC) && defined(__DECC_VER) && __DECC_VER > 20000000
+# include <unistd.h> /* DECC has this; VAXC and gcc don't */
+#endif
+
+#ifdef NO_PERL_TYPEDEFS /* a2p; we don't want Perl's special routines */
+# define DONT_MASK_RTL_CALLS
+#endif
+
+ /* defined for vms.c so we can see CRTL | defined for a2p */
+#ifndef DONT_MASK_RTL_CALLS
+# ifdef getenv
+# undef getenv
+# endif
+# define getenv(v) my_getenv(v) /* getenv used for regular logical names */
+#endif
+
+/* DECC introduces this routine in the RTL as of VMS 7.0; for now,
+ * we'll use ours, since it gives us the full VMS exit status. */
+#ifdef __PID_T
+# define Pid_t pid_t
+#else
+# define Pid_t unsigned int
+#endif
+#define waitpid my_waitpid
/* Our own contribution to PerlShr's global symbols . . . */
#ifdef EMBED
# define my_trnlnm Perl_my_trnlnm
# define my_getenv Perl_my_getenv
+# define prime_env_iter Perl_prime_env_iter
+# define my_setenv Perl_my_setenv
# define my_crypt Perl_my_crypt
-# define waitpid Perl_waitpid
+# define my_waitpid Perl_my_waitpid
# define my_gconvert Perl_my_gconvert
# define do_rmdir Perl_do_rmdir
# define kill_file Perl_kill_file
+# define my_mkdir Perl_my_mkdir
# define my_utime Perl_my_utime
+# define rmsexpand Perl_rmsexpand
+# define rmsexpand_ts Perl_rmsexpand_ts
# define fileify_dirspec Perl_fileify_dirspec
# define fileify_dirspec_ts Perl_fileify_dirspec_ts
# define pathify_dirspec Perl_pathify_dirspec
@@ -83,24 +104,30 @@
# define tounixpath_ts Perl_tounixpath_ts
# define tovmspath Perl_tovmspath
# define tovmspath_ts Perl_tovmspath_ts
-# define getredirection Perl_getredirection
+# define vms_image_init Perl_vms_image_init
# define opendir Perl_opendir
# define readdir Perl_readdir
# define telldir Perl_telldir
# define seekdir Perl_seekdir
# define closedir Perl_closedir
# define vmsreaddirversions Perl_vmsreaddirversions
-# define getredirection Perl_getredirection
+#if __VMS_VER < 70000000 || __DECC_VER < 50200000
# define my_gmtime Perl_my_gmtime
+# define my_localtime Perl_my_localtime
+# define my_time Perl_my_time
+#endif
# define cando_by_name Perl_cando_by_name
# define flex_fstat Perl_flex_fstat
# define flex_stat Perl_flex_stat
# define trim_unixpath Perl_trim_unixpath
+# define my_vfork Perl_my_vfork
# define vms_do_aexec Perl_vms_do_aexec
# define vms_do_exec Perl_vms_do_exec
# define do_aspawn Perl_do_aspawn
# define do_spawn Perl_do_spawn
# define my_fwrite Perl_my_fwrite
+# define my_flush Perl_my_flush
+# define my_binmode Perl_my_binmode
# define my_getpwnam Perl_my_getpwnam
# define my_getpwuid Perl_my_getpwuid
# define my_getpwent Perl_my_getpwent
@@ -113,22 +140,73 @@
/* Delete if at all possible, changing protections if necessary. */
#define unlink kill_file
-/* The VMS C RTL has vfork() but not fork(). Both actually work in a way
- * that's somewhere between Unix vfork() and VMS lib$spawn(), so it's
- * probably not a good idea to use them much. That said, we'll try to
- * use vfork() in either case.
+/*
+ * Intercept calls to fork, so we know whether subsequent calls to
+ * exec should be handled in VMSish or Unixish style.
+ */
+#define fork my_vfork
+#ifndef DONT_MASK_RTL_CALLS /* #defined in vms.c so we see real vfork */
+# ifdef vfork
+# undef vfork
+# endif
+# define vfork my_vfork
+#endif
+
+/* BIG_TIME:
+ * This symbol is defined if Time_t is an unsigned type on this system.
*/
-#define fork vfork
+#define BIG_TIME
+
+/* 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 "$"
/* Macros to set errno using the VAX thread-safe calls, if present */
#if (defined(__DECC) || defined(__DECCXX)) && !defined(__ALPHA)
# define set_errno(v) (cma$tis_errno_set_value(v))
+ void cma$tis_errno_set_value(int __value); /* missing in some errno.h */
# define set_vaxc_errno(v) (vaxc$errno = (v))
#else
# define set_errno(v) (errno = (v))
# define set_vaxc_errno(v) (vaxc$errno = (v))
#endif
+/* Support for 'vmsish' behaviors enabled with C<use vmsish> pragma */
+
+#define COMPLEX_STATUS 1 /* We track both "POSIX" and VMS values */
+
+#define HINT_V_VMSISH 24
+#define HINT_M_VMSISH_STATUS 0x01000000 /* system, $? return VMS status */
+#define HINT_M_VMSISH_EXIT 0x02000000 /* exit(1) ==> SS$_NORMAL */
+#define HINT_M_VMSISH_TIME 0x04000000 /* times are local, not UTC */
+#define NATIVE_HINTS (hints >> HINT_V_VMSISH) /* used in op.c */
+
+#define TEST_VMSISH(h) (curcop->op_private & ((h) >> HINT_V_VMSISH))
+#define VMSISH_STATUS TEST_VMSISH(HINT_M_VMSISH_STATUS)
+#define VMSISH_EXIT TEST_VMSISH(HINT_M_VMSISH_EXIT)
+#define VMSISH_TIME TEST_VMSISH(HINT_M_VMSISH_TIME)
+
/* Handy way to vet calls to VMS system services and RTL routines. */
#define _ckvmssts(call) STMT_START { register unsigned long int __ckvms_sts; \
if (!((__ckvms_sts=(call))&1)) { \
@@ -136,14 +214,22 @@
croak("Fatal VMS error (status=%d) at %s, line %d", \
__ckvms_sts,__FILE__,__LINE__); } } STMT_END
+/* Same thing, but don't call back to Perl's croak(); useful for errors
+ * occurring during startup, before Perl's state is initialized */
+#define _ckvmssts_noperl(call) STMT_START { register unsigned long int __ckvms_sts; \
+ if (!((__ckvms_sts=(call))&1)) { \
+ set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
+ fprintf(Perl_debug_log,"Fatal VMS error (status=%d) at %s, line %d", \
+ __ckvms_sts,__FILE__,__LINE__); lib$signal(__ckvms_sts); } } STMT_END
+
#ifdef VMS_DO_SOCKETS
#include "sockadapt.h"
#endif
#define BIT_BUCKET "_NLA0:"
-#define PERL_SYS_INIT(c,v) getredirection((c),(v))
+#define PERL_SYS_INIT(c,v) vms_image_init((c),(v))
#define PERL_SYS_TERM()
-#define dXSUB_SYS int dummy
+#define dXSUB_SYS
#define HAS_KILL
#define HAS_WAIT
@@ -184,6 +270,14 @@
#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.
+ */
+#define USEMYBINMODE
+
/*
* 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
@@ -192,12 +286,20 @@
*/
#define fwrite1 my_fwrite
+/* By default, flush data all the way to disk, not just to RMS buffers */
+#define Fflush(fp) my_flush(fp)
+
/* Use our own rmdir() */
#define rmdir(name) do_rmdir(name)
/* Assorted fiddling with sigs . . . */
# include <signal.h>
#define ABORT() abort()
+ /* VAXC's signal.h doesn't #define SIG_ERR, but provides BADSIG instead. */
+#if !defined(SIG_ERR) && defined(BADSIG)
+# define SIG_ERR BADSIG
+#endif
+
/* Used with our my_utime() routine in vms.c */
struct utimbuf {
@@ -206,21 +308,35 @@ struct utimbuf {
};
#define utime my_utime
-/* This is what times() returns, but <times.h> calls it tbuffer_t on VMS */
+/* This is what times() returns, but <times.h> calls it tbuffer_t on VMS
+ * prior to v7.0. We check the DECC manifest to see whether it's already
+ * done this for us, relying on the fact that perl.h #includes <time.h>
+ * before it #includes "vmsish.h".
+ */
-struct tms {
- clock_t tms_utime; /* user time */
- clock_t tms_stime; /* system time - always 0 on VMS */
- clock_t tms_cutime; /* user time, children */
- clock_t tms_cstime; /* system time, children - always 0 on VMS */
-};
+#ifndef __TMS
+ struct tms {
+ clock_t tms_utime; /* user time */
+ clock_t tms_stime; /* system time - always 0 on VMS */
+ clock_t tms_cutime; /* user time, children */
+ clock_t tms_cstime; /* system time, children - always 0 on VMS */
+ };
+#else
+ /* The new headers change the times() prototype to tms from tbuffer */
+# define tbuffer_t struct tms
+#endif
/* Prior to VMS 7.0, the CRTL gmtime() routine was a stub which always
* returned NULL. Substitute our own routine, which uses the logical
* SYS$TIMEZONE_DIFFERENTIAL, whcih the native UTC support routines
- * in VMS 6.0 or later use.*
+ * in VMS 6.0 or later use. We also add shims for time() and localtime()
+ * so we can run on UTC by default.
*/
+#if __VMS_VER < 70000000 || __DECC_VER < 50200000
#define gmtime(t) my_gmtime(t)
+#define localtime(t) my_localtime(t)
+#define time(t) my_time(t)
+#endif
/* VMS doesn't use a real sys_nerr, but we need this when scanning for error
* messages in text strings . . .
@@ -231,6 +347,9 @@ struct tms {
/* Look up new %ENV values on the fly */
#define DYNAMIC_ENV_FETCH 1
#define ENV_HV_NAME "%EnV%VmS%"
+ /* Special getenv function for retrieving %ENV elements. */
+#define ENV_getenv(v) my_getenv(v)
+
/* Thin jacket around cuserid() tomatch Unix' calling sequence */
#define getlogin my_getlogin
@@ -238,18 +357,17 @@ struct tms {
/* Ditto for sys$hash_passwrod() . . . */
#define crypt my_crypt
+/* Tweak arg to mkdir first, so we can tolerate trailing /. */
+#define Mkdir(dir,mode) my_mkdir((dir),(mode))
+
/* Use our own stat() clones, which handle Unix-style directory names */
#define Stat(name,bufptr) flex_stat(name,bufptr)
#define Fstat(fd,bufptr) flex_fstat(fd,bufptr)
-/* By default, flush data all the way to disk, not just to RMS buffers */
-#define Fflush(fp) ((fflush(fp) || fsync(fileno(fp))) ? EOF : 0)
-
/* Setup for the dirent routines:
* opendir(), closedir(), readdir(), seekdir(), telldir(), and
* vmsreaddirversions(), and preprocessor stuff on which these depend:
* Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
- * This code has no copyright.
*/
/* Data structure returned by READDIR(). */
struct dirent {
@@ -334,11 +452,16 @@ struct mystat
char st_fab_fsz; /* fixed header size */
unsigned st_dev; /* encoded device name */
};
-#define stat mystat
typedef unsigned mydev_t;
-#define dev_t mydev_t
typedef unsigned myino_t;
-#define ino_t myino_t
+#ifndef DONT_MASK_RTL_CALLS /* defined for vms.c so we can see RTL calls */
+# ifdef stat
+# undef stat
+# endif
+# define stat mystat
+# define dev_t mydev_t
+# define ino_t myino_t
+#endif
#if defined(__DECC) || defined(__DECCXX)
# pragma __member_alignment __restore
#endif
@@ -359,16 +482,41 @@ typedef unsigned myino_t;
* __VMS_PROTOTYPES__ and __VMS_SEPYTOTORP__ lines, and must be in the form
* <data type><TAB>name<WHITESPACE>_((<prototype args>));
*/
+
+#ifdef NO_PERL_TYPEDEFS
+ /* We don't have Perl typedefs available (e.g. when building a2p), so
+ we fake them here. N.B. There is *no* guarantee that the faked
+ prototypes will actually match the real routines. If you want to
+ call Perl routines, include perl.h to get the real typedefs. */
+# ifndef bool
+# define bool int
+# define __MY_BOOL_TYPE_FAKE
+# endif
+# ifndef I32
+# define I32 int
+# define __MY_I32_TYPE_FAKE
+# endif
+# ifndef SV
+# define SV void /* Since we only see SV * in prototypes */
+# define __MY_SV_TYPE_FAKE
+# endif
+#endif
+
+void prime_env_iter _((void));
+void init_os_extras _(());
/* prototype section start marker; `typedef' passes through cpp */
typedef char __VMS_PROTOTYPES__;
int my_trnlnm _((char *, char *, unsigned long int));
char * my_getenv _((char *));
char * my_crypt _((const char *, const char *));
-unsigned long int waitpid _((unsigned long int, int *, int));
+Pid_t my_waitpid _((Pid_t, int *, int));
char * my_gconvert _((double, int, int, char *));
int do_rmdir _((char *));
int kill_file _((char *));
+int my_mkdir _((char *, Mode_t));
int my_utime _((char *, struct utimbuf *));
+char * rmsexpand _((char *, char *, char *, unsigned));
+char * rmsexpand_ts _((char *, char *, char *, unsigned));
char * fileify_dirspec _((char *, char *));
char * fileify_dirspec_ts _((char *, char *));
char * pathify_dirspec _((char *, char *));
@@ -381,34 +529,54 @@ char * tounixpath _((char *, char *));
char * tounixpath_ts _((char *, char *));
char * tovmspath _((char *, char *));
char * tovmspath_ts _((char *, char *));
-void getredirection _(());
+void vms_image_init _((int *, char ***));
DIR * opendir _((char *));
struct dirent * readdir _((DIR *));
long telldir _((DIR *));
void seekdir _((DIR *, long));
void closedir _((DIR *));
void vmsreaddirversions _((DIR *, int));
-void getredirection _((int *, char ***));
-struct tm *my_gmtime _((const time_t *));
+#ifdef my_gmtime
+struct tm * my_gmtime _((const time_t *));
+struct tm * my_localtime _((const time_t *));
+time_t my_time _((time_t *));
+#endif /* We're assuming these three come as a package */
I32 cando_by_name _((I32, I32, char *));
-int flex_fstat _((int, struct stat *));
-int flex_stat _((char *, struct stat *));
-int trim_unixpath _((char *, char*));
+int flex_fstat _((int, struct mystat *));
+int flex_stat _((char *, struct mystat *));
+int trim_unixpath _((char *, char*, int));
+int my_vfork _(());
bool vms_do_aexec _((SV *, SV **, SV **));
bool vms_do_exec _((char *));
unsigned long int do_aspawn _((SV *, SV **, SV **));
unsigned long int do_spawn _((char *));
int my_fwrite _((void *, size_t, size_t, FILE *));
+int my_flush _((FILE *));
+FILE * my_binmode _((FILE *, char));
struct passwd * my_getpwnam _((char *name));
struct passwd * my_getpwuid _((Uid_t uid));
struct passwd * my_getpwent _(());
void my_endpwent _(());
char * my_getlogin _(());
int rmscopy _((char *, char *, int));
-void init_os_extras _(());
typedef char __VMS_SEPYTOTORP__;
/* prototype section end marker; `typedef' passes through cpp */
+#ifdef NO_PERL_TYPEDEFS /* We'll try not to scramble later files */
+# ifdef __MY_BOOL_TYPE_FAKE
+# undef bool
+# undef __MY_BOOL_TYPE_FAKE
+# endif
+# ifdef __MY_I32_TYPE_FAKE
+# undef I32
+# undef __MY_I32_TYPE_FAKE
+# endif
+# ifdef __MY_SV_TYPE_FAKE
+# undef SV
+# undef __MY_SV_TYPE_FAKE
+# endif
+#endif
+
#ifndef VMS_DO_SOCKETS
/* This relies on tricks in perl.h to pick up that these manifest constants
* are undefined and set up conversion routines. It will then redefine
diff --git a/gnu/usr.bin/perl/vms/writemain.pl b/gnu/usr.bin/perl/vms/writemain.pl
index eb059f810a7..a502d6131e1 100644
--- a/gnu/usr.bin/perl/vms/writemain.pl
+++ b/gnu/usr.bin/perl/vms/writemain.pl
@@ -36,12 +36,13 @@ print OUT <<'EOH';
static void
xs_init()
{
- dXSUB_SYS;
EOH
if (@ARGV) {
+ $names = join(' ',@ARGV);
+ $names =~ tr/"//d; # Plan9 doesn't remove "" on command line
# Allow for multiple names in one quoted group
- @exts = split(/\s+/, join(' ',@ARGV));
+ @exts = split(/\s+/,$names);
}
if (@exts) {
@@ -51,6 +52,8 @@ if (@exts) {
$subname =~ s/::/__/g;
print OUT "extern void boot_${subname} _((CV* cv));\n"
}
+ # May not actually be a declaration, so put after other declarations
+ print OUT " dXSUB_SYS;\n";
foreach $ext (@exts) {
my($subname) = $ext;
$subname =~ s/::/__/g;
diff --git a/gnu/usr.bin/perl/win32/Makefile b/gnu/usr.bin/perl/win32/Makefile
new file mode 100644
index 00000000000..7a98f84c2cb
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/Makefile
@@ -0,0 +1,517 @@
+#
+# Makefile to build perl on Windowns NT using Microsoft NMAKE.
+#
+#
+# This is set up to build a perl.exe that runs off a shared library
+# (perl.dll). Also makes individual DLLs for the XS extensions.
+#
+
+#
+# Set these to wherever you want "nmake install" to put your
+# newly built perl.
+INST_DRV=c:
+INST_TOP=$(INST_DRV)\perl
+
+#
+# uncomment next line if you are using Visual C++ 2.x
+#CCTYPE=MSVC20
+
+#
+# uncomment next line if you want debug version of perl (big,slow)
+#CFG=Debug
+
+#
+# set the install locations of the compiler include/libraries
+#CCHOME = f:\msvc20
+CCHOME = $(MSVCDIR)
+CCINCDIR = $(CCHOME)\include
+CCLIBDIR = $(CCHOME)\lib
+
+#
+# set this to your email address (perl will guess a value from
+# from your loginname and your hostname, which may not be right)
+#EMAIL =
+
+##################### CHANGE THESE ONLY IF YOU MUST #####################
+
+#
+# Programs to compile, build .lib files and link
+#
+
+CC=cl.exe
+LINK32=link.exe
+LIB32=$(LINK32) -lib
+#
+# Options
+#
+!IF "$(RUNTIME)" == ""
+RUNTIME = -MD
+!ENDIF
+INCLUDES = -I.\include -I. -I..
+#PCHFLAGS = -Fp"$(INTDIR)/modules.pch" -YX
+DEFINES = -DWIN32 -D_CONSOLE -DPERLDLL
+SUBSYS = console
+
+!IF "$(RUNTIME)" == "-MD"
+LIBC = msvcrt.lib
+WINIOMAYBE =
+!ELSE
+LIBC = libcmt.lib
+WINIOMAYBE = win32io.obj
+!ENDIF
+
+!IF "$(CFG)" == "Debug"
+! IF "$(CCTYPE)" == "MSVC20"
+OPTIMIZE = -Od $(RUNTIME) -Z7 -D_DEBUG
+! ELSE
+OPTIMIZE = -Od $(RUNTIME)d -Z7 -D_DEBUG
+! ENDIF
+LINK_DBG = -debug -pdb:none
+!ELSE
+! IF "$(CCTYPE)" == "MSVC20"
+OPTIMIZE = -Od $(RUNTIME) -DNDEBUG
+! ELSE
+OPTIMIZE = -Od $(RUNTIME) -DNDEBUG
+! ENDIF
+LINK_DBG = -release
+!ENDIF
+
+# we don't add LIBC here, the compiler do it based on -MD/-MT
+LIBFILES = oldnames.lib kernel32.lib user32.lib gdi32.lib \
+ winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib \
+ oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \
+ version.lib odbc32.lib odbccp32.lib
+
+CFLAGS = -nologo -W3 $(INCLUDES) $(DEFINES) $(PCHFLAGS) $(OPTIMIZE)
+LINK_FLAGS = -nologo $(LIBFILES) $(LINK_DBG) -machine:I386
+OBJOUT_FLAG = -Fo
+
+#################### do not edit below this line #######################
+############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ##############
+
+#
+# Rules
+#
+.SUFFIXES :
+.SUFFIXES : .c .obj .dll .lib .exe
+
+.c.obj:
+ $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $<
+
+.obj.dll:
+ $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \
+ -out:$@ $(LINK_FLAGS) $< $(LIBPERL)
+
+#
+INST_BIN=$(INST_TOP)\bin
+INST_LIB=$(INST_TOP)\lib
+INST_POD=$(INST_LIB)\pod
+INST_HTML=$(INST_POD)\html
+LIBDIR=..\lib
+EXTDIR=..\ext
+PODDIR=..\pod
+EXTUTILSDIR=$(LIBDIR)\extutils
+
+#
+# various targets
+PERLIMPLIB=..\perl.lib
+MINIPERL=..\miniperl.exe
+PERLDLL=..\perl.dll
+PERLEXE=..\perl.exe
+GLOBEXE=..\perlglob.exe
+CONFIGPM=..\lib\Config.pm
+MINIMOD=..\lib\ExtUtils\Miniperl.pm
+
+PL2BAT=bin\pl2bat.pl
+GLOBBAT = bin\perlglob.bat
+
+MAKE=nmake -nologo
+CFGSH_TMPL = config.vc
+CFGH_TMPL = config_H.vc
+PERL95EXE=..\perl95.exe
+XCOPY=xcopy /f /r /i /d
+RCOPY=xcopy /f /r /i /e /d
+NULL=
+
+#
+# filenames given to xsubpp must have forward slashes (since it puts
+# full pathnames in #line strings)
+XSUBPP=..\$(MINIPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp -C++ -prototypes
+
+CORE_C= ..\av.c \
+ ..\deb.c \
+ ..\doio.c \
+ ..\doop.c \
+ ..\dump.c \
+ ..\globals.c \
+ ..\gv.c \
+ ..\hv.c \
+ ..\mg.c \
+ ..\op.c \
+ ..\perl.c \
+ ..\perlio.c \
+ ..\perly.c \
+ ..\pp.c \
+ ..\pp_ctl.c \
+ ..\pp_hot.c \
+ ..\pp_sys.c \
+ ..\regcomp.c \
+ ..\regexec.c \
+ ..\run.c \
+ ..\scope.c \
+ ..\sv.c \
+ ..\taint.c \
+ ..\toke.c \
+ ..\universal.c \
+ ..\util.c
+
+CORE_OBJ= ..\av.obj \
+ ..\deb.obj \
+ ..\doio.obj \
+ ..\doop.obj \
+ ..\dump.obj \
+ ..\globals.obj \
+ ..\gv.obj \
+ ..\hv.obj \
+ ..\mg.obj \
+ ..\op.obj \
+ ..\perl.obj \
+ ..\perlio.obj \
+ ..\perly.obj \
+ ..\pp.obj \
+ ..\pp_ctl.obj \
+ ..\pp_hot.obj \
+ ..\pp_sys.obj \
+ ..\regcomp.obj \
+ ..\regexec.obj \
+ ..\run.obj \
+ ..\scope.obj \
+ ..\sv.obj \
+ ..\taint.obj \
+ ..\toke.obj \
+ ..\universal.obj\
+ ..\util.obj
+
+WIN32_C = perllib.c \
+ win32.c \
+ win32io.c \
+ win32sck.c
+
+WIN32_OBJ = win32.obj \
+ win32io.obj \
+ win32sck.obj
+
+PERL95_OBJ = perl95.obj \
+ win32mt.obj \
+ win32iomt.obj \
+ win32sckmt.obj
+
+DLL_OBJ = perllib.obj $(DYNALOADER).obj
+
+CORE_H = ..\av.h \
+ ..\cop.h \
+ ..\cv.h \
+ ..\dosish.h \
+ ..\embed.h \
+ ..\form.h \
+ ..\gv.h \
+ ..\handy.h \
+ ..\hv.h \
+ ..\mg.h \
+ ..\nostdio.h \
+ ..\op.h \
+ ..\opcode.h \
+ ..\perl.h \
+ ..\perlio.h \
+ ..\perlsdio.h \
+ ..\perlsfio.h \
+ ..\perly.h \
+ ..\pp.h \
+ ..\proto.h \
+ ..\regexp.h \
+ ..\scope.h \
+ ..\sv.h \
+ ..\unixish.h \
+ ..\util.h \
+ ..\XSUB.h \
+ .\config.h \
+ ..\EXTERN.h \
+ .\include\dirent.h \
+ .\include\netdb.h \
+ .\include\sys\socket.h \
+ .\win32.h
+
+EXTENSIONS=DynaLoader Socket IO Fcntl Opcode SDBM_File
+
+DYNALOADER=$(EXTDIR)\DynaLoader\DynaLoader
+SOCKET=$(EXTDIR)\Socket\Socket
+FCNTL=$(EXTDIR)\Fcntl\Fcntl
+OPCODE=$(EXTDIR)\Opcode\Opcode
+SDBM_FILE=$(EXTDIR)\SDBM_File\SDBM_File
+IO=$(EXTDIR)\IO\IO
+
+SOCKET_DLL=..\lib\auto\Socket\Socket.dll
+FCNTL_DLL=..\lib\auto\Fcntl\Fcntl.dll
+OPCODE_DLL=..\lib\auto\Opcode\Opcode.dll
+SDBM_FILE_DLL=..\lib\auto\SDBM_File\SDBM_File.dll
+IO_DLL=..\lib\auto\IO\IO.dll
+
+STATICLINKMODULES=DynaLoader
+DYNALOADMODULES= \
+ $(SOCKET_DLL) \
+ $(FCNTL_DLL) \
+ $(OPCODE_DLL) \
+ $(SDBM_FILE_DLL)\
+ $(IO_DLL)
+
+POD2HTML=$(PODDIR)\pod2html
+POD2MAN=$(PODDIR)\pod2man
+POD2LATEX=$(PODDIR)\pod2latex
+POD2TEXT=$(PODDIR)\pod2text
+
+#
+# Top targets
+#
+
+all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) $(GLOBBAT)
+
+$(DYNALOADER).obj : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c
+
+#------------------------------------------------------------
+
+$(GLOBEXE): perlglob.obj
+ $(LINK32) $(LINK_FLAGS) -out:$@ -subsystem:$(SUBSYS) perlglob.obj setargv.obj
+
+$(GLOBBAT) : ..\lib\File\DosGlob.pm $(MINIPERL)
+ $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(GLOBBAT)
+
+perlglob.obj : perlglob.c
+
+..\miniperlmain.obj : ..\miniperlmain.c $(CORE_H)
+
+config.w32 : $(CFGSH_TMPL)
+ copy $(CFGSH_TMPL) config.w32
+
+.\config.h : $(CFGSH_TMPL)
+ -del /f config.h
+ copy $(CFGH_TMPL) config.h
+
+..\config.sh : config.w32 $(MINIPERL) config_sh.PL
+ $(MINIPERL) -I..\lib config_sh.PL "INST_DRV=$(INST_DRV)" \
+ "INST_TOP=$(INST_TOP)" "cc=$(CC)" "ccflags=$(RUNTIME) -DWIN32" \
+ "cf_email=$(EMAIL)" "libs=$(LIBFILES)" "incpath=$(CCINCDIR)" \
+ "libpth=$(CCLIBDIR)" "libc=$(LIBC)" \
+ config.w32 > ..\config.sh
+
+$(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
+ cd .. && miniperl configpm
+ if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL)
+ $(XCOPY) ..\*.h ..\lib\CORE\*.*
+ $(XCOPY) *.h ..\lib\CORE\*.*
+ $(RCOPY) include ..\lib\CORE\*.*
+ $(MINIPERL) -I..\lib config_h.PL || $(MAKE) CCTYPE=$(CCTYPE) \
+ RUNTIME=$(RUNTIME) CFG=$(CFG) $(CONFIGPM)
+
+$(MINIPERL) : ..\miniperlmain.obj $(CORE_OBJ) $(WIN32_OBJ)
+ $(LINK32) -subsystem:console -out:$@ @<<
+ $(LINK_FLAGS) ..\miniperlmain.obj $(CORE_OBJ) $(WIN32_OBJ)
+<<
+
+$(WIN32_OBJ) : $(CORE_H)
+$(CORE_OBJ) : $(CORE_H)
+$(DLL_OBJ) : $(CORE_H)
+
+perldll.def : $(MINIPERL) $(CONFIGPM)
+ $(MINIPERL) -w makedef.pl $(CCTYPE) > perldll.def
+
+$(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ)
+ $(LINK32) -dll -def:perldll.def -out:$@ @<<
+ $(LINK_FLAGS) $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ)
+<<
+ $(XCOPY) $(PERLIMPLIB) ..\lib\CORE
+
+perl.def : $(MINIPERL) makeperldef.pl
+ $(MINIPERL) -I..\lib makeperldef.pl $(NULL) > perl.def
+
+$(MINIMOD) : $(MINIPERL) ..\minimod.pl
+ cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm
+
+perlmain.c : runperl.c
+ copy runperl.c perlmain.c
+
+perlmain.obj : perlmain.c
+ $(CC) $(CFLAGS) -UPERLDLL -c perlmain.c
+
+$(PERLEXE): $(PERLDLL) $(CONFIGPM) perlmain.obj
+ $(LINK32) -subsystem:console -out:perl.exe $(LINK_FLAGS) \
+ perlmain.obj $(WINIOMAYBE) $(PERLIMPLIB)
+ copy perl.exe $@
+ del perl.exe
+ copy splittree.pl ..
+ $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto"
+ attrib -r ..\t\*.*
+ copy test ..\t
+
+perl95.c : runperl.c
+ copy runperl.c perl95.c
+
+perl95.obj : perl95.c
+ $(CC) $(CFLAGS) -MT -UPERLDLL -c perl95.c
+
+win32iomt.obj : win32io.c
+ $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32iomt.obj win32io.c
+
+win32sckmt.obj : win32sck.c
+ $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32sckmt.obj win32sck.c
+
+win32mt.obj : win32.c
+ $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32mt.obj win32.c
+
+$(PERL95EXE): $(PERLDLL) $(CONFIGPM) $(PERL95_OBJ)
+ $(LINK32) -subsystem:console -out:perl95.exe $(LINK_FLAGS) \
+ $(PERL95_OBJ) $(PERLIMPLIB)
+ copy perl95.exe $@
+ del perl95.exe
+
+$(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM)
+ if not exist ..\lib\auto md ..\lib\auto
+ $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL)
+ cd $(EXTDIR)\$(*B)
+ $(XSUBPP) dl_win32.xs > $(*B).c
+ cd ..\..\win32
+
+$(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs
+ copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs
+
+$(IO_DLL): $(PERLEXE) $(CONFIGPM) $(IO).xs
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\win32
+
+$(SDBM_FILE_DLL) : $(PERLEXE) $(SDBM_FILE).xs
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\win32
+
+$(FCNTL_DLL): $(PERLEXE) $(FCNTL).xs
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\win32
+
+$(OPCODE_DLL): $(PERLEXE) $(OPCODE).xs
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\win32
+
+$(SOCKET_DLL): $(SOCKET).xs $(PERLEXE)
+ cd $(EXTDIR)\$(*B)
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ $(MAKE)
+ cd ..\..\win32
+
+doc: $(PERLEXE)
+ cd ..\pod
+ $(MAKE) -f ..\win32\pod.mak checkpods pod2html pod2latex \
+ pod2man pod2text
+ $(XCOPY) *.bat ..\win32\bin\*.*
+ cd ..\win32
+ copy ..\README.win32 ..\pod\perlwin32.pod
+ $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \
+ --podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML::=|)" \
+ --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse
+
+utils: $(PERLEXE)
+ cd ..\utils
+ nmake PERL=$(MINIPERL)
+ $(PERLEXE) ..\win32\$(PL2BAT) h2ph splain perlbug pl2pm c2ph
+ $(PERLEXE) ..\win32\$(PL2BAT) h2xs perldoc pstruct
+ $(XCOPY) *.bat ..\win32\bin\*.*
+ cd ..\win32
+ $(PERLEXE) $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \
+ bin\pl2bat.pl
+
+distclean: clean
+ -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \
+ $(PERLIMPLIB) ..\miniperl.lib $(MINIMOD)
+ -del /f *.def *.map
+ -del /f $(SOCKET_DLL) $(IO_DLL) $(SDBM_FILE_DLL) $(FCNTL_DLL) \
+ $(OPCODE_DLL)
+ -del /f $(SOCKET).c $(IO).c $(SDBM_FILE).c $(FCNTL).c $(OPCODE).c \
+ $(DYNALOADER).c
+ -del /f $(PODDIR)\*.html
+ -del /f $(PODDIR)\*.bat
+ -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c \
+ config.h.new perl95.c
+ -del /f bin\*.bat
+ -rmdir /s /q ..\lib\auto
+ -rmdir /s /q ..\lib\CORE
+ cd $(EXTDIR)
+ -del /s *.lib *.def *.map *.bs Makefile *.obj pm_to_blib
+ cd ..\win32
+
+install : all doc utils
+ if not exist $(INST_TOP) mkdir $(INST_TOP)
+ echo I $(INST_TOP) L $(LIBDIR)
+ $(XCOPY) $(PERLEXE) $(INST_BIN)\*.*
+ $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.*
+ $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.*
+ $(XCOPY) $(PERLDLL) $(INST_BIN)\*.*
+ $(XCOPY) bin\*.bat $(INST_BIN)\*.*
+ $(RCOPY) ..\lib $(INST_LIB)\*.*
+ $(XCOPY) ..\pod\*.bat $(INST_BIN)\*.*
+ $(XCOPY) ..\pod\*.pod $(INST_POD)\*.*
+ $(RCOPY) html\*.* $(INST_HTML)\*.*
+
+inst_lib : $(CONFIGPM)
+ copy splittree.pl ..
+ $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto"
+ $(RCOPY) ..\lib $(INST_LIB)\*.*
+
+minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM)
+ $(XCOPY) $(MINIPERL) ..\t\perl.exe
+ $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
+ attrib -r ..\t\*.*
+ copy test ..\t
+ cd ..\t
+ $(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t
+ cd ..\win32
+
+test-prep : all
+ $(XCOPY) $(PERLEXE) ..\t\$(NULL)
+ $(XCOPY) $(PERLDLL) ..\t\$(NULL)
+ $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
+
+test : test-prep
+ cd ..\t
+ $(PERLEXE) -I..\lib harness
+ cd ..\win32
+
+test-notty : test-prep
+ set PERL_SKIP_TTY_TEST=1
+ cd ..\t
+ $(PERLEXE) -I..\lib harness
+ cd ..\win32
+
+clean :
+ -@erase miniperlmain.obj
+ -@erase $(MINIPERL)
+ -@erase perlglob.obj
+ -@erase perlmain.obj
+ -@erase config.w32
+ -@erase /f config.h
+ -@erase $(GLOBEXE)
+ -@erase $(PERLEXE)
+ -@erase $(PERLDLL)
+ -@erase $(CORE_OBJ)
+ -@erase $(WIN32_OBJ)
+ -@erase $(DLL_OBJ)
+ -@erase ..\*.obj ..\*.lib ..\*.exp *.obj *.lib *.exp
+ -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat
+ -@erase *.ilk
+ -@erase *.pdb
+
+
diff --git a/gnu/usr.bin/perl/win32/TEST b/gnu/usr.bin/perl/win32/TEST
new file mode 100644
index 00000000000..1bda4ef7930
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/TEST
@@ -0,0 +1,149 @@
+#!./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] 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';
+
+$ENV{EMXSHELL} = 'sh'; # For OS/2
+
+if ($ARGV[0] eq '') {
+ push( @ARGV, `dir/s/b base` );
+ push( @ARGV, `dir/s/b comp` );
+ push( @ARGV, `dir/s/b cmd` );
+ push( @ARGV, `dir/s/b io` );
+ push( @ARGV, `dir/s/b op` );
+ push( @ARGV, `dir/s/b pragma` );
+ push( @ARGV, `dir/s/b lib` );
+
+ grep( chomp, @ARGV );
+ @ARGV = grep( /\.t$/, @ARGV );
+ grep( s/.*t\\//, @ARGV );
+# @ARGV = split(/[ \n]/,
+# `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`);
+} else {
+
+@ARGV = map(glob($_),@ARGV);
+
+}
+
+if ($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'qnx' || 1) {
+ $sharpbang = 0;
+}
+else {
+ open(CONFIG, "../config.sh");
+ while (<CONFIG>) {
+ if (/sharpbang='(.*)'/) {
+ $sharpbang = ($1 eq '#!');
+ last;
+ }
+ }
+ close(CONFIG);
+}
+
+$bad = 0;
+$good = 0;
+$total = @ARGV;
+while ($test = shift) {
+ if ($test =~ /^$/) {
+ next;
+ }
+ $te = $test;
+ chop($te);
+ print "$te" . '.' x (18 - length($te));
+ if ($sharpbang) {
+ open(results,"./$test |") || (print "can't run.\n");
+ } else {
+ open(script,"$test") || 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 = '';
+ }
+ open(results,"perl$switch $test |") || (print "can't run.\n");
+ }
+ $ok = 0;
+ $next = 0;
+ while (<results>) {
+ if (/^$/) { next;};
+ 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 (.*)/ && $1 == $next) {
+ $next = $next + 1;
+ } else {
+ $ok = 0;
+ }
+ }
+ }
+ }
+ $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 on 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";
+ } 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".
+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/gnu/usr.bin/perl/win32/autosplit.pl b/gnu/usr.bin/perl/win32/autosplit.pl
new file mode 100644
index 00000000000..26ce2c358ce
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/autosplit.pl
@@ -0,0 +1,3 @@
+use AutoSplit;
+
+autosplit($ARGV[0], $ARGV[1], 0, 1, 1);
diff --git a/gnu/usr.bin/perl/win32/bin/network.pl b/gnu/usr.bin/perl/win32/bin/network.pl
new file mode 100644
index 00000000000..f49045333d9
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/bin/network.pl
@@ -0,0 +1,211 @@
+##
+## Jeffrey Friedl (jfriedl@omron.co.jp)
+## Copyri.... ah hell, just take it.
+##
+## July 1994
+##
+package network;
+$version = "950311.5";
+
+## version 950311.5 -- turned off warnings when requiring 'socket.ph';
+## version 941028.4 -- some changes to quiet perl5 warnings.
+## version 940826.3 -- added check for "socket.ph", and alternate use of
+## socket STREAM value for SunOS5.x
+##
+
+## BLURB:
+## A few simple and easy-to-use routines to make internet connections.
+## Similar to "chat2.pl" (but actually commented, and a bit more portable).
+## Should work even on SunOS5.x.
+##
+
+##>
+##
+## connect_to() -- make an internet connection to a server.
+##
+## Two uses:
+## $error = &network'connect_to(*FILEHANDLE, $fromsockaddr, $tosockaddr)
+## $error = &network'connect_to(*FILEHANDLE, $hostname, $portnum)
+##
+## Makes the given connection and returns an error string, or undef if
+## no error.
+##
+## In the first form, FROMSOCKADDR and TOSOCKADDR are of the form returned
+## by SOCKET'GET_ADDR and SOCKET'MY_ADDR.
+##
+##<
+sub connect_to
+{
+ local(*FD, $arg1, $arg2) = @_;
+ local($from, $to) = ($arg1, $arg2); ## for one interpretation.
+ local($host, $port) = ($arg1, $arg2); ## for the other
+
+ if (defined($to) && length($from)==16 && length($to)==16) {
+ ## ok just as is
+ } elsif (defined($host)) {
+ $to = &get_addr($host, $port);
+ return qq/unknown address "$host"/ unless defined $to;
+ $from = &my_addr;
+ } else {
+ return "unknown arguments to network'connect_to";
+ }
+
+ return "connect_to failed (socket: $!)" unless &my_inet_socket(*FD);
+ return "connect_to failed (bind: $!)" unless bind(FD, $from);
+ return "connect_to failed (connect: $!)" unless connect(FD, $to);
+ local($old) = select(FD); $| = 1; select($old);
+ undef;
+}
+
+
+
+##>
+##
+## listen_at() - used by a server to indicate that it will accept requests
+## at the port number given.
+##
+## Used as
+## $error = &network'listen_at(*LISTEN, $portnumber);
+## (returns undef upon success)
+##
+## You can then do something like
+## $addr = accept(REMOTE, LISTEN);
+## print "contact from ", &network'addr_to_ascii($addr), ".\n";
+## while (<REMOTE>) {
+## .... process request....
+## }
+## close(REMOTE);
+##
+##<
+sub listen_at
+{
+ local(*FD, $port) = @_;
+ local($empty) = pack('S n a4 x8', 2 ,$port, "\0\0\0\0");
+ return "listen_for failed (socket: $!)" unless &my_inet_socket(*FD);
+ return "listen_for failed (bind: $!)" unless bind(FD, $empty);
+ return "listen_for failed (listen: $!)" unless listen(FD, 5);
+ local($old) = select(FD); $| = 1; select($old);
+ undef;
+}
+
+
+##>
+##
+## Given an internal packed internet address (as returned by &connect_to
+## or &get_addr), return a printable ``1.2.3.4'' version.
+##
+##<
+sub addr_to_ascii
+{
+ local($addr) = @_;
+ return "bad arg" if length $addr != 16;
+ return join('.', unpack("CCCC", (unpack('S n a4 x8', $addr))[2]));
+}
+
+##
+##
+## Given a host and a port name, returns the packed socket addresss.
+## Mostly for internal use.
+##
+##
+sub get_addr
+{
+ local($host, $port) = @_;
+ return $addr{$host,$port} if defined $addr{$host,$port};
+ local($addr);
+
+ if ($host =~ m/^\d+\.\d+\.\d+\.\d+$/)
+ {
+ $addr = pack("C4", split(/\./, $host));
+ }
+ elsif ($addr = (gethostbyname($host))[4], !defined $addr)
+ {
+ local(@lookup) = `nslookup $host 2>&1`;
+ if (@lookup)
+ {
+ local($lookup) = join('', @lookup[2 .. $#lookup]);
+ if ($lookup =~ m/^Address:\s*(\d+\.\d+\.\d+\.\d+)/) {
+ $addr = pack("C4", split(/\./, $1));
+ }
+ }
+ if (!defined $addr) {
+ ## warn "$host: SOL, dude\n";
+ return undef;
+ }
+ }
+ $addr{$host,$port} = pack('S n a4 x8', 2 ,$port, $addr);
+}
+
+
+##
+## my_addr()
+## Returns the packed socket address of the local host (port 0)
+## Mostly for internal use.
+##
+##
+sub my_addr
+{
+ local(@x) = gethostbyname('localhost');
+ local(@y) = gethostbyname($x[0]);
+# local($name,$aliases,$addrtype,$length,@addrs) = gethostbyname($x[0]);
+# local(@bytes) = unpack("C4",$addrs[0]);
+# return pack('S n a4 x8', 2 ,0, $addr);
+ return pack('S n a4 x8', 2 ,0, $y[4]);
+}
+
+
+##
+## my_inet_socket(*FD);
+##
+## Local routine to do socket(PF_INET, SOCK_STREAM, AF_NS).
+## Takes care of figuring out the proper values for the args. Hopefully.
+##
+## Returns the same value as 'socket'.
+##
+sub my_inet_socket
+{
+ local(*FD) = @_;
+ local($socket);
+
+ if (!defined $socket_values_queried)
+ {
+ ## try to load some "socket.ph"
+ if (!defined &main'_SYS_SOCKET_H_) {
+ eval 'package main;
+ local($^W) = 0;
+ require("sys/socket.ph")||require("socket.ph");';
+ }
+
+ ## we'll use "the regular defaults" if for PF_INET and AF_NS if unknown
+ $PF_INET = defined &main'PF_INET ? &main'PF_INET : 2;
+ $AF_NS = defined &main'AF_NS ? &main'AF_NS : 6;
+ $SOCK_STREAM = &main'SOCK_STREAM if defined &main'SOCK_STREAM;
+
+ $socket_values_queried = 1;
+ }
+
+ if (defined $SOCK_STREAM) {
+ $socket = socket(FD, $PF_INET, $SOCK_STREAM, $AF_NS);
+ } else {
+ ##
+ ## We'll try the "regular default" of 1. If that returns a
+ ## "not supported" error, we'll try 2, which SunOS5.x uses.
+ ##
+ $socket = socket(FD, $PF_INET, 1, $AF_NS);
+ if ($socket) {
+ $SOCK_STREAM = 1; ## got it.
+ } elsif ($! =~ m/not supported/i) {
+ ## we'll just assume from now on that it's 2.
+ $socket = socket(FD, $PF_INET, $SOCK_STREAM = 2, $AF_NS);
+ }
+ }
+ $socket;
+}
+
+## This here just to quiet -w warnings.
+sub dummy {
+ 1 || $version || &dummy;
+}
+
+1;
+__END__
diff --git a/gnu/usr.bin/perl/win32/bin/pl2bat.pl b/gnu/usr.bin/perl/win32/bin/pl2bat.pl
new file mode 100644
index 00000000000..73ae87164da
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/bin/pl2bat.pl
@@ -0,0 +1,154 @@
+#!perl -w
+require 5;
+use Getopt::Std;
+
+$0 =~ s|.*[/\\]||;
+
+my $usage = <<EOT;
+Usage: $0 [-h] [-a argstring] [-s stripsuffix] [files]
+ -a argstring arguments to invoke perl with in generated file
+ Defaults to "-x -S %0 %*" on WindowsNT,
+ "-x -S %0 %1 %2 %3 %4 %5 %6 %7 %8 %9" otherwise
+ -s stripsuffix strip this suffix from file before appending ".bat"
+ Not case-sensitive
+ Can be a regex if it begins with `/'
+ Defaults to "/\.pl/"
+ -h show this help
+EOT
+
+my %OPT = ();
+warn($usage), exit(0) if !getopts('ha:s:',\%OPT) or $OPT{'h'};
+$OPT{'a'} = ($^O eq 'MSWin32' and &Win32::IsWinNT
+ ? '-x -S %0 %*'
+ : '-x -S %0 %1 %2 %3 %4 %5 %6 %7 %8 %9')
+ unless exists $OPT{'a'};
+$OPT{'s'} = '.pl' unless exists $OPT{'s'};
+$OPT{'s'} = ($OPT{'s'} =~ m|^/([^/]*)| ? $1 : "\Q$OPT{'s'}\E");
+
+(my $head = <<EOT) =~ s/^\t//gm;
+ \@rem = '--*-Perl-*--
+ \@echo off
+ perl $OPT{'a'}
+ goto endofperl
+ \@rem ';
+EOT
+my $headlines = 2 + ($head =~ tr/\n/\n/);
+my $tail = "__END__\n:endofperl\n";
+
+@ARGV = ('-') unless @ARGV;
+
+process(@ARGV);
+
+sub process {
+ LOOP:
+ foreach ( @_ ) {
+ my $myhead = $head;
+ my $linedone = 0;
+ my $linenum = $headlines;
+ my $line;
+ open( FILE, $_ ) or die "$0: Can't open $_: $!";
+ @file = <FILE>;
+ foreach $line ( @file ) {
+ $linenum++;
+ if ( $line =~ /^:endofperl/) {
+ warn "$0: $_ has already been converted to a batch file!\n";
+ next LOOP;
+ }
+ if ( not $linedone and $line =~ /^#!.*perl/ ) {
+ $line .= "#line $linenum\n";
+ $linedone++;
+ }
+ }
+ close( FILE );
+ s/$OPT{'s'}$//oi;
+ $_ .= '.bat' unless /\.bat$/i or /^-$/;
+ open( FILE, ">$_" ) or die "Can't open $_: $!";
+ print FILE $myhead;
+ print FILE "#!perl\n#line " . ($headlines+1) . "\n" unless $linedone;
+ print FILE @file, $tail;
+ close( FILE );
+ }
+}
+__END__
+
+=head1 NAME
+
+pl2bat - wrap perl code into a batch file
+
+=head1 SYNOPSIS
+
+B<pl2bat> [B<-h>] S<[B<-a> I<argstring>]> S<[B<-s> I<stripsuffix>]> [files]
+
+=head1 DESCRIPTION
+
+This utility converts a perl script into a batch file that can be
+executed on DOS-like operating systems.
+
+Note that by default, the ".pl" suffix will be stripped before adding
+a ".bat" suffix to the supplied file names. This can be controlled
+with the C<-s> option.
+
+The default behavior on WindowsNT is to generate a batch file that
+uses the C<%*> construct to refer to all the command line arguments
+that were given to it, so you'll need to make sure that works on your
+variant of the command shell. It is known to work in the cmd.exe shell
+under WindowsNT. 4DOS/NT users will want to put a C<ParameterChar = *>
+line in their initialization file, or execute C<setdos /p*> in
+the shell startup file. On Windows95 and other platforms a nine
+argument limit is imposed on command-line arguments given to the
+generated batch file, since they may not support C<%*> in batch files.
+This can be overridden using the C<-a> option.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-a> I<argstring>
+
+Arguments to invoke perl with in generated batch file. Defaults to
+S<"-x -S %0 %*"> on WindowsNT, S<"-x -S %0 %1 %2 %3 %4 %5 %6 %7 %8 %9">
+on other platforms.
+
+=item B<-s> I<stripsuffix>
+
+Strip a suffix string from file name before appending a ".bat"
+suffix. The suffix is not case-sensitive. It can be a regex if it
+begins with `/' (the trailing '/' being optional. Defaults to ".pl".
+
+=item B<-h>
+
+Show command line usage.
+
+=back
+
+=head1 EXAMPLES
+
+ C:\> pl2bat foo.pl bar.PM
+ [..creates foo.bat, bar.PM.bat..]
+
+ C:\> pl2bat -s "/\.pl|\.pm/" foo.pl bar.PM
+ [..creates foo.bat, bar.bat..]
+
+ C:\> pl2bat < somefile > another.bat
+
+ C:\> pl2bat > another.bat
+ print scalar reverse "rekcah lrep rehtona tsuj\n";
+ ^Z
+ [..another.bat is now a certified japh application..]
+
+=head1 BUGS
+
+C<$0> will contain the full name, including the ".bat" suffix
+when the generated batch file runs. If you don't like this,
+see runperl.bat for an alternative way to invoke perl scripts.
+
+Default behavior is to invoke Perl with the -S flag, so Perl will
+search the PATH to find the script. This may have undesirable
+effects.
+
+=head1 SEE ALSO
+
+perl, perlwin32, runperl.bat
+
+=cut
+
diff --git a/gnu/usr.bin/perl/win32/bin/runperl.pl b/gnu/usr.bin/perl/win32/bin/runperl.pl
new file mode 100644
index 00000000000..95b33f9342d
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/bin/runperl.pl
@@ -0,0 +1,67 @@
+#!perl -w
+$0 =~ s|\.bat||i;
+unless (-f $0) {
+ $0 =~ s|.*[/\\]||;
+ for (".", split ';', $ENV{PATH}) {
+ $_ = "." if $_ eq "";
+ $0 = "$_/$0" , goto doit if -f "$_/$0";
+ }
+ die "`$0' not found.\n";
+}
+doit: exec "perl", "-x", $0, @ARGV;
+die "Failed to exec `$0': $!";
+__END__
+
+=head1 NAME
+
+runperl.bat - "universal" batch file to run perl scripts
+
+=head1 SYNOPSIS
+
+ C:\> copy runperl.bat foo.bat
+ C:\> foo
+ [..runs the perl script `foo'..]
+
+ C:\> foo.bat
+ [..runs the perl script `foo'..]
+
+
+=head1 DESCRIPTION
+
+This file can be copied to any file name ending in the ".bat" suffix.
+When executed on a DOS-like operating system, it will invoke the perl
+script of the same name, but without the ".bat" suffix. It will
+look for the script in the same directory as itself, and then in
+the current directory, and then search the directories in your PATH.
+
+It relies on the C<exec()> operator, so you will need to make sure
+that works in your perl.
+
+This method of invoking perl scripts has some advantages over
+batch-file wrappers like C<pl2bat.bat>: it avoids duplication
+of all the code; it ensures C<$0> contains the same name as the
+executing file, without any egregious ".bat" suffix; it allows
+you to separate your perl scripts from the wrapper used to
+run them; since the wrapper is generic, you can use symbolic
+links to simply link to C<runperl.bat>, if you are serving your
+files on a filesystem that supports that.
+
+On the other hand, if the batch file is invoked with the ".bat"
+suffix, it does an extra C<exec()>. This may be a performance
+issue. You can avoid this by running it without specifying
+the ".bat" suffix.
+
+Perl is invoked with the -x flag, so the script must contain
+a C<#!perl> line. Any flags found on that line will be honored.
+
+=head1 BUGS
+
+Perl is invoked with the -S flag, so it will search the PATH to find
+the script. This may have undesirable effects.
+
+=head1 SEE ALSO
+
+perl, perlwin32, pl2bat.bat
+
+=cut
+
diff --git a/gnu/usr.bin/perl/win32/bin/search.pl b/gnu/usr.bin/perl/win32/bin/search.pl
new file mode 100644
index 00000000000..b63f7353aff
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/bin/search.pl
@@ -0,0 +1,1865 @@
+#!/usr/local/bin/perl -w
+'di';
+'ig00';
+##############################################################################
+##
+## search
+##
+## Jeffrey Friedl (jfriedl@omron.co.jp), Dec 1994.
+## Copyright 19.... ah hell, just take it.
+##
+## BLURB:
+## A combo of find and grep -- more or less do a 'grep' on a whole
+## directory tree. Fast, with lots of options. Much more powerful than
+## the simple "find ... | xargs grep ....". Has a full man page.
+## Powerfully customizable.
+##
+## This file is big, but mostly comments and man page.
+##
+## See man page for usage info.
+## Return value: 2=error, 1=nothing found, 0=something found.
+##
+
+$version = "950918.5";
+##
+## "950918.5";
+## Changed all 'sysread' to 'read' because Linux perl's don't seem
+## to like sysread()
+##
+## "941227.4";
+## Added -n, -u
+##
+## "941222.3"
+## Added -nice (due to Lionel Cons <Lionel.Cons@cern.ch>)
+## Removed any leading "./" from name.
+## Added default flags for ~/.search, including TTY, -nice, -list, etc.
+## Program name now has path removed when printed in diagnostics.
+## Added simple tilde-expansion to -dir arg.
+## Added -dskip, etc. Fixed -iregex bug.
+## Changed -dir to be additive, adding -ddir.
+## Now screen out devices, pipes, and sockets.
+## More tidying and lots of expanding of the man page
+##
+##
+## "941217.2";
+## initial release.
+
+$stripped=0;
+
+&init;
+$rc_file = join('/', $ENV{'HOME'}, ".search");
+
+&check_args;
+
+## Make sure we've got a regex.
+## Don't need one if -find or -showrc was specified.
+$!=2, die "expecting regex arguments.\n"
+ if $FIND_ONLY == 0 && $showrc == 0 && @ARGV == 0;
+
+&prepare_to_search($rc_file);
+
+&import_program if !defined &dodir; ## BIG key to speed.
+
+## do search while there are directories to be done.
+&dodir(shift(@todo)) while @todo;
+
+&clear_message if $VERBOSE && $STDERR_IS_TTY;
+exit($retval);
+###############################################################################
+
+sub init
+{
+ ## initialize variables that might be reset by command-line args
+ $DOREP=0; ## set true by -dorep (redo multi-hardlink files)
+ $DO_SORT=0; ## set by -sort (sort files in a dir before checking)
+ $FIND_ONLY=0; ## set by -find (don't search files)
+ $LIST_ONLY=0; ## set true by -l (list filenames only)
+ $NEWER=0; ## set by -newer, "-mtime -###"
+ $NICE=0; ## set by -nice (print human-readable output)
+ $NOLINKS=0; ## set true by -nolinks (don't follow symlinks)
+ $OLDER=0; ## set by -older, "-mtime ###"
+ $PREPEND_FILENAME=1; ## set false by -h (don't prefix lines with filename)
+ $REPORT_LINENUM=0; ## set true by -n (show line numbers)
+ $VERBOSE=0; ## set to a value by -v, -vv, etc. (verbose messages)
+ $WHY=0; ## set true by -why, -vvv+ (report why skipped)
+ $XDEV=0; ## set true by -xdev (stay on one filesystem)
+ $all=0; ## set true by -all (don't skip many kinds of files)
+ $iflag = ''; ## set to 'i' by -i (ignore case);
+ $norc=0; ## set by -norc (don't load rc file)
+ $showrc=0; ## set by -showrc (show what happens with rc file)
+ $underlineOK=0; ## set true by -u (watch for underline stuff)
+ $words=0; ## set true by -w (match whole-words only)
+ $DELAY=0; ## inter-file delay (seconds)
+ $retval=1; ## will set to 0 if we find anything.
+
+ ## various elements of stat() that we might access
+ $STAT_DEV = 1;
+ $STAT_INODE = 2;
+ $STAT_MTIME = 9;
+
+ $VV_PRINT_COUNT = 50; ## with -vv, print every VV_PRINT_COUNT files, or...
+ $VV_SIZE = 1024*1024; ## ...every VV_SIZE bytes searched
+ $vv_print = $vv_size = 0; ## running totals.
+
+ ## set default options, in case the rc file wants them
+ $opt{'TTY'}= 1 if -t STDOUT;
+
+ ## want to know this for debugging message stuff
+ $STDERR_IS_TTY = -t STDERR ? 1 : 0;
+ $STDERR_SCREWS_STDOUT = ($STDERR_IS_TTY && -t STDOUT) ? 1 : 0;
+
+ $0 =~ s,.*/,,; ## clean up $0 for any diagnostics we'll be printing.
+}
+
+##
+## Check arguments.
+##
+sub check_args
+{
+ while (@ARGV && $ARGV[0] =~ m/^-/)
+ {
+ $arg = shift(@ARGV);
+
+ if ($arg eq '-version' || ($VERBOSE && $arg eq '-help')) {
+ print qq/Jeffrey's file search, version "$version".\n/;
+ exit(0) unless $arg eq '-help';
+ }
+ if ($arg eq '-help') {
+ print <<INLINE_LITERAL_TEXT;
+usage: $0 [options] [-e] [PerlRegex ....]
+OPTIONS TELLING *WHERE* TO SEARCH:
+ -dir DIR start search at the named directory (default is current dir).
+ -xdev stay on starting file system.
+ -sort sort the files in each directory before processing.
+ -nolinks don't follow symbolic links.
+OPTIONS TELLING WHICH FILES TO EVEN CONSIDER:
+ -mtime # consider files modified > # days ago (-# for < # days old)
+ -newer FILE consider files modified more recently than FILE (also -older)
+ -name GLOB consider files whose name matches pattern (also -regex).
+ -skip GLOB opposite of -name: identifies files to not consider.
+ -path GLOB like -name, but for files whose whole path is described.
+ -dpath/-dregex/-dskip versions for selecting or pruning directories.
+ -all don't skip any files marked to be skipped by the startup file.
+ -x<SPECIAL> (see manual, and/or try -showrc).
+ -why report why a file isn't checked (also implied by -vvvv).
+OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED:
+ -f | -find just list files (PerlRegex ignored). Default is to grep them.
+ -ff | -ffind Does a faster -find (implies -find -all -dorep)
+OPTIONS CONTROLLING HOW THE SEARCH IS DONE (AND WHAT IS PRINTED):
+ -l | -list only list files with matches, not the lines themselves.
+ -nice | -nnice print more "human readable" output.
+ -n prefix each output line with its line number in the file.
+ -h don't prefix output lines with file name.
+ -u also look "inside" manpage-style underlined text
+ -i do case-insensitive searching.
+ -w match words only (as defined by perl's \\b).
+OTHER OPTIONS:
+ -v, -vv, -vvv various levels of message verbosity.
+ -e end of options (in case a regex looks like an option).
+ -showrc show what the rc file sets, then exit.
+ -norc don't load the rc file.
+ -dorep check files with multiple hard links multiple times.
+INLINE_LITERAL_TEXT
+ print "Use -v -help for more verbose help.\n" unless $VERBOSE;
+ print "This script file is also a man page.\n" unless $stripped;
+ print <<INLINE_LITERAL_TEXT if $VERBOSE;
+
+If -f (or -find) given, PerlRegex is optional and ignored.
+Otherwise, will search for files with lines matching any of the given regexes.
+
+Combining things like -name and -mtime implies boolean AND.
+However, duplicating things (such as -name '*.c' -name '*.txt') implies OR.
+
+-mtime may be given floating point (i.e. 1.5 is a day and a half).
+-iskip/-idskip/-ipath/... etc are case-insensitive versions.
+
+If any letter in -newer/-older is upper case, "or equal" is
+inserted into the test.
+
+You can always find the latest version on the World Wide Web in
+ http://www.wg.omron.co.jp/~jfriedl/perl/
+INLINE_LITERAL_TEXT
+ exit(0);
+ }
+ $DOREP=1, next if $arg eq '-dorep'; ## do repeats
+ $DO_SORT=1, next if $arg eq '-sort'; ## sort files
+ $NOLINKS=1, next if $arg eq '-nolinks'; ## no sym. links
+ $PREPEND_FILENAME=0, next if $arg eq '-h'; ## no filename prefix
+ $REPORT_LINENUM=1, next if $arg eq '-n'; ## show line numbers
+ $WHY=1, next if $arg eq '-why'; ## tell why skipped
+ $XDEV=1, next if $arg eq '-xdev'; ## don't leave F.S.
+ $all=1,$opt{'-all'}=1,next if $arg eq '-all'; ## don't skip *.Z, etc
+ $iflag='i', next if $arg eq '-i'; ## ignore case
+ $norc=1, next if $arg eq '-norc'; ## don't load rc file
+ $showrc=1, next if $arg eq '-showrc'; ## show rc file
+ $underlineOK=1, next if $arg eq '-u'; ## look throuh underln.
+ $words=1, next if $arg eq '-w'; ## match "words" only
+ &strip if $arg eq '-strip'; ## dump this program
+ last if $arg eq '-e';
+ $DELAY=$1, next if $arg =~ m/-delay(\d+)/;
+
+ $FIND_ONLY=1, next if $arg =~/^-f(ind)?$/;## do "find" only
+
+ $FIND_ONLY=1, $DOREP=1, $all=1,
+ next if $arg =~/^-ff(ind)?$/;## fast -find
+ $LIST_ONLY=1,$opt{'-list'}=1,
+ next if $arg =~/^-l(ist)?$/;## only list files
+
+ if ($arg =~ m/^-(v+)$/) { ## verbosity
+ $VERBOSE =length($1);
+ foreach $len (1..$VERBOSE) { $opt{'-'.('v' x $len)}=1 }
+ next;
+ }
+ if ($arg =~ m/^-(n+)ice$/) { ## "nice" output
+ $NICE =length($1);
+ foreach $len (1..$NICE) { $opt{'-'.('n' x $len).'ice'}=1 }
+ next;
+ }
+
+ if ($arg =~ m/^-(i?)(d?)skip$/) {
+ local($i) = $1 eq 'i';
+ local($d) = $2 eq 'd';
+ $! = 2, die qq/$0: expecting glob arg to -$arg\n/ unless @ARGV;
+ foreach (split(/\s+/, shift @ARGV)) {
+ if ($d) {
+ $idskip{$_}=1 if $i;
+ $dskip{$_}=1;
+ } else {
+ $iskip{$_}=1 if $i;
+ $skip{$_}=1;
+ }
+ }
+ next;
+ }
+
+
+ if ($arg =~ m/^-(i?)(d?)(regex|path|name)$/) {
+ local($i) = $1 eq 'i';
+ $! = 2, die qq/$0: expecting arg to -$arg\n/ unless @ARGV;
+ foreach (split(/\s+/, shift @ARGV)) {
+ $iname{join(',', $arg, $_)}=1 if $i;
+ $name{join(',', $arg, $_)}=1;
+ }
+ next;
+ }
+
+ if ($arg =~ m/^-d?dir$/) {
+ $opt{'-dir'}=1;
+ $! = 2, die qq/$0: expecting filename arg to -$arg\n/ unless @ARGV;
+ $start = shift(@ARGV);
+ $start =~ s#^~(/+|$)#$ENV{'HOME'}$1# if defined $ENV{'HOME'};
+ $! = 2, die qq/$0: can't find ${arg}'s "$start"\n/ unless -e $start;
+ $! = 2, die qq/$0: ${arg}'s "$start" not a directory.\n/ unless -d _;
+ undef(@todo), $opt{'-ddir'}=1 if $arg eq '-ddir';
+ push(@todo, $start);
+ next;
+ }
+
+ if ($arg =~ m/^-(new|old)er$/i) {
+ $! = 2, die "$0: expecting filename arg to -$arg\n" unless @ARGV;
+ local($file, $time) = shift(@ARGV);
+ $! = 2, die qq/$0: can't stat -${arg}'s "$file"./
+ unless $time = (stat($file))[$STAT_MTIME];
+ local($upper) = $arg =~ tr/A-Z//;
+ if ($arg =~ m/new/i) {
+ $time++ unless $upper;
+ $NEWER = $time if $NEWER < $time;
+ } else {
+ $time-- unless $upper;
+ $OLDER = $time if $OLDER == 0 || $OLDER > $time;
+ }
+ next;
+ }
+
+ if ($arg =~ m/-mtime/) {
+ $! = 2, die "$0: expecting numerical arg to -$arg\n" unless @ARGV;
+ local($days) = shift(@ARGV);
+ $! = 2, die qq/$0: inappropriate arg ($days) to $arg\n/ if $days==0;
+ $days *= 3600 * 24;
+ if ($days < 0) {
+ local($time) = $^T + $days;
+ $NEWER = $time if $NEWER < $time;
+ } else {
+ local($time) = $^T - $days;
+ $OLDER = $time if $OLDER == 0 || $OLDER > $time;
+ }
+ next;
+ }
+
+ ## special user options
+ if ($arg =~ m/^-x(.+)/) {
+ foreach (split(/[\s,]+/, $1)) { $user_opt{$_} = $opt{$_}= 1; }
+ next;
+ }
+
+ $! = 2, die "$0: unknown arg [$arg]\n";
+ }
+}
+
+##
+## Given a filename glob, return a regex.
+## If the glob has no globbing chars (no * ? or [..]), then
+## prepend an effective '*' to it.
+##
+sub glob_to_regex
+{
+ local($glob) = @_;
+ local(@parts) = $glob =~ m/\\.|[*?]|\[]?[^]]*]|[^[\\*?]+/g;
+ local($trueglob)=0;
+ foreach (@parts) {
+ if ($_ eq '*' || $_ eq '?') {
+ $_ = ".$_";
+ $trueglob=1; ## * and ? are a real glob
+ } elsif (substr($_, 0, 1) eq '[') {
+ $trueglob=1; ## [..] is a real glob
+ } else {
+ s/^\\//; ## remove any leading backslash;
+ s/\W/\\$&/g; ## now quote anything dangerous;
+ }
+ }
+ unshift(@parts, '.*') unless $trueglob;
+ join('', '^', @parts, '$');
+}
+
+sub prepare_to_search
+{
+ local($rc_file) = @_;
+
+ $HEADER_BYTES=0; ## Might be set nonzero in &read_rc;
+ $last_message_length = 0; ## For &message and &clear_message.
+
+ &read_rc($rc_file, $showrc) unless $norc;
+ exit(0) if $showrc;
+
+ $NEXT_DIR_ENTRY = $DO_SORT ? 'shift @files' : 'readdir(DIR)';
+ $WHY = 1 if $VERBOSE > 3; ## Arg -vvvv or above implies -why.
+ @todo = ('.') if @todo == 0; ## Where we'll start looking
+
+ ## see if any user options were specified that weren't accounted for
+ foreach $opt (keys %user_opt) {
+ next if defined $seen_opt{$opt};
+ warn "warning: -x$opt never considered.\n";
+ }
+
+ die "$0: multiple time constraints exclude all possible files.\n"
+ if ($NEWER && $OLDER) && ($NEWER > $OLDER);
+
+ ##
+ ## Process any -skip/-iskip args that had been given
+ ##
+ local(@skip_test);
+ foreach $glob (keys %skip) {
+ $i = defined($iskip{$glob}) ? 'i': '';
+ push(@skip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i");
+ }
+ if (@skip_test) {
+ $SKIP_TEST = join('||',@skip_test);
+ $DO_SKIP_TEST = 1;
+ } else {
+ $DO_SKIP_TEST = $SKIP_TEST = 0;
+ }
+
+ ##
+ ## Process any -dskip/-idskip args that had been given
+ ##
+ local(@dskip_test);
+ foreach $glob (keys %dskip) {
+ $i = defined($idskip{$glob}) ? 'i': '';
+ push(@dskip_test, '$name =~ m/'. &glob_to_regex($glob). "/$i");
+ }
+ if (@dskip_test) {
+ $DSKIP_TEST = join('||',@dskip_test);
+ $DO_DSKIP_TEST = 1;
+ } else {
+ $DO_DSKIP_TEST = $DSKIP_TEST = 0;
+ }
+
+
+ ##
+ ## Process any -name, -path, -regex, etc. args that had been given.
+ ##
+ undef @name_test;
+ undef @dname_test;
+ foreach $key (keys %name) {
+ local($type, $pat) = split(/,/, $key, 2);
+ local($i) = defined($iname{$key}) ? 'i' : '';
+ if ($type =~ /regex/) {
+ $pat =~ s/!/\\!/g;
+ $test = "\$name =~ m!^$pat\$!$i";
+ } else {
+ local($var) = $type eq 'name' ? '$name' : '$file';
+ $test = "$var =~ m/". &glob_to_regex($pat). "/$i";
+ }
+ if ($type =~ m/^-i?d/) {
+ push(@dname_test, $test);
+ } else {
+ push(@name_test, $test);
+ }
+ }
+ if (@name_test) {
+ $GLOB_TESTS = join('||', @name_test);
+
+ $DO_GLOB_TESTS = 1;
+ } else {
+ $GLOB_TESTS = $DO_GLOB_TESTS = 0;
+ }
+ if (@dname_test) {
+ $DGLOB_TESTS = join('||', @dname_test);
+ $DO_DGLOB_TESTS = 1;
+ } else {
+ $DGLOB_TESTS = $DO_DGLOB_TESTS = 0;
+ }
+
+
+ ##
+ ## Process any 'magic' things from the startup file.
+ ##
+ if (@magic_tests && $HEADER_BYTES) {
+ ## the $magic' one is for when &dodir is not inlined
+ $tests = join('||',@magic_tests);
+ $MAGIC_TESTS = " { package magic; \$val = ($tests) }";
+ $DO_MAGIC_TESTS = 1;
+ } else {
+ $MAGIC_TESTS = 1;
+ $DO_MAGIC_TESTS = 0;
+ }
+
+ ##
+ ## Prepare regular expressions.
+ ##
+ {
+ local(@regex_tests);
+
+ if ($LIST_ONLY) {
+ $mflag = '';
+ ## need to have $* set, but perl5 just won''t shut up about it.
+ if ($] >= 5) {
+ $mflag = 'm';
+ } else {
+ eval ' $* = 1 ';
+ }
+ }
+
+ ##
+ ## Until I figure out a better way to deal with it,
+ ## We have to worry about a regex like [^xyz] when doing $LIST_ONLY.
+ ## Such a regex *will* match \n, and if I'm pulling in multiple
+ ## lines, it can allow lines to match that would otherwise not match.
+ ##
+ ## Therefore, if there is a '[^' in a regex, we can NOT take a chance
+ ## an use the fast listonly.
+ ##
+ $CAN_USE_FAST_LISTONLY = $LIST_ONLY;
+
+ local(@extra);
+ local($underline_glue) = ($] >= 5) ? '(:?_\cH)?' : '(_\cH)?';
+ while (@ARGV) {
+ $regex = shift(@ARGV);
+ ##
+ ## If watching for underlined things too, add another regex.
+ ##
+ if ($underlineOK) {
+ if ($regex =~ m/[?*+{}()\\.|^\$[]/) {
+ warn "$0: warning, can't underline-safe ``$regex''.\n";
+ } else {
+ $regex = join($underline_glue, split(//, $regex));
+ }
+ }
+
+ ## If nothing special in the regex, just use index...
+ ## is quite a bit faster.
+ if (($iflag eq '') && ($words == 0) &&
+ $regex !~ m/[?*+{}()\\.|^\$[]/)
+ {
+ push(@regex_tests, "(index(\$_, q+$regex+)>=0)");
+
+ } else {
+ $regex =~ s#[\$\@\/]\w#\\$&#;
+ if ($words) {
+ if ($regex =~ m/\|/) {
+ ## could be dangerous -- see if we can wrap in parens.
+ if ($regex =~ m/\\\d/) {
+ warn "warning: -w and a | in a regex is dangerous.\n"
+ } else {
+ $regex = join($regex, '(', ')');
+ }
+ }
+ $regex = join($regex, '\b', '\b');
+ }
+ $CAN_USE_FAST_LISTONLY = 0 if substr($regex, "[^") >= 0;
+ push(@regex_tests, "m/$regex/$iflag$mflag");
+ }
+
+ ## If we're done, but still have @extra to do, get set for that.
+ if (@ARGV == 0 && @extra) {
+ @ARGV = @extra; ## now deal with the extra stuff.
+ $underlineOK = 0; ## but no more of this.
+ undef @extra; ## or this.
+ }
+ }
+ if (@regex_tests) {
+ $REGEX_TEST = join('||', @regex_tests);
+ ## print STDERR $REGEX_TEST, "\n"; exit;
+ } else {
+ ## must be doing -find -- just give something syntactically correct.
+ $REGEX_TEST = 1;
+ }
+ }
+
+ ##
+ ## Make sure we can read the first item(s).
+ ##
+ foreach $start (@todo) {
+ $! = 2, die qq/$0: can't stat "$start"\n/
+ unless ($dev,$inode) = (stat($start))[$STAT_DEV,$STAT_INODE];
+
+ if (defined $dir_done{"$dev,$inode"}) {
+ ## ignore the repeat.
+ warn(qq/ignoring "$start" (same as "$dir_done{"$dev,$inode"}").\n/)
+ if $VERBOSE;
+ next;
+ }
+
+ ## if -xdev was given, remember the device.
+ $xdev{$dev} = 1 if $XDEV;
+
+ ## Note that we won't want to do it again
+ $dir_done{"$dev,$inode"} = $start;
+ }
+}
+
+
+##
+## See the comment above the __END__ above the 'sub dodir' below.
+##
+sub import_program
+{
+ sub bad {
+ print STDERR "$0: internal error (@_)\n";
+ exit 2;
+ }
+
+ ## Read from data, up to next __END__. This will be &dodir.
+ local($/) = "\n__END__";
+ $prog = <DATA>;
+ close(DATA);
+
+ $prog =~ s/\beval\b//g; ## remove any 'eval'
+
+ ## Inline uppercase $-variables by their current values.
+ if ($] >= 5) {
+ $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/
+ &bad($1) if !defined ${$main::{$1}}; ${$main::{$1}};/eg;
+ } else {
+ $prog =~ s/\$([A-Z][A-Z0-9_]{2,}\b)/local(*VAR) = $_main{$1};
+ &bad($1) if !defined $VAR; $VAR;/eg;
+ }
+
+ eval $prog; ## now do it. This will define &dodir;
+ $!=2, die "$0 internal error: $@\n" if $@;
+}
+
+###########################################################################
+
+##
+## Read the .search file:
+## Blank lines and lines that are only #-comments ignored.
+## Newlines may be escaped to create long lines
+## Other lines are directives.
+##
+## A directive may begin with an optional tag in the form <...>
+## Things inside the <...> are evaluated as with:
+## <(this || that) && must>
+## will be true if
+## -xmust -xthis or -xmust -xthat
+## were specified on the command line (order doesn't matter, though)
+## A directive is not done if there is a tag and it's false.
+## Any characters but whitespace and &|()>,! may appear after an -x
+## (although "-xdev" is special). -xmust,this is the same as -xmust -xthis.
+## Something like -x~ would make <~> true, and <!~> false.
+##
+## Directives are in the form:
+## option: STRING
+## magic : NUMBYTES : EXPR
+##
+## With option:
+## The STRING is parsed like a Bourne shell command line, and the
+## options are used as if given on the command line.
+## No comments are allowed on 'option' lines.
+## Examples:
+## # skip objects and libraries
+## option: -skip '.o .a'
+## # skip emacs *~ and *# files, unless -x~ given:
+## <!~> option: -skip '~ #'
+##
+## With magic:
+## EXPR can be pretty much any perl (comments allowed!).
+## If it evaluates to true for any particular file, it is skipped.
+## The only info you'll have about a file is the variable $H, which
+## will have at least the first NUMBYTES of the file (less if the file
+## is shorter than that, of course, and maybe more). You'll also have
+## any variables you set in previous 'magic' lines.
+## Examples:
+## magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a'
+## magic: 6 : $x6 eq 'GIF89a'
+##
+## magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a' ## old gif \
+## || $x6 eq 'GIF89a' ## new gif
+## (the above two sets are the same)
+## ## Check the first 32 bytes for "binarish" looking bytes.
+## ## Don't blindly dump on any high-bit set, as non-ASCII text
+## ## often has them set. \x80 and \xff seem to be special, though.
+## ## Require two in a row to not get things like perl's $^T.
+## ## This is known to get *.Z, *.gz, pkzip, *.elc and about any
+## ## executable you'll find.
+## magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/
+##
+sub read_rc
+{
+ local($file, $show) = @_;
+ local($line_num, $ln, $tag) = 0;
+ local($use_default, @default) = 0;
+
+ { package magic; $ = 0; } ## turn off warnings for when we run EXPR's
+
+ unless (open(RC, "$file")) {
+ $use_default=1;
+ $file = "<internal default startup file>";
+ ## no RC file -- use this default.
+ @default = split(/\n/,<<'--------INLINE_LITERAL_TEXT');
+ magic: 32 : $H =~ m/[\x00-\x06\x10-\x1a\x1c-\x1f\x80\xff]{2}/
+ option: -skip '.a .COM .elc .EXE .gz .o .pbm .xbm .dvi'
+ option: -iskip '.tarz .zip .z .lzh .jpg .jpeg .gif .uu'
+ <!~> option: -skip '~ #'
+--------INLINE_LITERAL_TEXT
+ }
+
+ ##
+ ## Make an eval error pretty.
+ ##
+ sub clean_eval_error {
+ local($_) = @_;
+ s/ in file \(eval\) at line \d+,//g; ## perl4-style error
+ s/ at \(eval \d+\) line \d+,//g; ## perl5-style error
+ $_ = $` if m/\n/; ## remove all but first line
+ "$_\n";
+ }
+
+ print "reading RC file: $file\n" if $show;
+
+ while (defined($_ = ($use_default ? shift(@default) : <RC>))) {
+ $ln = ++$line_num; ## note starting line num.
+ $_ .= <RC>, $line_num++ while s/\\\n?$/\n/; ## allow continuations
+ next if /^\s*(#.*)?$/; ## skip blank or comment-only lines.
+ $do = '';
+
+ ## look for an initial <...> tag.
+ if (s/^\s*<([^>]*)>//) {
+ ## This simple s// will make the tag ready to eval.
+ ($tag = $msg = $1) =~
+ s/[^\s&|(!)]+/
+ $seen_opt{$&}=1; ## note seen option
+ "defined(\$opt{q>$&>})" ## (q>> is safe quoting here)
+ /eg;
+
+ ## see if the tag is true or not, abort this line if not.
+ $dothis = (eval $tag);
+ $!=2, die "$file $ln <$msg>: $_".&clean_eval_error($@) if $@;
+
+ if ($show) {
+ $msg =~ s/[^\s&|(!)]+/-x$&/;
+ $msg =~ s/\s*!\s*/ no /g;
+ $msg =~ s/\s*&&\s*/ and /g;
+ $msg =~ s/\s*\|\|\s*/ or /g;
+ $msg =~ s/^\s+//; $msg =~ s/\s+$//;
+ $do = $dothis ? "(doing because $msg)" :
+ "(do if $msg)";
+ } elsif (!$dothis) {
+ next;
+ }
+ }
+
+ if (m/^\s*option\s*:\s*/) {
+ next if $all && !$show; ## -all turns off these checks;
+ local($_) = $';
+ s/\n$//;
+ local($orig) = $_;
+ print " $do option: $_\n" if $show;
+ local($0) = "$0 ($file)"; ## for any error message.
+ local(@ARGV);
+ local($this);
+ ##
+ ## Parse $_ as a Bourne shell line -- fill @ARGV
+ ##
+ while (length) {
+ if (s/^\s+//) {
+ push(@ARGV, $this) if defined $this;
+ undef $this;
+ next;
+ }
+ $this = '' if !defined $this;
+ $this .= $1 while s/^'([^']*)'// ||
+ s/^"([^"]*)"// ||
+ s/^([^'"\s\\]+)//||
+ s/^(\\[\D\d])//;
+ die "$file $ln: error parsing $orig at $_\n" if m/^\S/;
+ }
+ push(@ARGV, $this) if defined $this;
+ &check_args;
+ die qq/$file $ln: unused arg "@ARGV".\n/ if @ARGV;
+ next;
+ }
+
+ if (m/^\s*magic\s*:\s*(\d+)\s*:\s*/) {
+ next if $all && !$show; ## -all turns off these checks;
+ local($bytes, $check) = ($1, $');
+
+ if ($show) {
+ $check =~ s/\n?$/\n/;
+ print " $do contents: $check";
+ }
+ ## Check to make sure the thing at least compiles.
+ eval "package magic; (\$H = '1'x \$main'bytes) && (\n$check\n)\n";
+ $! = 2, die "$file $ln: ".&clean_eval_error($@) if $@;
+
+ $HEADER_BYTES = $bytes if $bytes > $HEADER_BYTES;
+ push(@magic_tests, "(\n$check\n)");
+ next;
+ }
+ $! = 2, die "$file $ln: unknown command\n";
+ }
+ close(RC);
+}
+
+sub message
+{
+ if (!$STDERR_IS_TTY) {
+ print STDERR $_[0], "\n";
+ } else {
+ local($text) = @_;
+ $thislength = length($text);
+ if ($thislength >= $last_message_length) {
+ print STDERR $text, "\r";
+ } else {
+ print STDERR $text, ' 'x ($last_message_length-$thislength),"\r";
+ }
+ $last_message_length = $thislength;
+ }
+}
+
+sub clear_message
+{
+ print STDERR ' ' x $last_message_length, "\r" if $last_message_length;
+ $vv_print = $vv_size = $last_message_length = 0;
+}
+
+##
+## Output a copy of this program with comments, extra whitespace, and
+## the trailing man page removed. On an ultra slow machine, such a copy
+## might load faster (but I can't tell any difference on my machine).
+##
+sub strip {
+ seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n";
+ while(<DATA>) {
+ print, next if /INLINE_LITERAL_TEXT/.../INLINE_LITERAL_TEXT/;
+ ## must mention INLINE_LITERAL_TEXT on this line!
+ s/\#\#.*|^\s+|\s+$//; ## remove cruft
+ last if $_ eq '.00;';
+ next if ($_ eq '') || ($_ eq "'di'") || ($_ eq "'ig00'");
+ s/\$stripped=0;/\$stripped=1;/;
+ s/\s\s+/ /; ## squish multiple whitespaces down to one.
+ print $_, "\n";
+ }
+ exit(0);
+}
+
+##
+## Just to shut up -w. Never executed.
+##
+sub dummy {
+
+ 1 || &dummy || &dir_done || &bad || &message || $NEXT_DIR_ENTRY ||
+ $DELAY || $VV_SIZE || $VV_PRINT_COUNT || $STDERR_SCREWS_STDOUT ||
+ @files || @files || $magic'H || $magic'H || $xdev{''} || &clear_message;
+
+}
+
+##
+## If the following __END__ is in place, what follows will be
+## inlined when the program first starts up. Any $ variable name
+## all in upper case, specifically, any string matching
+## \$([A-Z][A-Z0-9_]{2,}\b
+## will have the true value for that variable inlined. Also, any 'eval' is
+## removed
+##
+## The idea is that when the whole thing is then eval'ed to define &dodir,
+## the perl optimizer will make all the decisions that are based upon
+## command-line options (such as $VERBOSE), since they'll be inlined as
+## constants
+##
+## Also, and here's the big win, the tests for matching the regex, and a
+## few others, are all inlined. Should be blinding speed here.
+##
+## See the read from <DATA> above for where all this takes place.
+## But all-in-all, you *want* the __END__ here. Comment it out only for
+## debugging....
+##
+
+__END__
+
+##
+## Given a directory, check all "appropriate" files in it.
+## Shove any subdirectories into the global @todo, so they'll be done
+## later.
+##
+## Be careful about adding any upper-case variables, as they are subject
+## to being inlined. See comments above the __END__ above.
+##
+sub dodir
+{
+ local($dir) = @_;
+ $dir =~ s,/+$,,; ## remove any trailing slash.
+ unless (opendir(DIR, "$dir/.")) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq($0: can't opendir "$dir/".\n);
+ return;
+ }
+
+ if ($VERBOSE) {
+ &message($dir);
+ $vv_print = $vv_size = 0;
+ }
+
+ @files = sort readdir(DIR) if $DO_SORT;
+
+ while (defined($name = eval $NEXT_DIR_ENTRY))
+ {
+ next if $name eq '.' || $name eq '..'; ## never follow these.
+
+ ## create full relative pathname.
+ $file = $dir eq '.' ? $name : "$dir/$name";
+
+ ## if link and skipping them, do so.
+ if ($NOLINKS && -l $file) {
+ warn qq/skip (symlink): $file\n/ if $WHY;
+ next;
+ }
+
+ ## skip things unless files or directories
+ unless (-f $file || -d _) {
+ if ($WHY) {
+ $why = (-S _ && "socket") ||
+ (-p _ && "pipe") ||
+ (-b _ && "block special")||
+ (-c _ && "char special") || "somekinda special";
+ warn qq/skip ($why): $file\n/;
+ }
+ next;
+ }
+
+ ## skip things we can't read
+ unless (-r _) {
+ if ($WHY) {
+ $why = (-l $file) ? "follow" : "read";
+ warn qq/skip (can't $why): $file\n/;
+ }
+ next;
+ }
+
+ ## skip things that are empty
+ unless (-s _) {
+ warn qq/skip (empty): $file\n/ if $WHY;
+ next;
+ }
+
+ ## Note file device & inode. If -xdev, skip if appropriate.
+ ($dev, $inode) = (stat(_))[$STAT_DEV, $STAT_INODE];
+ if ($XDEV && defined $xdev{$dev}) {
+ warn qq/skip (other device): $file\n/ if $WHY;
+ next;
+ }
+ $id = "$dev,$inode";
+
+ ## special work for a directory
+ if (-d _) {
+ ## Do checks for directory file endings.
+ if ($DO_DSKIP_TEST && (eval $DSKIP_TEST)) {
+ warn qq/skip (-dskip): $file\n/ if $WHY;
+ next;
+ }
+ ## do checks for -name/-regex/-path tests
+ if ($DO_DGLOB_TESTS && !(eval $DGLOB_TESTS)) {
+ warn qq/skip (dirname): $file\n/ if $WHY;
+ next;
+ }
+
+ ## _never_ redo a directory
+ if (defined $dir_done{$id}) {
+ warn qq/skip (did as "$dir_done{$id}"): $file\n/ if $WHY;
+ next;
+ }
+ $dir_done{$id} = $file; ## mark it done.
+ unshift(@todo, $file); ## add to the list to do.
+ next;
+ }
+ if ($WHY == 0 && $VERBOSE > 1) {
+ if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){
+ &message($file);
+ $vv_print = $vv_size = 0;
+ }
+ }
+
+ ## do time-related tests
+ if ($NEWER || $OLDER) {
+ $_ = (stat(_))[$STAT_MTIME];
+ if ($NEWER && $_ < $NEWER) {
+ warn qq/skip (too old): $file\n/ if $WHY;
+ next;
+ }
+ if ($OLDER && $_ > $OLDER) {
+ warn qq/skip (too new): $file\n/ if $WHY;
+ next;
+ }
+ }
+
+ ## do checks for file endings
+ if ($DO_SKIP_TEST && (eval $SKIP_TEST)) {
+ warn qq/skip (-skip): $file\n/ if $WHY;
+ next;
+ }
+
+ ## do checks for -name/-regex/-path tests
+ if ($DO_GLOB_TESTS && !(eval $GLOB_TESTS)) {
+ warn qq/skip (filename): $file\n/ if $WHY;
+ next;
+ }
+
+
+ ## If we're not repeating files,
+ ## skip this one if we've done it, or note we're doing it.
+ unless ($DOREP) {
+ if (defined $file_done{$id}) {
+ warn qq/skip (did as "$file_done{$id}"): $file\n/ if $WHY;
+ next;
+ }
+ $file_done{$id} = $file;
+ }
+
+ if ($DO_MAGIC_TESTS) {
+ if (!open(FILE_IN, $file)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't open: $file\n/;
+ next;
+ }
+ unless (read(FILE_IN, $magic'H, $HEADER_BYTES)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't read from "$file"\n"/;
+ close(FILE_IN);
+ next;
+ }
+
+ eval $MAGIC_TESTS;
+ if ($magic'val) {
+ close(FILE_IN);
+ warn qq/skip (magic): $file\n/ if $WHY;
+ next;
+ }
+ seek(FILE_IN, 0, 0); ## reset for later <FILE_IN>
+ }
+
+ if ($WHY != 0 && $VERBOSE > 1) {
+ if ($VERBOSE>2||$vv_print++>$VV_PRINT_COUNT||($vv_size+=-s _)>$VV_SIZE){
+ &message($file);
+ $vv_print = $vv_size = 0;
+ }
+ }
+
+ if ($DELAY) {
+ sleep($DELAY);
+ }
+
+ if ($FIND_ONLY) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ print $file, "\n";
+ $retval=0; ## we've found something
+ close(FILE_IN) if $DO_MAGIC_TESTS;
+ next;
+ } else {
+ ## if we weren't doing magic tests, file won't be open yet...
+ if (!$DO_MAGIC_TESTS && !open(FILE_IN, $file)) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ warn qq/$0: can't open: $file\n/;
+ next;
+ }
+ if ($LIST_ONLY && $CAN_USE_FAST_LISTONLY) {
+ ##
+ ## This is rather complex, but buys us a LOT when we're just
+ ## listing files and not the individual internal lines.
+ ##
+ local($size) = 4096; ## block-size in which to do reads
+ local($nl); ## will point to $_'s ending newline.
+ local($read); ## will be how many bytes read.
+ local($_) = ''; ## Starts out empty
+ local($hold); ## (see below)
+
+ while (($read = read(FILE_IN,$_,$size,length($_)))||length($_))
+ {
+ undef @parts;
+ ## if read a full block, but no newline, need to read more.
+ while ($read == $size && ($nl = rindex($_, "\n")) < 0) {
+ push(@parts, $_); ## save that part
+ $read = read(FILE_IN, $_, $size); ## keep trying
+ }
+
+ ##
+ ## If we had to save parts, must now combine them together.
+ ## adjusting $nl to reflect the now-larger $_. This should
+ ## be a lot more efficient than using any kind of .= in the
+ ## loop above.
+ ##
+ if (@parts) {
+ local($lastlen) = length($_); #only need if $nl >= 0
+ $_ = join('', @parts, $_);
+ $nl = length($_) - ($lastlen - $nl) if $nl >= 0;
+ }
+
+ ##
+ ## If we're at the end of the file, then we can use $_ as
+ ## is. Otherwise, we need to remove the final partial-line
+ ## and save it so that it'll be at the beginning of the
+ ## next read (where the rest of the line will be layed in
+ ## right after it). $hold will be what we should save
+ ## until next time.
+ ##
+ if ($read != $size || $nl < 0) {
+ $hold = '';
+ } else {
+ $hold = substr($_, $nl + 1);
+ substr($_, $nl + 1) = '';
+ }
+
+ ##
+ ## Now have a bunch of full lines in $_. Use it.
+ ##
+ if (eval $REGEX_TEST) {
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ print $file, "\n";
+ $retval=0; ## we've found something
+
+ last;
+ }
+
+ ## Prepare for next read....
+ $_ = $hold;
+ }
+
+ } else { ## else not using faster block scanning.....
+
+ $lines_printed = 0 if $NICE;
+ while (<FILE_IN>) {
+ study;
+ next unless (eval $REGEX_TEST);
+
+ ##
+ ## We found a matching line.
+ ##
+ $retval=0;
+ &clear_message if $VERBOSE && $STDERR_SCREWS_STDOUT;
+ if ($LIST_ONLY) {
+ print $file, "\n";
+ last;
+ } else {
+ ## prepare to print line.
+ if ($NICE && $lines_printed++ == 0) {
+ print '-' x 70, "\n" if $NICE > 1;
+ print $file, ":\n";
+ }
+
+ ##
+ ## Print all the prelim stuff. This looks less efficient
+ ## than it needs to be, but that's so that when the eval
+ ## is compiled (and the tests are optimized away), the
+ ## result will be less actual PRINTs than the more natural
+ ## way of doing these tests....
+ ##
+ if ($NICE) {
+ if ($REPORT_LINENUM) {
+ print " line $.: ";
+ } else {
+ print " ";
+ }
+ } elsif ($REPORT_LINENUM && $PREPEND_FILENAME) {
+ print "$file,:$.: ";
+ } elsif ($PREPEND_FILENAME) {
+ print "$file: ";
+ } elsif ($REPORT_LINENUM) {
+ print "$.: ";
+ }
+ print $_;
+ print "\n" unless m/\n$/;
+ }
+ }
+ print "\n" if ($NICE > 1) && $lines_printed;
+ }
+ close(FILE_IN);
+ }
+ }
+ closedir(DIR);
+}
+
+__END__
+.00; ## finish .ig
+
+'di \" finish diversion--previous line must be blank
+.nr nl 0-1 \" fake up transition to first page again
+.nr % 0 \" start at page 1
+.\"__________________NORMAL_MAN_PAGE_BELOW_________________
+.ll+10n
+.TH search 1 "Dec 17, 1994"
+.SH SEARCH
+search \- search files (a'la grep) in a whole directory tree.
+.SH SYNOPSIS
+search [ grep-like and find-like options] [regex ....]
+.SH DESCRIPTION
+.I Search
+is more or less a combo of 'find' and 'grep' (although the regular
+expression flavor is that of the perl being used, which is closer to
+egrep's than grep's).
+
+.I Search
+does generally the same kind of thing that
+.nf
+ find <blah blah> | xargs egrep <blah blah>
+.fi
+does, but is
+.I much
+more powerful and efficient (and intuitive, I think).
+
+This manual describes
+.I search
+as of version "941227.4". You can always find the latest version at
+.nf
+ http://www.wg.omron.co.jp/~jfriedl/perl/index.html
+.fi
+
+.SH "QUICK EXAMPLE"
+Basic use is simple:
+.nf
+ % search jeff
+.fi
+will search files in the current directory, and all sub directories, for
+files that have "jeff" in them. The lines will be listed with the
+containing file's name prepended.
+.PP
+If you list more than one regex, such as with
+.nf
+ % search jeff Larry Randal+ 'Stoc?k' 'C.*son'
+.fi
+then a line containing any of the regexes will be listed.
+This makes it effectively the same as
+.nf
+ % search 'jeff|Larry|Randal+|Stoc?k|C.*son'
+.fi
+However, listing them separately is much more efficient (and is easier
+to type).
+.PP
+Note that in the case of these examples, the
+.B \-w
+(list whole-words only) option would be useful.
+.PP
+Normally, various kinds of files are automatically removed from consideration.
+If it has has a certain ending (such as ".tar", ".Z", ".o", .etc), or if
+the beginning of the file looks like a binary, it'll be excluded.
+You can control exactly how this works -- see below. One quick way to
+override this is to use the
+.B \-all
+option, which means to consider all the files that would normally be
+automatically excluded.
+Or, if you're curious, you can use
+.B \-why
+to have notes about what files are skipped (and why) printed to stderr.
+
+.SH "BASIC OVERVIEW"
+Normally, the search starts in the current directory, considering files in
+all subdirectories.
+
+You can use the
+.I ~/.search
+file to control ways to automatically exclude files.
+If you don't have this file, a default one will kick in, which automatically
+add
+.nf
+ -skip .o .Z .gif
+.fi
+(among others) to exclude those kinds of files (which you probably want to
+skip when searching for text, as is normal).
+Files that look to be be binary will also be excluded.
+
+Files ending with "#" and "~" will also be excluded unless the
+.B -x~
+option is given.
+
+You can use
+.B -showrc
+to show what kinds of files will normally be skipped.
+See the section on the startup file
+for more info.
+
+You can use the
+.B -all
+option to indicate you want to consider all files that would otherwise be
+skipped by the startup file.
+
+Based upon various other flags (see "WHICH FILES TO CONSIDER" below),
+more files might be removed from consideration. For example
+.nf
+ -mtime 3
+.fi
+will exclude files that aren't at least three days old (change the 3 to -3
+to exclude files that are more than three days old), while
+.nf
+ -skip .*
+.fi
+would exclude any file beginning with a dot (of course, '.' and '..' are
+special and always excluded).
+
+If you'd like to see what files are being excluded, and why, you can get the
+list via the
+.B \-why
+option.
+
+If a file makes it past all the checks, it is then "considered".
+This usually means it is greped for the regular expressions you gave
+on the command line.
+
+If any of the regexes match a line, the line is printed.
+However, if
+.B -list
+is given, just the filename is printed. Or, if
+.B -nice
+is given, a somewhat more (human-)readable output is generated.
+
+If you're searching a huge tree and want to keep informed about how
+the search is progressing,
+.B -v
+will print (to stderr) the current directory being searched.
+Using
+.B -vv
+will also print the current file "every so often", which could be useful
+if a directory is huge. Using
+.B -vvv
+will print the update with every file.
+
+Below is the full listing of options.
+
+.SH "OPTIONS TELLING *WHERE* TO SEARCH"
+.TP
+.BI -dir " DIR"
+Start searching at the named directory instead of the current directory.
+If multiple
+.B -dir
+arguments are given, multiple trees will be searched.
+.TP
+.BI -ddir " DIR"
+Like
+.B -dir
+except it flushes any previous
+.B -dir
+directories (i.e. "-dir A -dir B -dir C" will search A, B, and C, while
+"-dir A -ddir B -dir C" will search only B and C. This might be of use
+in the startup file (see that section below).
+.TP
+.B -xdev
+Stay on the same filesystem as the starting directory/directories.
+.TP
+.B -sort
+Sort the items in a directory before processing them.
+Normally they are processed in whatever order they happen to be read from
+the directory.
+.TP
+.B -nolinks
+Don't follow symbolic links. Normally they're followed.
+
+.SH "OPTIONS CONTROLLING WHICH FILES TO CONSIDER AND EXCLUDE"
+.TP
+.BI -mtime " NUM"
+Only consider files that were last changed more than
+.I NUM
+days ago
+(less than
+.I NUM
+days if
+.I NUM
+has '-' prepended, i.e. "-mtime -2.5" means to consider files that
+have been changed in the last two and a half days).
+.TP
+.B -older FILE
+Only consider files that have not changed since
+.I FILE
+was last changed.
+If there is any upper case in the "-older", "or equal" is added to the sense
+of the test. Therefore, "search -older ./file regex" will never consider
+"./file", while "search -Older ./file regex" will.
+
+If a file is a symbolic link, the time used is that of the file and not the
+link.
+.TP
+.BI -newer " FILE"
+Opposite of
+.BR -older .
+.TP
+.BI -name " GLOB"
+Only consider files that match the shell filename pattern
+.IR GLOB .
+The check is only done on a file's name (use
+.B -path
+to check the whole path, and use
+.B -dname
+to check directory names).
+
+Multiple specifications can be given by separating them with spaces, a'la
+.nf
+ -name '*.c *.h'
+.fi
+to consider C source and header files.
+If
+.I GLOB
+doesn't contain any special pattern characters, a '*' is prepended.
+This last example could have been given as
+.nf
+ -name '.c .h'
+.fi
+It could also be given as
+.nf
+ -name .c -name .h
+.fi
+or
+.nf
+ -name '*.c' -name '*.h'
+.fi
+or
+.nf
+ -name '*.[ch]'
+.fi
+(among others)
+but in this last case, you have to be sure to supply the leading '*'.
+.TP
+.BI -path " GLOB"
+Like
+.B -name
+except the entire path is checked against the pattern.
+.TP
+.B -regex " REGEX"
+Considers files whose names (not paths) match the given perl regex
+exactly.
+.TP
+.BI -iname " GLOB"
+Case-insensitive version of
+.BR -name .
+.TP
+.BI -ipath " GLOB"
+Case-insensitive version of
+.BR -path .
+.TP
+.BI -iregex " REGEX"
+Case-insensitive version of
+.BR -regex .
+
+.TP
+.BI -dpath " GLOB"
+Only search down directories whose path matches the given pattern (this
+doesn't apply to the initial directory given by
+.BI -dir ,
+of course).
+Something like
+.nf
+ -dir /usr/man -dpath /usr/man/man*
+.fi
+would completely skip
+"/usr/man/cat1", "/usr/man/cat2", etc.
+.TP
+.BI -dskip " GLOB"
+Skips directories whose name (not path) matches the given pattern.
+Something like
+.nf
+ -dir /usr/man -dskip cat*
+.fi
+would completely skip any directory in the tree whose name begins with "cat"
+(including "/usr/man/cat1", "/usr/man/cat2", etc.).
+.TP
+.BI -dregex " REGEX"
+Like
+.BI -dpath ,
+but the pattern is a full perl regex. Note that this quite different
+from
+.B -regex
+which considers only file names (not paths). This option considers
+full directory paths (not just names). It's much more useful this way.
+Sorry if it's confusing.
+.TP
+.BI -dpath " GLOB"
+This option exists, but is probably not very useful. It probably wants to
+be like the '-below' or something I mention in the "TODO" section.
+.TP
+.BI -idpath " GLOB"
+Case-insensitive version of
+.BR -dpath .
+.TP
+.BI -idskip " GLOB"
+Case-insensitive version of
+.BR -dskip .
+.TP
+.BI -idregex " REGEX"
+Case-insensitive version of
+.BR -dregex .
+.TP
+.B -all
+Ignore any 'magic' or 'option' lines in the startup file.
+The effect is that all files that would otherwise be automatically
+excluded are considered.
+.TP
+.BI -x SPECIAL
+Arguments starting with
+.B -x
+(except
+.BR -xdev ,
+explained elsewhere) do special interaction with the
+.I ~/.search
+startup file. Something like
+.nf
+ -xflag1 -xflag2
+.fi
+will turn on "flag1" and "flag2" in the startup file (and is
+the same as "-xflag1,flag2"). You can use this to write your own
+rules for what kinds of files are to be considered.
+
+For example, the internal-default startup file contains the line
+.nf
+ <!~> option: -skip '~ #'
+.fi
+This means that if the
+.B -x~
+flag is
+.I not
+seen, the option
+.nf
+ -skip '~ #'
+.fi
+should be done.
+The effect is that emacs temp and backup files are not normally
+considered, but you can included them with the -x~ flag.
+
+You can write your own rules to customize
+.I search
+in powerful ways. See the STARTUP FILE section below.
+.TP
+.B -why
+Print a message (to stderr) when and why a file is not considered.
+
+.SH "OPTIONS TELLING WHAT TO DO WITH FILES THAT WILL BE CONSIDERED"
+.TP
+.B -find
+(you can use
+.B -f
+as well).
+This option changes the basic action of
+.IR search .
+
+Normally, if a file is considered, it is searched
+for the regular expressions as described earlier. However, if this option
+is given, the filename is printed and no searching takes place. This turns
+.I search
+into a 'find' of some sorts.
+
+In this case, no regular expressions are needed on the command line
+(any that are there are silently ignored).
+
+This is not intended to be a replacement for the 'find' program,
+but to aid
+you in understanding just what files are getting past the exclusion checks.
+If you really want to use it as a sort of replacement for the 'find' program,
+you might want to use
+.B -all
+so that it doesn't waste time checking to see if the file is binary, etc
+(unless you really want that, of course).
+
+If you use
+.BR -find ,
+none of the "GREP-LIKE OPTIONS" (below) matter.
+
+As a replacement for 'find',
+.I search
+is probably a bit slower (or in the case of GNU find, a lot slower --
+GNU find is
+.I unbelievably
+fast).
+However, "search -ffind"
+might be more useful than 'find' when options such as
+.B -skip
+are used (at least until 'find' gets such functionality).
+.TP
+.B -ffind
+(or
+.BR -ff )
+A faster more 'find'-like find. Does
+.nf
+ -find -all -dorep
+.fi
+.SH "GREP-LIKE OPTIONS"
+These options control how a searched file is accessed,
+and how things are printed.
+.TP
+.B -i
+Ignore letter case when matching.
+.TP
+.B -w
+Consider only whole-word matches ("whole word" as defined by perl's "\\b"
+regex).
+.TP
+.B -u
+If the regex(es) is/are simple, try to modify them so that they'll work
+in manpage-like underlined text (i.e. like _^Ht_^Hh_^Hi_^Hs).
+This is very rudimentary at the moment.
+.TP
+.B -list
+(you can use
+.B -l
+too).
+Don't print matching lines, but the names of files that contain matching
+lines. This will likely be *much* faster, as special optimizations are
+made -- particularly with large files.
+.TP
+.B -n
+Pepfix each line by its line number.
+.TP
+.B -nice
+Not a grep-like option, but similar to
+.BR -list ,
+so included here.
+.B -nice
+will have the output be a bit more human-readable, with matching lines printed
+slightly indented after the filename, a'la
+.nf
+
+ % search foo
+ somedir/somefile: line with foo in it
+ somedir/somefile: some food for thought
+ anotherdir/x: don't be a buffoon!
+ %
+
+.fi
+will become
+.nf
+
+ % search -nice foo
+ somedir/somefile:
+ line with foo in it
+ some food for thought
+ anotherdir/x:
+ don't be a buffoon!
+ %
+
+.fi
+This option due to Lionel Cons.
+.TP
+.B -nnice
+Be a bit nicer than
+.BR -nice .
+Prefix each file's output by a rule line, and follow with an extra blank line.
+.TP
+.B -h
+Don't prepend each output line with the name of the file
+(meaningless when
+.B -find
+or
+.B -l
+are given).
+
+.SH "OTHER OPTIONS"
+.TP
+.B -help
+Print the usage information.
+.TP
+.B -version
+Print the version information and quit.
+.TP
+.B -v
+Set the level of message verbosity.
+.B -v
+will print a note whenever a new directory is entered.
+.B -vv
+will also print a note "every so often". This can be useful to see
+what's happening when searching huge directories.
+.B -vvv
+will print a new with every file.
+.B -vvvv
+is
+-vvv
+plus
+.BR -why .
+.TP
+.B -e
+This ends the options, and can be useful if the regex begins with '-'.
+.TP
+.B -showrc
+Shows what is being considered in the startup file, then exits.
+.TP
+.B -dorep
+Normally, an identical file won't be checked twice (even with multiple
+hard or symbolic links). If you're just trying to do a fast
+.BR -find ,
+the bookkeeping to remember which files have been seen is not desirable,
+so you can eliminate the bookkeeping with this flag.
+
+.SH "STARTUP FILE"
+When
+.I search
+starts up, it processes the directives in
+.IR ~/.search .
+If no such file exists, a default
+internal version is used.
+
+The internal version looks like:
+.nf
+
+ magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/
+ option: -skip '.a .COM .elc .EXE .gz .o .pbm .xbm .dvi'
+ option: -iskip '.tarz .zip .z .lzh .jpg .jpeg .gif .uu'
+ <!~> option: -skip '~ #'
+
+.fi
+If you wish to create your own "~/.search",
+you might consider copying the above, and then working from there.
+
+There are two kinds of directives in a startup file: "magic" and "option".
+.RS 0n
+.TP
+OPTION
+Option lines will automatically do the command-line options given.
+For example, the line
+.nf
+ option: -v
+.fi
+in you startup file will turn on -v every time, without needing to type it
+on the command line.
+
+The text on the line after the "option:" directive is processed
+like the Bourne shell, so make sure to pay attention to quoting.
+.nf
+ option: -skip .exe .com
+.fi
+will give an error (".com" by itself isn't a valid option), while
+.nf
+ option: -skip ".exe .com"
+.fi
+will properly include it as part of -skip's argument.
+
+.TP
+MAGIC
+Magic lines are used to determine if a file should be considered a binary
+or not (the term "magic" refers to checking a file's magic number). These
+are described in more detail below.
+.RE
+
+Blank lines and comments (lines beginning with '#') are allowed.
+
+If a line begins with <...>, then it's a check to see if the
+directive on the line should be done or not. The stuff inside the <...>
+can contain perl's && (and), || (or), ! (not), and parens for grouping,
+along with "flags" that might be indicated by the user with
+.BI -x flag
+options.
+
+For example, using "-xfoo" will cause "foo" to be true inside the <...>
+blocks. Therefore, a line beginning with "<foo>" would be done only when
+"-xfoo" had been specified, while a line beginning with "<!foo>" would be
+done only when "-xfoo" is not specified (of course, a line without any <...>
+is done in either case).
+
+A realistic example might be
+.nf
+ <!v> -vv
+.fi
+This will cause -vv messages to be the default, but allow "-xv" to override.
+
+There are a few flags that are set automatically:
+.RS
+.TP
+.B TTY
+true if the output is to the screen (as opposed to being redirected to a file).
+You can force this (as with all the other automatic flags) with -xTTY.
+.TP
+.B -v
+True if -v was specified. If -vv was specified, both
+.B -v
+and
+.B -vv
+flags are true (and so on).
+.TP
+.B -nice
+True if -nice was specified. Same thing about -nnice as for -vv.
+.PP
+.TP
+.B -list
+true if -list (or -l) was given.
+.TP
+.B -dir
+true if -dir was given.
+.RE
+
+Using this info, you might change the last example to
+.nf
+
+ <!v && !-v> option: -vv
+
+.fi
+The added "&& !-v" means "and if the '-v' option not given".
+This will allow you to use "-v" alone on the command line, and not
+have this directive add the more verbose "-vv" automatically.
+
+.RS 0
+Some other examples:
+.TP
+<!-dir && !here> option: -dir ~/
+Effectively make the default directory your home directory (instead of the
+current directory). Using -dir or -xhere will undo this.
+.TP
+<tex> option: -name .tex -dir ~/pub
+Create '-xtex' to search only "*.tex" files in your ~/pub directory tree.
+Actually, this could be made a bit better. If you combine '-xtex' and '-dir'
+on the command line, this directive will add ~/pub to the list, when you
+probably want to use the -dir directory only. You could do
+.nf
+
+ <tex> option: -name .tex
+ <tex && !-dir> option: -dir ~/pub
+.fi
+
+to will allow '-xtex' to work as before, but allow a command-line "-dir"
+to take precedence with respect to ~/pub.
+.TP
+<fluff> option: -nnice -sort -i -vvv
+Combine a few user-friendly options into one '-xfluff' option.
+.TP
+<man> option: -ddir /usr/man -v -w
+When the '-xman' option is given, search "/usr/man" for whole-words
+(of whatever regex or regexes are given on the command line), with -v.
+.RE
+
+The lines in the startup file are executed from top to bottom, so something
+like
+.nf
+
+ <both> option: -xflag1 -xflag2
+ <flag1> option: ...whatever...
+ <flag2> option: ...whatever...
+
+.fi
+will allow '-xboth' to be the same as '-xflag1 -xflag2' (or '-xflag1,flag2'
+for that matter). However, if you put the "<both>" line below the others,
+they will not be true when encountered, so the result would be different
+(and probably undesired).
+
+The "magic" directives are used to determine if a file looks to be binary
+or not. The form of a magic line is
+.nf
+ magic: \fISIZE\fP : \fIPERLCODE\fP
+.fi
+where
+.I SIZE
+is the number of bytes of the file you need to check, and
+.I PERLCODE
+is the code to do the check. Within
+.IR PERLCODE ,
+the variable $H will hold at least the first
+.I SIZE
+bytes of the file (unless the file is shorter than that, of course).
+It might hold more bytes. The perl should evaluate to true if the file
+should be considered a binary.
+
+An example might be
+.nf
+ magic: 6 : substr($H, 0, 6) eq 'GIF87a'
+.fi
+to test for a GIF ("-iskip .gif" is better, but this might be useful
+if you have images in files without the ".gif" extension).
+
+Since the startup file is checked from top to bottom, you can be a bit
+efficient:
+.nf
+ magic: 6 : ($x6 = substr($H, 0, 6)) eq 'GIF87a'
+ magic: 6 : $x6 eq 'GIF89a'
+.fi
+You could also write the same thing as
+.nf
+ magic: 6 : (($x6 = substr($H, 0, 6)) eq 'GIF87a') || ## an old gif, or.. \e
+ $x6 eq 'GIF89a' ## .. a new one.
+.fi
+since newlines may be escaped.
+
+The default internal startup file includes
+.nf
+ magic: 32 : $H =~ m/[\ex00-\ex06\ex10-\ex1a\ex1c-\ex1f\ex80\exff]{2}/
+.fi
+which checks for certain non-printable characters, and catches a large
+number of binary files, including most system's executables, linkable
+objects, compressed, tarred, and otherwise folded, spindled, and mutilated
+files.
+
+Another example might be
+.nf
+ ## an archive library
+ magic: 17 : substr($H, 0, 17) eq "!<arch>\en__.SYMDEF"
+.fi
+
+.SH "RETURN VALUE"
+.I Search
+returns zero if lines (or files, if appropriate) were found,
+or if no work was requested (such as with
+.BR -help ).
+Returns 1 if no lines (or files) were found.
+Returns 2 on error.
+
+.SH TODO
+Things I'd like to add some day:
+.nf
+ + show surrounding lines (context).
+ + highlight matched portions of lines.
+ + add '-and', which can go between regexes to override
+ the default logical or of the regexes.
+ + add something like
+ -below GLOB
+ which will examine a tree and only consider files that
+ lie in a directory deeper than one named by the pattern.
+ + add 'warning' and 'error' directives.
+ + add 'help' directive.
+.fi
+.SH BUGS
+If -xdev and multiple -dir arguments are given, any file in any of the
+target filesystems are allowed. It would be better to allow each filesystem
+for each separate tree.
+
+Multiple -dir args might also cause some confusing effects. Doing
+.nf
+ -dir some/dir -dir other
+.fi
+will search "some/dir" completely, then search "other" completely. This
+is good. However, something like
+.nf
+ -dir some/dir -dir some/dir/more/specific
+.fi
+will search "some/dir" completely *except for* "some/dir/more/specific",
+after which it will return and be searched. Not really a bug, but just sort
+of odd.
+
+File times (for -newer, etc.) of symbolic links are for the file, not the
+link. This could cause some misunderstandings.
+
+Probably more. Please let me know.
+.SH AUTHOR
+Jeffrey Friedl, Omron Corp (jfriedl@omron.co.jp)
+.br
+http://www.wg.omron.co.jp/cgi-bin/j-e/jfriedl.html
+
+.SH "LATEST SOURCE"
+See http://www.wg.omron.co.jp/~jfriedl/perl/index.html
diff --git a/gnu/usr.bin/perl/win32/bin/webget.pl b/gnu/usr.bin/perl/win32/bin/webget.pl
new file mode 100644
index 00000000000..3d72208cb2b
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/bin/webget.pl
@@ -0,0 +1,1091 @@
+#!/usr/local/bin/perl -w
+
+#-
+#!/usr/local/bin/perl -w
+$version = "951121.18";
+$comments = 'jfriedl@omron.co.jp';
+
+##
+## This is "webget"
+##
+## Jeffrey Friedl (jfriedl@omron.co.jp), July 1994.
+## Copyright 19.... ah hell, just take it.
+## Should work with either perl4 or perl5
+##
+## BLURB:
+## Given a URL on the command line (HTTP and FTP supported at the moment),
+## webget fetches the named object (HTML text, images, audio, whatever the
+## object happens to be). Will automatically use a proxy if one is defined
+## in the environment, follow "this URL has moved" responses, and retry
+## "can't find host" responses from a proxy in case host lookup was slow).
+## Supports users & passwords (FTP), Basic Authorization (HTTP), update-if-
+## modified (HTTP), and much more. Works with perl4 or perl5.
+
+##
+## More-detailed instructions in the comment block below the history list.
+##
+
+##
+## To-do:
+## Add gopher support.
+## Fix up how error messages are passed among this and the libraries.
+##
+
+## 951219.19
+## Lost ftp connections now die with a bit more grace.
+##
+## 951121.18
+## Add -nnab.
+## Brought the "usage" string in line with reality.
+##
+## 951114.17
+## Added -head.
+## Added -update/-refresh/-IfNewerThan. If any URL was not pulled
+## because it was not out of date, an exit value of 2 is returned.
+##
+## 951031.16
+## Added -timeout. Cleaned up (a bit) the exit value. Now exits
+## with 1 if all URLs had some error (timeout exits immediately with
+## code 3, though. This is subject to change). Exits with 0 if any
+## URL was brought over safely.
+##
+## 951017.15
+## Neat -pf, -postfile idea from Lorrie Cranor
+## (http://www.ccrc.wustl.edu/~lorracks/)
+##
+## 950912.14
+## Sigh, fixed a typo.
+##
+## 950911.13
+## Added Basic Authorization support for http. See "PASSWORDS AND STUFF"
+## in the documentation.
+##
+## 950911.12
+## Implemented a most-excellent suggestion by Anthony D'Atri
+## (aad@nwnet.net), to be able to automatically grab to a local file of
+## the same name as the URL. See the '-nab' flag.
+##
+## 950706.11
+## Quelled small -w warning (thanks: Lars Rasmussen <gnort@daimi.aau.dk>)
+##
+## 950630.10
+## Steve Campbell to the rescue again. FTP now works when supplied
+## with a userid & password (eg ftp://user:pass@foo.bar.com/index.txt).
+##
+## 950623.9
+## Incorporated changes from Steve Campbell (steven_campbell@uk.ibm.com)
+## so that the ftp will work when no password is required of a user.
+##
+## 950530.8
+## Minor changes:
+## Eliminate read-size warning message when size unknown.
+## Pseudo-debug/warning messages at the end of debug_read now go to
+## stderr. Some better error handling when trying to contact systems
+## that aren't really set up for ftp. Fixed a bug concerning FTP access
+## to a root directory. Added proxy documentation at head of file.
+##
+## 950426.6,7
+## Complete Overhaul:
+## Renamed from httpget. Added ftp support (very sketchy at the moment).
+## Redid to work with new 'www.pl' library; chucked 'Www.pl' library.
+## More or less new and/or improved in many ways, but probably introduced
+## a few bugs along the way.
+##
+## 941227.5
+## Added follow stuff (with -nofollow, etc.)
+## Added -updateme. Cool!
+## Some general tidying up.
+##
+## 941107.4
+## Allowed for ^M ending a header line... PCs give those kind of headers.
+##
+## 940820.3
+## First sorta'clean net release.
+##
+##
+
+##
+##>
+##
+## Fetch http and/or ftp URL(s) given on the command line and spit to
+## STDOUT.
+##
+## Options include:
+## -V, -version
+## Print version information; exit.
+##
+## -p, -post
+## If the URL looks like a reply to a form (i.e. has a '?' in it),
+## the request is POST'ed instead of GET'ed.
+##
+## -head
+## Gets the header only (for HTTP). This might include such useful
+## things as 'Last-modified' and 'Content-length' fields
+## (a lack of a 'Last-modified' might be a good indication that it's
+## a CGI).
+##
+## The "-head" option implies "-nostrip", but does *not* imply,
+## for example "-nofollow".
+##
+##
+## -pf, -postfile
+## The item after the '?' is taken as a local filename, and the contents
+## are POST'ed as with -post
+##
+## -nab, -f, -file
+## Rather than spit the URL(s) to standard output, unconditionally
+## dump to a file (or files) whose name is that as used in the URL,
+## sans path. I like '-nab', but supply '-file' as well since that's
+## what was originally suggested. Also see '-update' below for the
+## only-if-changed version.
+##
+## -nnab
+## Like -nab, but in addtion to dumping to a file, dump to stdout as well.
+## Sort of like the 'tee' command.
+##
+## -update, -refresh
+## Do the same thing as -nab, etc., but does not bother pulling the
+## URL if it older than the localfile. Only applies to HTTP.
+## Uses the HTTP "If-Modified-Since" field. If the URL was not modified
+## (and hence not changed), the return value is '2'.
+##
+## -IfNewerThan FILE
+## -int FILE
+## Only pulls URLs if they are newer than the date the local FILE was
+## last written.
+##
+## -q, -quiet
+## Suppresses all non-essential informational messages.
+##
+## -nf, -nofollow
+## Normally, a "this URL has moved" HTTP response is automatically
+## followed. Not done with -nofollow.
+##
+## -nr, -noretry
+## Normally, an HTTP proxy response of "can't find host" is retried
+## up to three times, to give the remote hostname lookup time to
+## come back with an answer. This suppresses the retries. This is the
+## same as '-retry 0'.
+##
+## -r#, -retry#, -r #, -retry #
+## Sets the number of times to retry. Default 3.
+##
+## -ns, -nostrip
+## For HTTP items (including other items going through an HTTP proxy),
+## the HTTP response header is printed rather than stripped as default.
+##
+## -np, -noproxy
+## A proxy is not used, even if defined for the protocol.
+##
+## -h, -help
+## Show a usage message and exit.
+##
+## -d, -debug
+## Show some debugging messages.
+##
+## -updateme
+## The special and rather cool flag "-updateme" will see if webget has
+## been updated since you got your version, and prepare a local
+## version of the new version for you to use. Keep updated! (although
+## you can always ask to be put on the ping list to be notified when
+## there's a new version -- see the author's perl web page).
+##
+## -timeout TIMESPAN
+## -to TIMESPAN
+## Time out if a connection can not be made within the specified time
+## period. TIMESPAN is normally in seconds, although a 'm' or 'h' may
+## be appended to indicate minutes and hours. "-to 1.5m" would timeout
+## after 90 seconds.
+##
+## (At least for now), a timeout causes immediate program death (with
+## exit value 3). For some reason, the alarm doesn't always cause a
+## waiting read or connect to abort, so I just die immediately.. /-:
+##
+## I might consider adding an "entire fetch" timeout, if someone
+## wants it.
+##
+## PASSWORDS AND SUCH
+##
+## You can use webget to do FTP fetches from non-Anonymous systems and
+## accounts. Just put the required username and password into the URL,
+## as with
+## webget 'ftp:/user:password@ftp.somesite.com/pub/pix/babe.gif
+## ^^^^^^^^^^^^^
+## Note the user:password is separated from the hostname by a '@'.
+##
+## You can use the same kind of thing with HTTP, and if so it will provide
+## what's know as Basic Authorization. This is >weak< authorization. It
+## also provides >zero< security -- I wouldn't be sending any credit-card
+## numbers this way (unless you send them 'round my way :-). It seems to
+## be used most by providers of free stuff where they want to make some
+## attempt to limit access to "known users".
+##
+## PROXY STUFF
+##
+## If you need to go through a gateway to get out to the whole internet,
+## you can use a proxy if one's been set up on the gateway. This is done
+## by setting the "http_proxy" environmental variable to point to the
+## proxy server. Other variables are used for other target protocols....
+## "gopher_proxy", "ftp_proxy", "wais_proxy", etc.
+##
+## For example, I have the following in my ".login" file (for use with csh):
+##
+## setenv http_proxy http://local.gateway.machine:8080/
+##
+## This is to indicate that any http URL should go to local.gateway.machine
+## (port 8080) via HTTP. Additionally, I have
+##
+## setenv gopher_proxy "$http_proxy"
+## setenv wais_proxy "$http_proxy"
+## setenv ftp_proxy "$http_proxy"
+##
+## This means that any gopher, wais, or ftp URL should also go to the
+## same place, also via HTTP. This allows webget to get, for example,
+## GOPHER URLs even though it doesn't support GOPHER itself. It uses HTTP
+## to talk to the proxy, which then uses GOPHER to talk to the destination.
+##
+## Finally, if there are sites inside your gateway that you would like to
+## connect to, you can list them in the "no_proxy" variable. This will allow
+## you to connect to them directly and skip going through the proxy:
+##
+## setenv no_proxy "www.this,www.that,www.other"
+##
+## I (jfriedl@omron.co.jp) have little personal experience with proxies
+## except what I deal with here at Omron, so if this is not representative
+## of your situation, please let me know.
+##
+## RETURN VALUE
+## The value returned to the system by webget is rather screwed up because
+## I didn't think about dealing with it until things were already
+## complicated. Since there can be more than one URL on the command line,
+## it's hard to decide what to return when one times out, another is fetched,
+## another doesn't need to be fetched, and a fourth isn't found.
+##
+## So, here's the current status:
+##
+## Upon any timeout (via the -timeout arg), webget immediately
+## returns 3. End of story. Otherwise....
+##
+## If any URL was fetched with a date limit (i.e. via
+## '-update/-refresh/-IfNewerThan' and was found to not have changed,
+## 2 is returned. Otherwise....
+##
+## If any URL was successfully fetched, 0 is returned. Otherwise...
+##
+## If there were any errors, 1 is returned. Otherwise...
+##
+## Must have been an info-only or do-nothing instance. 0 is returned.
+##
+## Phew. Hopefully useful to someone.
+##<
+##
+
+## Where latest version should be.
+$WEB_normal = 'http://www.wg.omron.co.jp/~jfriedl/perl/webget';
+$WEB_inlined = 'http://www.wg.omron.co.jp/~jfriedl/perl/inlined/webget';
+
+
+require 'network.pl'; ## inline if possible (directive to a tool of mine)
+require 'www.pl'; ## inline if possible (directive to a tool of mine)
+$inlined=0; ## this might be changed by a the inline thing.
+
+##
+## Exit values. All screwed up.
+##
+$EXIT_ok = 0;
+$EXIT_error = 1;
+$EXIT_notmodified = 2;
+$EXIT_timeout = 3;
+
+##
+##
+
+warn qq/WARNING:\n$0: need a newer version of "network.pl"\n/ if
+ !defined($network'version) || $network'version < "950311.5";
+warn qq/WARNING:\n$0: need a newer version of "www.pl"\n/ if
+ !defined($www'version) || $www'version < "951114.8";
+
+$WEB = $inlined ? $WEB_inlined : $WEB_normal;
+
+$debug = 0;
+$strip = 1; ## default is to strip
+$quiet = 0; ## also normally off.
+$follow = 1; ## normally, we follow "Found (302)" links
+$retry = 3; ## normally, retry proxy hostname lookups up to 3 times.
+$nab = 0; ## If true, grab to a local file of the same name.
+$refresh = 0; ## If true, use 'If-Modified-Since' with -nab get.
+$postfile = 0; ## If true, filename is given after the '?'
+$defaultdelta2print = 2048;
+$TimeoutSpan = 0; ## seconds after which we should time out.
+
+while (@ARGV && $ARGV[0] =~ m/^-/)
+{
+ $arg = shift(@ARGV);
+
+ $nab = 1, next if $arg =~ m/^-f(ile)?$/;
+ $nab = 1, next if $arg =~ m/^-nab$/;
+ $nab = 2, next if $arg =~ m/^-nnab$/;
+ $post = 1, next if $arg =~ m/^-p(ost)?$/i;
+ $post = $postfile = 1, next if $arg =~ m/^-p(ost)?f(ile)?$/i;
+ $quiet=1, next if $arg =~ m/^-q(uiet)?$/;
+ $follow = 0, next if $arg =~ m/^-no?f(ollow)?$/;
+ $strip = 0, next if $arg =~ m/^-no?s(trip)?$/;
+ $debug=1, next if $arg =~ m/^-d(ebug)?$/;
+ $noproxy=1, next if $arg =~ m/^-no?p(roxy)?$/;
+ $retry=0, next if $arg =~ m/^-no?r(etry)?$/;
+ $retry=$2, next if $arg =~ m/^-r(etry)?(\d+)$/;
+ &updateme if $arg eq '-updateme';
+ $strip = 0, $head = 1, next if $arg =~ m/^-head(er)?/;
+ $nab = $refresh = 1, next if $arg =~ m/^-(refresh|update)/;
+
+ &usage($EXIT_ok) if $arg =~ m/^-h(elp)?$/;
+ &show_version, exit($EXIT_ok) if $arg eq '-version' || $arg eq '-V';
+
+ if ($arg =~ m/^-t(ime)?o(ut)?$/i) {
+ local($num) = shift(@ARGV);
+ &usage($EXIT_error, "expecting timespan argument to $arg\n") unless
+ $num =~ m/^\d+(\d*)?[hms]?$/;
+ &timeout_arg($num);
+ next;
+ }
+
+ if ($arg =~ m/^-if?n(ewer)?t(han)?$/i) {
+ $reference_file = shift(@ARGV);
+ &usage($EXIT_error, "expecting filename arg to $arg")
+ if !defined $reference_file;
+ if (!-f $reference_file) {
+ warn qq/$0: ${arg}'s "$reference_file" not found.\n/;
+ exit($EXIT_error);
+ }
+ next;
+ }
+
+ if ($arg eq '-r' || $arg eq '-retry') {
+ local($num) = shift(@ARGV);
+ &usage($EXIT_error, "expecting numerical arg to $arg\n") unless
+ defined($num) && $num =~ m/^\d+$/;
+ $retry = $num;
+ next;
+ }
+ &usage($EXIT_error, qq/$0: unknown option "$arg"\n/);
+}
+
+if ($head && $post) {
+ warn "$0: combining -head and -post makes no sense, ignoring -post.\n";
+ $post = 0;
+ undef $postfile;
+}
+
+if ($refresh && defined($reference_file)) {
+ warn "$0: combining -update and -IfNewerThan make no sense, ignoring -IfNewerThan.\n";
+ undef $reference_file;
+}
+
+if (@ARGV == 0) {
+ warn "$0: nothing to do. Use -help for info.\n";
+ exit($EXIT_ok);
+}
+
+
+##
+## Now run through the remaining arguments (mostly URLs) and do a quick
+## check to see if they look well-formed. We won't *do* anything -- just
+## want to catch quick errors before really starting the work.
+##
+@tmp = @ARGV;
+$errors = 0;
+while (@tmp) {
+ $arg = shift(@tmp);
+ if ($arg =~ m/^-t(ime)?o(ut)?$/) {
+ local($num) = shift(@tmp);
+ if ($num !~ m/^\d+(\d*)?[hms]?$/) {
+ &warn("expecting timespan argument to $arg\n");
+ $errors++;
+ }
+ } else {
+ local($protocol) = &www'grok_URL($arg, $noproxy);
+
+ if (!defined $protocol) {
+ warn qq/can't grok "$arg"/;
+ $errors++;
+ } elsif (!$quiet && ($protocol eq 'ftp')) {
+ warn qq/warning: -head ignored for ftp URLs\n/ if $head;
+ warn qq/warning: -refresh ignored for ftp URLs\n/if $refresh;
+ warn qq/warning: -IfNewerThan ignored for ftp URLs\n/if defined($reference_file);
+
+ }
+ }
+}
+
+exit($EXIT_error) if $errors;
+
+
+$SuccessfulCount = 0;
+$NotModifiedCount = 0;
+
+##
+## Now do the real thing.
+##
+while (@ARGV) {
+ $arg = shift(@ARGV);
+ if ($arg =~ m/^-t(ime)?o(ut)?$/) {
+ &timeout_arg(shift(@ARGV));
+ } else {
+ &fetch_url($arg);
+ }
+}
+
+if ($NotModifiedCount) {
+ exit($EXIT_notmodified);
+} elsif ($SuccessfulCount) {
+ exit($EXIT_ok);
+} else {
+ exit($EXIT_error);
+}
+
+###########################################################################
+###########################################################################
+
+sub timeout_arg
+{
+ ($TimeoutSpan) = @_;
+ $TimeoutSpan =~ s/s//;
+ $TimeoutSpan *= 60 if $TimeoutSpan =~ m/m/;
+ $TimeoutSpan *= 3600 if $TimeoutSpan =~ m/h/;
+
+}
+
+##
+## As a byproduct, returns the basename of $0.
+##
+sub show_version
+{
+ local($base) = $0;
+ $base =~ s,.*/,,;
+ print STDERR "This is $base version $version\n";
+ $base;
+}
+
+##
+## &usage(exitval, message);
+##
+## Prints a usage message to STDERR.
+## If MESSAGE is defined, prints that first.
+## If exitval is defined, exits with that value. Otherwise, returns.
+##
+sub usage
+{
+ local($exit, $message) = @_;
+
+ print STDERR $message if defined $message;
+ local($base) = &show_version;
+ print STDERR <<INLINE_LITERAL_TEXT;
+usage: $0 [options] URL ...
+ Fetches and displays the named URL(s). Supports http and ftp.
+ (if no protocol is given, a leading "http://" is normally used).
+
+Options are from among:
+ -V, -version Print version information; exit.
+ -p, -post If URL looks like a form reply, does POST instead of GET.
+ -pf, -postfile Like -post, but takes everything after ? to be a filename.
+ -q, -quiet All non-essential informational messages are suppressed.
+ -nf, -nofollow Don't follow "this document has moved" replies.
+ -nr, -noretry Doesn't retry a failed hostname lookup (same as -retry 0)
+ -r #, -retry # Sets failed-hostname-lookup-retry to # (default $retry)
+ -np, -noproxy Uses no proxy, even if one defined for the protocol.
+ -ns, -nostrip The HTTP header, normally elided, is printed.
+ -head gets item header only (implies -ns)
+ -nab, -file Dumps output to file whose name taken from URL, minus path
+ -nnab Like -nab, but *also* dumps to stdout.
+ -update HTTP only. Like -nab, but only if the page has been modified.
+ -h, -help Prints this message.
+ -IfNewerThan F HTTP only. Only brings page if it is newer than named file.
+ -timeout T Fail if a connection can't be made in the specified time.
+
+ -updateme Pull the latest version of $base from
+ $WEB
+ and reports if it is newer than your current version.
+
+Comments to $comments.
+INLINE_LITERAL_TEXT
+
+ exit($exit) if defined $exit;
+}
+
+##
+## Pull the latest version of this program to a local file.
+## Clip the first couple lines from this executing file so that we
+## preserve the local invocation style.
+##
+sub updateme
+{
+ ##
+ ## Open a temp file to hold the new version,
+ ## redirecting STDOUT to it.
+ ##
+ open(STDOUT, '>'.($tempFile="/tmp/webget.new")) ||
+ open(STDOUT, '>'.($tempFile="/usr/tmp/webget.new")) ||
+ open(STDOUT, '>'.($tempFile="/webget.new")) ||
+ open(STDOUT, '>'.($tempFile="webget.new")) ||
+ die "$0: can't open a temp file.\n";
+
+ ##
+ ## See if we can figure out how we were called.
+ ## The seek will rewind not to the start of the data, but to the
+ ## start of the whole program script.
+ ##
+ ## Keep the first line if it begins with #!, and the next two if they
+ ## look like the trick mentioned in the perl man page for getting
+ ## around the lack of #!-support.
+ ##
+ if (seek(DATA, 0, 0)) { ##
+ $_ = <DATA>; if (m/^#!/) { print STDOUT;
+ $_ = <DATA>; if (m/^\s*eval/) { print STDOUT;
+ $_ = <DATA>; if (m/^\s*if/) { print STDOUT; }
+ }
+ }
+ print STDOUT "\n#-\n";
+ }
+
+ ## Go get the latest one...
+ local(@options);
+ push(@options, 'head') if $head;
+ push(@options, 'nofollow') unless $follow;
+ push(@options, ('retry') x $retry) if $retry;
+ push(@options, 'quiet') if $quiet;
+ push(@options, 'debug') if $debug;
+ local($status, $memo, %info) = &www'open_http_url(*IN, $WEB, @options);
+ die "fetching $WEB:\n $memo\n" unless $status eq 'ok';
+
+ $size = $info{'content-length'};
+ while (<IN>)
+ {
+ $size -= length;
+ print STDOUT;
+ if (!defined $fetched_version && m/version\s*=\s*"([^"]+)"/) {
+ $fetched_version = $1;
+ &general_read(*IN, $size);
+ last;
+ }
+ }
+
+ $fetched_version = "<unknown>" unless defined $fetched_version;
+
+ ##
+ ## Try to update the mode of the temp file with the mode of this file.
+ ## Don't worry if it fails.
+ ##
+ chmod($mode, $tempFile) if $mode = (stat($0))[2];
+
+ $as_well = '';
+ if ($fetched_version eq $version)
+ {
+ print STDERR "You already have the most-recent version ($version).\n",
+ qq/FWIW, the newly fetched one has been left in "$tempFile".\n/;
+ }
+ elsif ($fetched_version <= $version)
+ {
+ print STDERR
+ "Mmm, your current version seems newer (?!):\n",
+ qq/ your version: "$version"\n/,
+ qq/ new version: "$fetched_version"\n/,
+ qq/FWIW, fetched one left in "$tempFile".\n/;
+ }
+ else
+ {
+ print STDERR
+ "Indeed, your current version was old:\n",
+ qq/ your version: "$version"\n/,
+ qq/ new version: "$fetched_version"\n/,
+ qq/The file "$tempFile" is ready to replace the old one.\n/;
+ print STDERR qq/Just do:\n % mv $tempFile $0\n/ if -f $0;
+ $as_well = ' as well';
+ }
+ print STDERR "Note that the libraries it uses may (or may not) need updating$as_well.\n"
+ unless $inlined;
+ exit($EXIT_ok);
+}
+
+##
+## Given a list of URLs, fetch'em.
+## Parses the URL and calls the routine for the appropriate protocol
+##
+sub fetch_url
+{
+ local(@todo) = @_;
+ local(%circref, %hold_circref);
+
+ URL_LOOP: while (@todo)
+ {
+ $URL = shift(@todo);
+ %hold_circref = %circref; undef %circref;
+
+ local($protocol, @args) = &www'grok_URL($URL, $noproxy);
+
+ if (!defined $protocol) {
+ &www'message(1, qq/can't grok "$URL"/);
+ next URL_LOOP;
+ }
+
+ ## call protocol-specific handler
+ $func = "fetch_via_" . $protocol;
+ $error = &$func(@args, $TimeoutSpan);
+ if (defined $error) {
+ &www'message(1, "$URL: $error");
+ } else {
+ $SuccessfulCount++;
+ }
+ }
+}
+
+sub filedate
+{
+ local($filename) = @_;
+ local($filetime) = (stat($filename))[9];
+ return 0 if !defined $filetime;
+ local($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($filetime);
+ return 0 if !defined $wday;
+ sprintf(qq/"%s, %02d-%s-%02d %02d:%02d:%02d GMT"/,
+ ("Sunday", "Monday", "Tuesdsy", "Wednesday",
+ "Thursday", "Friday", "Saturday")[$wday],
+ $mday,
+ ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
+ "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")[$mon],
+ $year,
+ $hour,
+ $min,
+ $sec);
+}
+
+sub local_filename
+{
+ local($filename) = @_;
+ $filename =~ s,/+$,,; ## remove any trailing slashes
+ $filename =~ s,.*/,,; ## remove any leading path
+ if ($filename eq '') {
+ ## empty -- pick a random name
+ $filename = "file0000";
+ ## look for a free random name.
+ $filename++ while -f $filename;
+ }
+ $filename;
+}
+
+sub set_output_file
+{
+ local($filename) = @_;
+ if (!open(OUT, ">$filename")) {
+ &www'message(1, "$0: can't open [$filename] for output");
+ } else {
+ open(SAVEOUT, ">>&STDOUT") || die "$!";;
+ open(STDOUT, ">>&OUT");
+ }
+}
+
+sub close_output_file
+{
+ local($filename) = @_;
+ unless ($quiet)
+ {
+ local($note) = qq/"$filename" written/;
+ if (defined $error) {
+ $note .= " (possibly corrupt due to error above)";
+ }
+ &www'message(1, "$note.");
+ }
+ close(STDOUT);
+ open(STDOUT, ">&SAVEOUT");
+}
+
+sub http_alarm
+{
+ &www'message(1, "ERROR: $AlarmNote.");
+ exit($EXIT_timeout); ## the alarm doesn't seem to cause a waiting syscall to break?
+# $HaveAlarm = 1;
+}
+
+##
+## Given the host, port, and path, and (for info only) real target,
+## fetch via HTTP.
+##
+## If there is a user and/or password, use that for Basic Authorization.
+##
+## If $timeout is nonzero, time out after that many seconds.
+##
+sub fetch_via_http
+{
+ local($host, $port, $path, $target, $user, $password, $timeout) = @_;
+ local(@options);
+ local($local_filename);
+
+ ##
+ ## If we're posting, but -postfile was given, we need to interpret
+ ## the item in $path after '?' as a filename, and replace it with
+ ## the contents of the file.
+ ##
+ if ($postfile && $path =~ s/\?([\d\D]*)//) {
+ local($filename) = $1;
+ return("can't open [$filename] to POST") if !open(IN, "<$filename");
+ local($/) = ''; ## want to suck up the whole file.
+ $path .= '?' . <IN>;
+ close(IN);
+ }
+
+ $local_filename = &local_filename($path)
+ if $refresh || $nab || defined($reference_file);
+ $refresh = &filedate($local_filename) if $refresh;
+ $refresh = &filedate($reference_file) if defined($reference_file);
+
+ push(@options, 'head') if $head;
+ push(@options, 'post') if $post;
+ push(@options, 'nofollow') unless $follow;
+ push(@options, ('retry') x 3);
+ push(@options, 'quiet') if $quiet;
+ push(@options, 'debug') if $debug;
+ push(@options, "ifmodifiedsince=$refresh") if $refresh;
+
+ if (defined $password || defined $user) {
+ local($auth) = join(':', ($user || ''), ($password || ''));
+ push(@options, "authorization=$auth");
+ }
+
+ local($old_alarm);
+ if ($timeout) {
+ $old_alarm = $SIG{'ALRM'} || 'DEFAULT';
+ $SIG{'ALRM'} = "main'http_alarm";
+# $HaveAlarm = 0;
+ $AlarmNote = "host $host";
+ $AlarmNote .= ":$port" if $port != $www'default_port{'http'};
+ $AlarmNote .= " timed out after $timeout second";
+ $AlarmNote .= 's' if $timeout > 1;
+ alarm($timeout);
+ }
+ local($result, $memo, %info) =
+ &www'open_http_connection(*HTTP, $host,$port,$path,$target,@options);
+
+ if ($timeout) {
+ alarm(0);
+ $SIG{'ALRM'} = $old_alarm;
+ }
+
+# if ($HaveAlarm) {
+# close(HTTP);
+# $error = "timeout after $timeout second";
+# $error .= "s" if $timeout > 1;
+# return $error;
+# }
+
+ if ($follow && ($result eq 'follow')) {
+ %circref = %hold_circref;
+ $circref{$memo} = 1;
+ unshift(@todo, $memo);
+ return undef;
+ }
+
+
+ return $memo if $result eq 'error';
+ if (!$quiet && $result eq 'status' && ! -t STDOUT) {
+ #&www'message(1, "Warning: $memo");
+ $error = "Warning: $memo";
+ }
+
+ if ($info{'CODE'} == 304) { ## 304 is magic for "Not Modified"
+ close(HTTP);
+ &www'message(1, "$URL: Not Modified") unless $quiet;
+ $NotModifiedCount++;
+ return undef; ## no error
+ }
+
+
+ &set_output_file($local_filename) if $nab;
+
+ unless($strip) {
+ print $info{'STATUS'}, "\n", $info{'HEADER'}, "\n";
+
+ print SAVEOUT $info{'STATUS'}, "\n", $info{'HEADER'}, "\n" if $nab==2;
+ }
+
+ if (defined $info{'BODY'}) {
+ print $info{'BODY'};
+ print SAVEOUT $info{'BODY'} if $nab==2;
+ }
+
+ if (!$head) {
+ &general_read(*HTTP, $info{'content-length'});
+ }
+ close(HTTP);
+ &close_output_file($local_filename) if $nab;
+
+ $error; ## will be 'undef' if no error;
+}
+
+sub fetch_via_ftp
+{
+ local($host, $port, $path, $target, $user, $password, $timeout) = @_;
+ local($local_filename) = &local_filename($path);
+ local($ftp_debug) = $debug;
+ local(@password) = ($password);
+ $path =~ s,^/,,; ## remove a leading / from the path.
+ $path = '.' if $path eq ''; ## make sure we have something
+
+ if (!defined $user) {
+ $user = 'anonymous';
+ $password = $ENV{'USER'} || 'WWWuser';
+ @password = ($password.'@'. &network'addr_to_ascii(&network'my_addr),
+ $password.'@');
+ } elsif (!defined $password) {
+ @password = ("");
+ }
+
+ local($_last_ftp_reply, $_passive_host, $_passive_port);
+ local($size);
+
+ sub _ftp_get_reply
+ {
+ local($text) = scalar(<FTP_CONTROL>);
+ die "lost connection to $host\n" if !defined $text;
+ local($_, $tmp);
+ print STDERR "READ: $text" if $ftp_debug;
+ die "internal error: expected reply code in response from ".
+ "ftp server [$text]" unless $text =~ s/^(\d+)([- ])//;
+ local($code) = $1;
+ if ($2 eq '-') {
+ while (<FTP_CONTROL>) {
+ ($tmp = $_) =~ s/^\d+[- ]//;
+ $text .= $tmp;
+ last if m/^$code /;
+ }
+ }
+ $text =~ s/^\d+ ?/<foo>/g;
+ ($code, $text);
+ }
+
+ sub _ftp_expect
+ {
+ local($code, $text) = &_ftp_get_reply;
+ $_last_ftp_reply = $text;
+ foreach $expect (@_) {
+ return ($code, $text) if $code == $expect;
+ }
+ die "internal error: expected return code ".
+ join('|',@_).", got [$text]";
+ }
+
+ sub _ftp_send
+ {
+ print STDERR "SEND: ", @_ if $ftp_debug;
+ print FTP_CONTROL @_;
+ }
+
+ sub _ftp_do_passive
+ {
+ local(@commands) = @_;
+
+ &_ftp_send("PASV\r\n");
+ local($code) = &_ftp_expect(227, 125);
+
+ if ($code == 227)
+ {
+ die "internal error: can't grok passive reply [$_last_ftp_reply]"
+ unless $_last_ftp_reply =~ m/\(([\d,]+)\)/;
+ local($a,$b,$c,$d, $p1, $p2) = split(/,/, $1);
+ ($_passive_host, $_passive_port) =
+ ("$a.$b.$c.$d", $p1*256 + $p2);
+ }
+
+ foreach(@commands) {
+ &_ftp_send($_);
+ }
+
+ local($error)=
+ &network'connect_to(*PASSIVE, $_passive_host, $_passive_port);
+ die "internal error: passive ftp connect [$error]" if $error;
+ }
+
+ ## make the connection to the host
+ &www'message($debug, "connecting to $host...") unless $quiet;
+
+ local($old_alarm);
+ if ($timeout) {
+ $old_alarm = $SIG{'ALRM'} || 'DEFAULT';
+ $SIG{'ALRM'} = "main'http_alarm"; ## can use this for now
+# $HaveAlarm = 0;
+ $AlarmNote = "host $host";
+ $AlarmNote .= ":$port" if $port != $www'default_port{'ftp'};
+ $AlarmNote .= " timed out after $timeout second";
+ $AlarmNote .= 's' if $timeout > 1;
+ alarm($timeout);
+ }
+
+ local($error) = &network'connect_to(*FTP_CONTROL, $host, $port);
+
+ if ($timeout) {
+ alarm(0);
+ $SIG{'ALRM'} = $old_alarm;
+ }
+
+ return $error if $error;
+
+ local ($code, $text) = &_ftp_get_reply(*FTP_CONTROL);
+ close(FTP_CONTROL), return "internal ftp error: [$text]" unless $code==220;
+
+ ## log in
+ &www'message($debug, "logging in as $user...") unless $quiet;
+ foreach $password (@password)
+ {
+ &_ftp_send("USER $user\r\n");
+ ($code, $text) = &_ftp_expect(230,331,530);
+ close(FTP_CONTROL), return $text if ($code == 530);
+ last if $code == 230; ## hey, already logged in, cool.
+
+ &_ftp_send("PASS $password\r\n");
+ ($code, $text) = &_ftp_expect(220,230,530,550,332);
+ last if $code != 550;
+ last if $text =~ m/can't change directory/;
+ }
+
+ if ($code == 550)
+ {
+ $text =~ s/\n+$//;
+ &www'message(1, "Can't log in $host: $text") unless $quiet;
+ exit($EXIT_error);
+ }
+
+ if ($code == 332)
+ {
+ &_ftp_send("ACCT noaccount\r\n");
+ ($code, $text) = &_ftp_expect(230, 202, 530, 500,501,503, 421)
+ }
+ close(FTP_CONTROL), return $text if $code >= 300;
+
+ &_ftp_send("TYPE I\r\n");
+ &_ftp_expect(200);
+
+ unless ($quiet) {
+ local($name) = $path;
+ $name =~ s,.*/([^/]),$1,;
+ &www'message($debug, "requesting $name...");
+ }
+ ## get file
+ &_ftp_do_passive("RETR $path\r\n");
+ ($code,$text) = &_ftp_expect(125, 150, 550, 530);
+ close(FTP_CONTROL), return $text if $code == 530;
+
+ if ($code == 550)
+ {
+ close(PASSIVE);
+ if ($text =~ /directory/i) {
+ ## probably from "no such file or directory", so just return now.
+ close(FTP_CONTROL);
+ return $text;
+ }
+
+ ## do like Mosaic and try getting a directory listing.
+ &_ftp_send("CWD $path\r\n");
+ ($code) = &_ftp_expect(250,550);
+ if ($code == 550) {
+ close(FTP_CONTROL);
+ return $text;
+ }
+ &_ftp_do_passive("LIST\r\n");
+ &_ftp_expect(125, 150);
+ }
+
+ $size = $1 if $text =~ m/(\d+)\s+bytes/;
+ binmode(PASSIVE); ## just in case.
+ &www'message($debug, "waiting for data...") unless $quiet;
+ &set_output_file($local_filename) if $nab;
+ &general_read(*PASSIVE, $size);
+ &close_output_file($local_filename) if $nab;
+
+ close(PASSIVE);
+ close(FTP_CONTROL);
+ undef;
+}
+
+sub general_read
+{
+ local(*INPUT, $size) = @_;
+ local($lastcount, $bytes) = (0,0);
+ local($need_to_clear) = 0;
+ local($start_time) = time;
+ local($last_time, $time) = $start_time;
+ ## Figure out how often to print the "bytes read" message
+ local($delta2print) =
+ (defined $size) ? int($size/50) : $defaultdelta2print;
+
+ &www'message(0, "read 0 bytes") unless $quiet;
+
+ ## so $! below is set only if a real error happens from now
+ eval 'local($^W) = 0; undef $!';
+
+
+ while (defined($_ = <INPUT>))
+ {
+ ## shove it out.
+ &www'clear_message if $need_to_clear;
+ print;
+ print SAVEOUT if $nab==2;
+
+ ## if we know the content-size, keep track of what we're reading.
+ $bytes += length;
+
+ last if eof || (defined $size && $bytes >= $size);
+
+ if (!$quiet && $bytes > ($lastcount + $delta2print))
+ {
+ if ($time = time, $last_time == $time) {
+ $delta2print *= 1.5;
+ } else {
+ $last_time = $time;
+ $lastcount = $bytes;
+ local($time_delta) = $time - $start_time;
+ local($text);
+
+ $delta2print /= $time_delta;
+ if (defined $size) {
+ $text = sprintf("read $bytes bytes (%.0f%%)",
+ $bytes*100/$size);
+ } else {
+ $text = "read $bytes bytes";
+ }
+
+ if ($time_delta > 5 || ($time_delta && $bytes > 10240))
+ {
+ local($rate) = int($bytes / $time_delta);
+ if ($rate < 5000) {
+ $text .= " ($rate bytes/sec)";
+ } elsif ($rate < 1024 * 10) {
+ $text .= sprintf(" (%.1f k/sec)", $rate/1024);
+ } else {
+ $text .= sprintf(" (%.0f k/sec)", $rate/1024);
+ }
+ }
+ &www'message(0, "$text...");
+ $need_to_clear = -t STDOUT;
+ }
+ }
+ }
+
+ if (!$quiet)
+ {
+ if ($size && ($size != $bytes)) {
+ &www'message("WARNING: Expected $size bytes, read $bytes bytes.\n");
+ }
+# if ($!) {
+# print STDERR "\$! is [$!]\n";
+# }
+# if ($@) {
+# print STDERR "\$\@ is [$@]\n";
+# }
+ }
+ &www'clear_message($text) unless $quiet;
+}
+
+sub dummy {
+ 1 || &dummy || &fetch_via_ftp || &fetch_via_http || &http_alarm;
+ 1 || close(OUT);
+ 1 || close(SAVEOUT);
+}
+
+__END__
diff --git a/gnu/usr.bin/perl/win32/bin/www.pl b/gnu/usr.bin/perl/win32/bin/www.pl
new file mode 100644
index 00000000000..8022597454b
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/bin/www.pl
@@ -0,0 +1,901 @@
+##
+## Jeffrey Friedl (jfriedl@omron.co.jp)
+## Copyri.... ah hell, just take it.
+##
+## This is "www.pl".
+## Include (require) to use, execute ("perl www.pl") to print a man page.
+## Requires my 'network.pl' library.
+package www;
+$version = "951219.9";
+
+##
+## 951219.9
+## -- oops, stopped sending garbage Authorization line when no
+## authorization was requested.
+##
+## 951114.8
+## -- added support for HEAD, If-Modified-Since
+##
+## 951017.7
+## -- Change to allow a POST'ed HTTP text to have newlines in it.
+## Added 'NewURL to the open_http_connection %info. Idea courtesy
+## of Bryan Schmersal (http://www.transarc.com/~bryans/Home.html).
+##
+##
+## 950921.6
+## -- added more robust HTTP error reporting
+## (due to steven_campbell@uk.ibm.com)
+##
+## 950911.5
+## -- added Authorization support
+##
+
+##
+## HTTP return status codes.
+##
+%http_return_code =
+ (200,"OK",
+ 201,"Created",
+ 202,"Accepted",
+ 203,"Partial Information",
+ 204,"No Response",
+ 301,"Moved",
+ 302,"Found",
+ 303,"Method",
+ 304,"Not modified",
+ 400,"Bad request",
+ 401,"Unauthorized",
+ 402,"Payment required",
+ 403,"Forbidden",
+ 404,"Not found",
+ 500,"Internal error",
+ 501,"Not implemented",
+ 502,"Service temporarily overloaded",
+ 503,"Gateway timeout");
+
+##
+## If executed directly as a program, print as a man page.
+##
+if (length($0) >= 6 && substr($0, -6) eq 'www.pl')
+{
+ seek(DATA, 0, 0) || die "$0: can't reset internal pointer.\n";
+ print "www.pl version $version\n", '=' x 60, "\n";
+ while (<DATA>) {
+ next unless /^##>/../^##</; ## select lines to print
+ s/^##[<> ]?//; ## clean up
+ print;
+ }
+ exit(0);
+}
+
+##
+## History:
+## version 950425.4
+## added require for "network.pl"
+##
+## version 950425.3
+## re-did from "Www.pl" which was a POS.
+##
+##
+## BLURB:
+## A group of routines for dealing with URLs, HTTP sessions, proxies, etc.
+## Requires my 'network.pl' package. The library file can be executed
+## directly to produce a man page.
+
+##>
+## A motley group of routines for dealing with URLs, HTTP sessions, proxies,
+## etc. Requires my 'network.pl' package.
+##
+## Latest version, as well as other stuff (including network.pl) available
+## at http://www.wg.omron.co.jp/~jfriedl/perl/
+##
+## Simpleton complete program to dump a URL given on the command-line:
+##
+## require 'network.pl'; ## required for www.pl
+## require 'www.pl'; ## main routines
+## $URL = shift; ## get URL
+## ($status, $memo) = &www'open_http_url(*IN, $URL); ## connect
+## die "$memo\n" if $status ne 'ok'; ## report any error
+## print while <IN>; ## dump contents
+##
+## There are various options available for open_http_url.
+## For example, adding 'quiet' to the call, i.e. vvvvvvv-----added
+## ($status, $memo) = &www'open_http_url(*IN, $URL, 'quiet');
+## suppresses the normal informational messages such as "waiting for data...".
+##
+## The options, as well as the various other public routines in the package,
+## are discussed below.
+##
+##<
+
+##
+## Default port for the protocols whose URL we'll at least try to recognize.
+##
+%default_port = ('http', 80,
+ 'ftp', 21,
+ 'gopher', 70,
+ 'telnet', 23,
+ 'wais', 210,
+ );
+
+##
+## A "URL" to "ftp.blah.com" without a protocol specified is probably
+## best reached via ftp. If the hostname begins with a protocol name, it's
+## easy. But something like "www." maps to "http", so that mapping is below:
+##
+%name2protocol = (
+ 'www', 'http',
+ 'wwwcgi','http',
+);
+
+$last_message_length = 0;
+$useragent = "www.pl/$version";
+
+##
+##>
+##############################################################################
+## routine: open_http_url
+##
+## Used as
+## ($status, $memo, %info) = &www'open_http_url(*FILEHANDLE, $URL, options..)
+##
+## Given an unused filehandle, a URL, and a list of options, opens a socket
+## to the URL and returns with the filehandle ready to read the data of the
+## URL. The HTTP header, as well as other information, is returned in %info.
+##
+## OPTIONS are from among:
+##
+## "post"
+## If PATH appears to be a query (i.e. has a ? in it), contact
+## via a POST rather than a GET.
+##
+## "nofollow"
+## Normally, if the initial contact indicates that the URL has moved
+## to a different location, the new location is automatically contacted.
+## "nofollow" inhibits this.
+##
+## "noproxy"
+## Normally, a proxy will be used if 'http_proxy' is defined in the
+## environment. This option inhibits the use of a proxy.
+##
+## "retry"
+## If a host's address can't be found, it may well be because the
+## nslookup just didn't return in time and that retrying the lookup
+## after a few seconds will succeed. If this option is given, will
+## wait five seconds and try again. May be given multiple times to
+## retry multiple times.
+##
+## "quiet"
+## Informational messages will be suppressed.
+##
+## "debug"
+## Additional messages will be printed.
+##
+## "head"
+## Requests only the file header to be sent
+##
+##
+##
+##
+## The return array is ($STATUS, $MEMO, %INFO).
+##
+## STATUS is 'ok', 'error', 'status', or 'follow'
+##
+## If 'error', the MEMO will indicate why (URL was not http, can't
+## connect, etc.). INFO is probably empty, but may have some data.
+## See below.
+##
+## If 'status', the connnection was made but the reply was not a normal
+## "OK" successful reply (i.e. "Not found", etc.). MEMO is a note.
+## INFO is filled as noted below. Filehandle is ready to read (unless
+## $info{'BODY'} is filled -- see below), but probably most useful
+## to treat this as an 'error' response.
+##
+## If 'follow', MEMO is the new URL (for when 'nofollow' was used to
+## turn off automatic following) and INFO is filled as described
+## below. Unless you wish to give special treatment to these types of
+## responses, you can just treat 'follow' responses like 'ok'
+## responses.
+##
+## If 'ok', the connection went well and the filehandle is ready to
+## read.
+##
+## INFO contains data as described at the read_http_header() function (in
+## short, the HTTP response header) and additional informational fields.
+## In addition, the following fields are filled in which describe the raw
+## connection made or attempted:
+##
+## PROTOCOL, HOST, PORT, PATH
+##
+## Note that if a proxy is being used, these will describe the proxy.
+## The field TARGET will describe the host or host:port ultimately being
+## contacted. When no proxy is being used, this will be the same info as
+## in the raw connection fields above. However, if a proxy is being used,
+## it will refer to the final target.
+##
+## In some cases, the additional entry $info{'BODY'} exists as well. If
+## the result-code indicates an error, the body of the message may be
+## parsed for internal reasons (i.e. to support 'repeat'), and if so, it
+## will be saved in $info{'BODY}.
+##
+## If the URL has moved, $info{'NewURL'} will exist and contain the new
+## URL. This will be true even if the 'nofollow' option is specified.
+##
+##<
+##
+sub open_http_url
+{
+ local(*HTTP, $URL, @options) = @_;
+ return &open_http_connection(*HTTP, $URL, undef, undef, undef, @options);
+}
+
+
+##
+##>
+##############################################################################
+## routine: read_http_header
+##
+## Given a filehandle to a just-opened HTTP socket connection (such as one
+## created via &network'connect_to which has had the HTTP request sent),
+## reads the HTTP header and and returns the parsed info.
+##
+## ($replycode, %info) = &read_http_header(*FILEHANDLE);
+##
+## $replycode will be the HTTP reply code as described below, or
+## zero on header-read error.
+##
+## %info contains two types of fields:
+##
+## Upper-case fields are informational from the function.
+## Lower-case fields are the header field/value pairs.
+##
+## Upper-case fields:
+##
+## $info{'STATUS'} will be the first line read (HTTP status line)
+##
+## $info{'CODE'} will be the numeric HTTP reply code from that line.
+## This is also returned as $replycode.
+##
+## $info{'TYPE'} is the text from the status line that follows CODE.
+##
+## $info{'HEADER'} will be the raw text of the header (sans status line),
+## newlines and all.
+##
+## $info{'UNKNOWN'}, if defined, will be any header lines not in the
+## field/value format used to fill the lower-case fields of %info.
+##
+## Lower-case fields are reply-dependent, but in general are described
+## in http://info.cern.ch/hypertext/WWW/Protocols/HTTP/Object_Headers.html
+##
+## A header line such as
+## Content-type: Text/Plain
+## will appear as $info{'content-type'} = 'Text/Plain';
+##
+## (*) Note that while the field names are are lower-cased, the field
+## values are left as-is.
+##
+##
+## When $replycode is zero, there are two possibilities:
+## $info{'TYPE'} is 'empty'
+## No response was received from the filehandle before it was closed.
+## No other %info fields present.
+## $info{'TYPE'} is 'unknown'
+## First line of the response doesn't seem to be proper HTTP.
+## $info{'STATUS'} holds that line. No other %info fields present.
+##
+## The $replycode, when not zero, is as described at
+## http://info.cern.ch/hypertext/WWW/Protocols/HTTP/HTRESP.html
+##
+## Some of the codes:
+##
+## success 2xx
+## ok 200
+## created 201
+## accepted 202
+## partial information 203
+## no response 204
+## redirection 3xx
+## moved 301
+## found 302
+## method 303
+## not modified 304
+## error 4xx, 5xx
+## bad request 400
+## unauthorized 401
+## paymentrequired 402
+## forbidden 403
+## not found 404
+## internal error 500
+## not implemented 501
+## service temporarily overloaded 502
+## gateway timeout 503
+##
+##<
+##
+sub read_http_header
+{
+ local(*HTTP) = @_;
+ local(%info, $_);
+
+ ##
+ ## The first line of the response will be the status (OK, error, etc.)
+ ##
+ unless (defined($info{'STATUS'} = <HTTP>)) {
+ $info{'TYPE'} = "empty";
+ return (0, %info);
+ }
+ chop $info{'STATUS'};
+
+ ##
+ ## Check the status line. If it doesn't match and we don't know the
+ ## format, we'll just let it pass and hope for the best.
+ ##
+ unless ($info{'STATUS'} =~ m/^HTTP\S+\s+(\d\d\d)\s+(.*\S)/i) {
+ $info{'TYPE'} = 'unknown';
+ return (0, %info);
+ }
+
+ $info{'CODE'} = $1;
+ $info{'TYPE'} = $2;
+ $info{'HEADER'} = '';
+
+ ## read the rest of the header.
+ while (<HTTP>) {
+ last if m/^\s*$/;
+ $info{'HEADER'} .= $_; ## save whole text of header.
+
+ if (m/^([^\n:]+):[ \t]*(.*\S)/) {
+ local($field, $value) = ("\L$1", $2);
+ if (defined $info{$field}) {
+ $info{$field} .= "\n" . $value;
+ } else {
+ $info{$field} = $value;
+ }
+ } elsif (defined $info{'UNKNOWN'}) {
+ $info{'UNKNOWN'} .= $_;
+ } else {
+ $info{'UNKNOWN'} = $_;
+ }
+ }
+
+ return ($info{'CODE'}, %info);
+}
+
+##
+##>
+##
+##############################################################################
+## routine: grok_URL(URL, noproxy, defaultprotocol)
+##
+## Given a URL, returns access information. Deals with
+## http, wais, gopher, ftp, and telnet
+## URLs.
+##
+## Information returned is
+## (PROTOCOL, HOST, PORT, PATH, TARGET, USER, PASSWORD)
+##
+## If noproxy is not given (or false) and there is a proxy defined
+## for the given protocol (via the "*_proxy" environmental variable),
+## the returned access information will be for the proxy and will
+## reference the given URL. In this case, 'TARGET' will be the
+## HOST:PORT of the original URL (PORT elided if it's the default port).
+##
+## Access information returned:
+## PROTOCOL: "http", "ftp", etc. (guaranteed to be lowercase).
+## HOST: hostname or address as given.
+## PORT: port to access
+## PATH: path of resource on HOST:PORT.
+## TARGET: (see above)
+## USER and PASSWORD: for 'ftp' and 'telnet' URLs, if supplied by the
+## URL these will be defined, undefined otherwise.
+##
+## If no protocol is defined via the URL, the defaultprotocol will be used
+## if given. Otherwise, the URL's address will be checked for a leading
+## protocol name (as with a leading "www.") and if found will be used.
+## Otherwise, the protocol defaults to http.
+##
+## Fills in the appropriate default port for the protocol if need be.
+##
+## A proxy is defined by a per-protocol environmental variable such
+## as http_proxy. For example, you might have
+## setenv http_proxy http://firewall:8080/
+## setenv ftp_proxy $http_proxy
+## to set it up.
+##
+## A URL seems to be officially described at
+## http://www.w3.org/hypertext/WWW/Addressing/URL/5_BNF.html
+## although that document is a joke of errors.
+##
+##<
+##
+sub grok_URL
+{
+ local($_, $noproxy, $defaultprotocol) = @_;
+ $noproxy = defined($noproxy) && $noproxy;
+
+ ## Items to be filled in and returned.
+ local($protocol, $address, $port, $path, $target, $user, $password);
+
+ return undef unless m%^(([a-zA-Z]+)://|/*)([^/]+)(/.*)?$%;
+
+ ##
+ ## Due to a bug in some versions of perl5, $2 might not be empty
+ ## even if $1 is. Therefore, we must check $1 for a : to see if the
+ ## protocol stuff matched or not. If not, the protocol is undefined.
+ ##
+ ($protocol, $address, $path) = ((index($1,":") >= 0 ? $2 : undef), $3, $4);
+
+ if (!defined $protocol)
+ {
+ ##
+ ## Choose a default protocol if none given. If address begins with
+ ## a protocol name (one that we know via %name2protocol or
+ ## %default_port), choose it. Otherwise, choose http.
+ ##
+ if (defined $defaultprotocol) {
+ $protocol = $defaultprotocol;
+ }
+ else
+ {
+ $address =~ m/^[a-zA-Z]+/;
+ if (defined($name2protocol{"\L$&"})) {
+ $protocol = $name2protocol{"\L$&"};
+ } else {
+ $protocol = defined($default_port{"\L$&"}) ? $& : 'http';
+ }
+ }
+ }
+ $protocol =~ tr/A-Z/a-z/; ## ensure lower-case.
+
+ ##
+ ## Http support here probably not kosher, but fits in nice for basic
+ ## authorization.
+ ##
+ if ($protocol eq 'ftp' || $protocol eq 'telnet' || $protocol eq 'http')
+ {
+ ## Glean a username and password from address, if there.
+ ## There if address starts with USER[:PASSWORD]@
+ if ($address =~ s/^(([^\@:]+)(:([^@]+))?\@)//) {
+ ($user, $password) = ($2, $4);
+ }
+ }
+
+ ##
+ ## address left is (HOSTNAME|HOSTNUM)[:PORTNUM]
+ ##
+ if ($address =~ s/:(\d+)$//) {
+ $port = $1;
+ } else {
+ $port = $default_port{$protocol};
+ }
+
+ ## default path is '/';
+ $path = '/' if !defined $path;
+
+ ##
+ ## If there's a proxy and we're to proxy this request, do so.
+ ##
+ local($proxy) = $ENV{$protocol."_proxy"};
+ if (!$noproxy && defined($proxy) && !&no_proxy($protocol,$address))
+ {
+ local($dummy);
+ local($old_pass, $old_user);
+
+ ##
+ ## Since we're going through a proxy, we want to send the
+ ## proxy the entire URL that we want. However, when we're
+ ## doing Authenticated HTTP, we need to take out the user:password
+ ## that webget has encoded in the URL (this is a bit sleazy on
+ ## the part of webget, but the alternative is to have flags, and
+ ## having them part of the URL like with FTP, etc., seems a bit
+ ## cleaner to me in the context of how webget is used).
+ ##
+ ## So, if we're doing this slezy thing, we need to construct
+ ## the new URL from the compnents we have now (leaving out password
+ ## and user), decode the proxy URL, then return the info for
+ ## that host, a "filename" of the entire URL we really want, and
+ ## the user/password from the original URL.
+ ##
+ ## For all other things, we can just take the original URL,
+ ## ensure it has a protocol on it, and pass it as the "filename"
+ ## we want to the proxy host. The difference between reconstructing
+ ## the URL (as for HTTP Authentication) and just ensuring the
+ ## protocol is there is, except for the user/password stuff,
+ ## nothing. In theory, at least.
+ ##
+ if ($protocol eq 'http' && (defined($password) || defined($user)))
+ {
+ $path = "http://$address$path";
+ $old_pass = $password;
+ $old_user = $user;
+ } else {
+ ## Re-get original URL and ensure protocol// actually there.
+ ## This will become our new path.
+ ($path = $_) =~ s,^($protocol:)?/*,$protocol://,i;
+ }
+
+ ## note what the target will be
+ $target = ($port==$default_port{$protocol})?$address:"$address:$port";
+
+ ## get proxy info, discarding
+ ($protocol, $address, $port, $dummy, $dummy, $user, $password)
+ = &grok_URL($proxy, 1);
+ $password = $old_pass if defined $old_pass;
+ $user = $old_user if defined $old_user;
+ }
+ ($protocol, $address, $port, $path, $target, $user, $password);
+}
+
+
+
+##
+## &no_proxy($protocol, $host)
+##
+## Returns true if the specified host is identified in the no_proxy
+## environmental variable, or identify the proxy server itself.
+##
+sub no_proxy
+{
+ local($protocol, $targethost) = @_;
+ local(@dests, $dest, $host, @hosts, $aliases);
+ local($proxy) = $ENV{$protocol."_proxy"};
+ return 0 if !defined $proxy;
+ $targethost =~ tr/A-Z/a-z/; ## ensure all lowercase;
+
+ @dests = ($proxy);
+ push(@dests,split(/\s*,\s*/,$ENV{'no_proxy'})) if defined $ENV{'no_proxy'};
+
+ foreach $dest (@dests)
+ {
+ ## just get the hostname
+ $host = (&grok_URL($dest, 1), 'http')[1];
+
+ if (!defined $host) {
+ warn "can't grok [$dest] from no_proxy env.var.\n";
+ next;
+ }
+ @hosts = ($host); ## throw in original name just to make sure
+ ($host, $aliases) = (gethostbyname($host))[0, 1];
+
+ if (defined $aliases) {
+ push(@hosts, ($host, split(/\s+/, $aliases)));
+ } else {
+ push(@hosts, $host);
+ }
+ foreach $host (@hosts) {
+ next if !defined $host;
+ return 1 if "\L$host" eq $targethost;
+ }
+ }
+ return 0;
+}
+
+sub ensure_proper_network_library
+{
+ require 'network.pl' if !defined $network'version;
+ warn "WARNING:\n". __FILE__ .
+ qq/ needs a newer version of "network.pl"\n/ if
+ !defined($network'version) || $network'version < "950311.5";
+}
+
+
+
+##
+##>
+##############################################################################
+## open_http_connection(*FILEHANDLE, HOST, PORT, PATH, TARGET, OPTIONS...)
+##
+## Opens an HTTP connection to HOST:PORT and requests PATH.
+## TARGET is used only for informational messages to the user.
+##
+## If PORT and PATH are undefined, HOST is taken as an http URL and TARGET
+## is filled in as needed.
+##
+## Otherwise, it's the same as open_http_url (including return value, etc.).
+##<
+##
+sub open_http_connection
+{
+ local(*HTTP, $host, $port, $path, $target, @options) = @_;
+ local($post_text, @error, %seen);
+ local(%info);
+
+ &ensure_proper_network_library;
+
+ ## options allowed:
+ local($post, $retry, $authorization, $nofollow, $noproxy,
+ $head, $debug, $ifmodifiedsince, $quiet, ) = (0) x 10;
+ ## parse options:
+ foreach $opt (@options)
+ {
+ next unless defined($opt) && $opt ne '';
+ local($var, $val);
+ if ($opt =~ m/^(\w+)=(.*)/) {
+ ($var, $val) = ($1, $2);
+ } else {
+ $var = $opt;
+ $val = 1;
+ }
+ $var =~ tr/A-Z/a-z/; ## ensure variable is lowercase.
+ local(@error);
+
+ eval "if (defined \$$var) { \$$var = \$val; } else { \@error =
+ ('error', 'bad open_http_connection option [$opt]'); }";
+ return ('error', "open_http_connection eval: $@") if $@;
+ return @error if defined @error;
+ }
+ $quiet = 0 if $debug; ## debug overrides quiet
+
+ local($protocol, $error, $code, $URL, %info, $tmp, $aite);
+
+ ##
+ ## if both PORT and PATH are undefined, treat HOST as a URL.
+ ##
+ unless (defined($port) && defined($path))
+ {
+ ($protocol,$host,$port,$path,$target)=&grok_URL($host,$noproxy,'http');
+ if ($protocol ne "http") {
+ return ('error',"open_http_connection doesn't grok [$protocol]");
+ }
+ unless (defined($host)) {
+ return ('error', "can't grok [$URL]");
+ }
+ }
+
+ return ('error', "no port in URL [$URL]") unless defined $port;
+ return ('error', "no path in URL [$URL]") unless defined $path;
+
+ RETRY: while(1)
+ {
+ ## we'll want $URL around for error messages and such.
+ if ($port == $default_port{'http'}) {
+ $URL = "http://$host";
+ } else {
+ $URL = "http://$host:$default_port{'http'}";
+ }
+ $URL .= ord($path) eq ord('/') ? $path : "/$path";
+
+ $aite = defined($target) ? "$target via $host" : $host;
+
+ &message($debug, "connecting to $aite ...") unless $quiet;
+
+ ##
+ ## note some info that might be of use to the caller.
+ ##
+ local(%preinfo) = (
+ 'PROTOCOL', 'http',
+ 'HOST', $host,
+ 'PORT', $port,
+ 'PATH', $path,
+ );
+ if (defined $target) {
+ $preinfo{'TARGET'} = $target;
+ } elsif ($default_port{'http'} == $port) {
+ $preinfo{'TARGET'} = $host;
+ } else {
+ $preinfo{'TARGET'} = "$host:$port";
+ }
+
+ ## connect to the site
+ $error = &network'connect_to(*HTTP, $host, $port);
+ if (defined $error) {
+ return('error', "can't connect to $aite: $error", %preinfo);
+ }
+
+ ## If we're asked to POST and it looks like a POST, note post text.
+ if ($post && $path =~ m/\?/) {
+ $post_text = $'; ## everything after the '?'
+ $path = $`; ## everything before the '?'
+ }
+
+ ## send the POST or GET request
+ $tmp = $head ? 'HEAD' : (defined $post_text ? 'POST' : 'GET');
+
+ &message($debug, "sending request to $aite ...") if !$quiet;
+ print HTTP $tmp, " $path HTTP/1.0\n";
+
+ ## send the If-Modified-Since field if needed.
+ if ($ifmodifiedsince) {
+ print HTTP "If-Modified-Since: $ifmodifiedsince\n";
+ }
+
+ ## oh, let's sputter a few platitudes.....
+ print HTTP "Accept: */*\n";
+ print HTTP "User-Agent: $useragent\n" if defined $useragent;
+
+ ## If doing Authorization, do so now.
+ if ($authorization) {
+ print HTTP "Authorization: Basic ",
+ &htuu_encode($authorization), "\n";
+ }
+
+ ## If it's a post, send it.
+ if (defined $post_text)
+ {
+ print HTTP "Content-type: application/x-www-form-urlencoded\n";
+ print HTTP "Content-length: ", length $post_text, "\n\n";
+ print HTTP $post_text, "\n";
+ }
+ print HTTP "\n";
+ &message($debug, "waiting for data from $aite ...") unless $quiet;
+
+ ## we can now read the response (header, then body) via HTTP.
+ binmode(HTTP); ## just in case.
+
+ ($code, %info) = &read_http_header(*HTTP);
+ &message(1, "header returns code $code ($info{'TYPE'})") if $debug;
+
+ ## fill in info from %preinfo
+ local($val, $key);
+ while (($val, $key) = each %preinfo) {
+ $info{$val} = $key;
+ }
+
+ if ($code == 0)
+ {
+ return('error',"empty response for $URL")
+ if $info{'TYPE'} eq 'empty';
+ return('error', "non-HTTP response for $URL", %info)
+ if $info{'TYPE'} eq 'unknown';
+ return('error', "unknown zero-code for $URL", %info);
+ }
+
+ if ($code == 302) ## 302 is magic for "Found"
+ {
+ if (!defined $info{'location'}) {
+ return('error', "No location info for Found URL $URL", %info);
+ }
+ local($newURL) = $info{'location'};
+
+ ## Remove :80 from hostname, if there. Looks ugly.
+ $newURL =~ s,^(http:/+[^/:]+):80/,$1/,i;
+ $info{"NewURL"} = $newURL;
+
+ ## if we're not following links or if it's not to HTTP, return.
+ return('follow', $newURL, %info) if
+ $nofollow || $newURL!~m/^http:/i;
+
+ ## note that we've seen this current URL.
+ $seen{$host, $port, $path} = 1;
+
+ &message(1, qq/[note: now moved to "$newURL"]/) unless $quiet;
+
+
+ ## get the new one and return an error if it's been seen.
+ ($protocol, $host, $port, $path, $target) =
+ &www'grok_URL($newURL, $noproxy);
+ &message(1, "[$protocol][$host][$port][$path]") if $debug;
+
+ if (defined $seen{$host, $port, $path})
+ {
+ return('error', "circular reference among:\n ".
+ join("\n ", sort grep(/^http/i, keys %seen)), %seen);
+ }
+ next RETRY;
+ }
+ elsif ($code == 500) ## 500 is magic for "internal error"
+ {
+ ##
+ ## A proxy will often return this with text saying "can't find
+ ## host" when in reality it's just because the nslookup returned
+ ## null at the time. Such a thing should be retied again after a
+ ## few seconds.
+ ##
+ if ($retry)
+ {
+ local($_) = $info{'BODY'} = join('', <HTTP>);
+ if (/Can't locate remote host:\s*(\S+)/i) {
+ local($times) = ($retry == 1) ?
+ "once more" : "up to $retry more times";
+ &message(0, "can't locate $1, will try $times ...")
+ unless $quiet;
+ sleep(5);
+ $retry--;
+ next RETRY;
+ }
+ }
+ }
+
+ if ($code != 200) ## 200 is magic for "OK";
+ {
+ ## I'll deal with these as I see them.....
+ &clear_message;
+ if ($info{'TYPE'} eq '')
+ {
+ if (defined $http_return_code{$code}) {
+ $info{'TYPE'} = $http_return_code{$code};
+ } else {
+ $info{'TYPE'} = "(unknown status code $code)";
+ }
+ }
+ return ('status', $info{'TYPE'}, %info);
+ }
+
+ &clear_message;
+ return ('ok', 'ok', %info);
+ }
+}
+
+
+##
+## Hyper Text UUencode. Somewhat different from regular uuencode.
+##
+## Logic taken from Mosaic for X code by Mark Riordan and Ari Luotonen.
+##
+sub htuu_encode
+{
+ local(@in) = unpack("C*", $_[0]);
+ local(@out);
+
+ push(@in, 0, 0); ## in case we need to round off an odd byte or two
+ while (@in >= 3) {
+ ##
+ ## From the next three input bytes,
+ ## construct four encoded output bytes.
+ ##
+ push(@out, $in[0] >> 2);
+ push(@out, (($in[0] << 4) & 060) | (($in[1] >> 4) & 017));
+ push(@out, (($in[1] << 2) & 074) | (($in[2] >> 6) & 003));
+ push(@out, $in[2] & 077);
+ splice(@in, 0, 3); ## remove these three
+ }
+
+ ##
+ ## @out elements are now indices to the string below. Convert to
+ ## the appropriate actual text.
+ ##
+ foreach $new (@out) {
+ $new = substr(
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/",
+ $new, 1);
+ }
+
+ if (@in == 2) {
+ ## the two left over are the two extra nulls, so we encoded the proper
+ ## amount as-is.
+ } elsif (@in == 1) {
+ ## We encoded one extra null too many. Undo it.
+ $out[$#out] = '=';
+ } else {
+ ## We must have encoded two nulls... Undo both.
+ $out[$#out ] = '=';
+ $out[$#out -1] = '=';
+ }
+
+ join('', @out);
+}
+
+##
+## This message stuff really shouldn't be here, but in some seperate library.
+## Sorry.
+##
+## Called as &message(SAVE, TEXT ....), it shoves the text to the screen.
+## If SAVE is true, bumps the text out as a printed line. Otherwise,
+## will shove out without a newline so that the next message overwrites it,
+## or it is clearded via &clear_message().
+##
+sub message
+{
+ local($nl) = shift;
+ die "oops $nl." unless $nl =~ m/^\d+$/;
+ local($text) = join('', @_);
+ local($NL) = $nl ? "\n" : "\r";
+ $thislength = length($text);
+ if ($thislength >= $last_message_length) {
+ print STDERR $text, $NL;
+ } else {
+ print STDERR $text, ' 'x ($last_message_length-$thislength), $NL;
+ }
+ $last_message_length = $nl ? 0 : $thislength;
+}
+
+sub clear_message
+{
+ if ($last_message_length) {
+ print STDERR ' ' x $last_message_length, "\r";
+ $last_message_length = 0;
+ }
+}
+
+1;
+__END__
diff --git a/gnu/usr.bin/perl/win32/config.bc b/gnu/usr.bin/perl/win32/config.bc
new file mode 100644
index 00000000000..ad76309e5d9
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/config.bc
@@ -0,0 +1,498 @@
+#
+## This file was hand coded and a lot of information is invalid
+#
+## Configured by: ~cf_email~
+## Target system: WIN32
+#
+
+archlibexp='~INST_TOP~\lib'
+archname='MSWin32'
+cc='bcc32'
+ccflags='-DWIN32'
+cppflags='-DWIN32'
+dlsrc='dl_win32.xs'
+dynamic_ext='Fcntl IO Opcode SDBM_File Socket'
+extensions='Fcntl IO Opcode SDBM_File Socket'
+installarchlib='~INST_TOP~\lib'
+installprivlib='~INST_TOP~\lib'
+libpth=''
+libs=''
+osname='MSWin32'
+osvers='4.0'
+prefix='~INST_DRV~'
+privlibexp='~INST_TOP~\lib'
+sharpbang='#!'
+shsharp='true'
+sig_name='ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM USR1 USR2 CHLD PWR WINCH URG IO STOP TSTP CONT TTIN TTOU VTALRM PROF XCPU XFSZ WAITING LWP FREEZE THAW RTMIN NUM37 NUM38 NUM39 NUM40 NUM41 NUM42 RTMAX IOT CLD POLL'
+so='dll'
+startsh='#!/bin/sh'
+static_ext=' '
+Author=''
+CONFIG='true'
+Date='$Date'
+Header=''
+Id='$Id'
+Locker=''
+Log='$Log'
+Mcc='Mcc'
+PATCHLEVEL='~PATCHLEVEL~'
+POSIX_cflags='ccflags="$ccflags -DSTRUCT_TM_HASZONE"'
+RCSfile='$RCSfile'
+Revision='$Revision'
+SUBVERSION='~SUBVERSION~'
+Source=''
+State=''
+afs='false'
+alignbytes='8'
+aphostname=''
+ar='tlib /P128'
+archlib='~INST_TOP~\lib'
+archobjs=''
+awk='awk'
+baserev='5.0'
+bash=''
+bin='~INST_TOP~\bin'
+binexp='~INST_TOP~\bin'
+bison=''
+byacc='byacc'
+byteorder='1234'
+c=''
+castflags='0'
+cat='type'
+cccdlflags=''
+ccdlflags=' '
+cf_by='garyng'
+cf_email='71564.1743@compuserve.com'
+cf_time='Thu Apr 11 06:20:49 PDT 1996'
+chgrp=''
+chmod=''
+chown=''
+clocktype='clock_t'
+comm=''
+compress=''
+contains='grep'
+cp='copy'
+cpio=''
+cpp='cpp32'
+cpp_stuff='42'
+cpplast=''
+cppminus=''
+cpprun=''
+cppstdin=''
+cryptlib=''
+csh='undef'
+d_Gconvert='gcvt((x),(n),(b))'
+d_access='define'
+d_alarm='undef'
+d_archlib='define'
+d_attribut='undef'
+d_bcmp='undef'
+d_bcopy='undef'
+d_bincompat3='undef'
+d_bsd='define'
+d_bsdgetpgrp='undef'
+d_bsdpgrp='undef'
+d_bsdsetpgrp='undef'
+d_bzero='undef'
+d_casti32='define'
+d_castneg='define'
+d_charvspr='undef'
+d_chown='undef'
+d_chroot='undef'
+d_chsize='define'
+d_closedir='define'
+d_const='define'
+d_crypt='undef'
+d_csh='undef'
+d_cuserid='undef'
+d_dbl_dig='define'
+d_difftime='define'
+d_dirnamlen='define'
+d_dlerror='define'
+d_dlopen='define'
+d_dlsymun='undef'
+d_dosuid='undef'
+d_dup2='define'
+d_eofnblk='define'
+d_eunice='undef'
+d_fchmod='undef'
+d_fchown='undef'
+d_fcntl='undef'
+d_fd_macros='define'
+d_fd_set='define'
+d_fds_bits='define'
+d_fgetpos='define'
+d_flexfnam='define'
+d_flock='define'
+d_fork='undef'
+d_fpathconf='undef'
+d_fsetpos='define'
+d_getgrps='undef'
+d_setgrps='undef'
+d_gethent='undef'
+d_gethname='undef'
+d_getlogin='undef'
+d_getpgrp2='undef'
+d_getpgrp='undef'
+d_getpgid='undef'
+d_getppid='undef'
+d_getprior='undef'
+d_gettimeod='undef'
+d_htonl='define'
+d_index='undef'
+d_inetaton='undef'
+d_isascii='define'
+d_killpg='undef'
+d_link='undef'
+d_locconv='define'
+d_lockf='undef'
+d_lstat='undef'
+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='undef'
+d_mktime='define'
+d_msg='undef'
+d_msgctl='define'
+d_msgget='define'
+d_msgrcv='define'
+d_msgsnd='define'
+d_mymalloc='undef'
+d_nice='undef'
+d_oldarchlib='undef'
+d_oldsock='undef'
+d_open3='undef'
+d_pathconf='undef'
+d_pause='define'
+d_phostname='undef'
+d_pipe='define'
+d_poll='undef'
+d_portable='define'
+d_pwage='undef'
+d_pwchange='undef'
+d_pwclass='undef'
+d_pwcomment='undef'
+d_pwexpire='undef'
+d_pwquota='undef'
+d_readdir='define'
+d_readlink='undef'
+d_rename='define'
+d_rewinddir='define'
+d_rmdir='define'
+d_safebcpy='undef'
+d_safemcpy='undef'
+d_sanemcmp='define'
+d_seekdir='define'
+d_select='define'
+d_sem='undef'
+d_semctl='define'
+d_semget='define'
+d_semop='define'
+d_setegid='undef'
+d_seteuid='undef'
+d_setlinebuf='undef'
+d_setlocale='define'
+d_setpgid='undef'
+d_setpgrp2='undef'
+d_setpgrp='undef'
+d_setprior='undef'
+d_setregid='undef'
+d_setresgid='undef'
+d_setresuid='undef'
+d_setreuid='undef'
+d_setrgid='undef'
+d_setruid='undef'
+d_setsid='undef'
+d_sfio='undef'
+d_shm='undef'
+d_shmat='undef'
+d_shmatprototype='undef'
+d_shmctl='define'
+d_shmdt='define'
+d_shmget='define'
+d_shrplib='undef'
+d_sigaction='undef'
+d_sigintrp=''
+d_sigsetjmp='undef'
+d_sigvec='define'
+d_sigvectr='undef'
+d_socket='define'
+d_sockpair='undef'
+d_statblks='undef'
+d_stdio_cnt_lval='define'
+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='undef'
+d_syscall='undef'
+d_sysconf='undef'
+d_sysernlst=''
+d_syserrlst='define'
+d_system='define'
+d_tcgetpgrp='undef'
+d_tcsetpgrp='undef'
+d_telldir='define'
+d_time='define'
+d_times='define'
+d_truncate='undef'
+d_tzname='define'
+d_umask='define'
+d_uname='undef'
+d_vfork='undef'
+d_void_closedir='undef'
+d_voidsig='define'
+d_voidtty=''
+d_volatile='define'
+d_vprintf='define'
+d_wait4='undef'
+d_waitpid='undef'
+d_wcstombs='define'
+d_wctomb='define'
+d_xenix='undef'
+date='date'
+db_hashtype='int'
+db_prefixtype='int'
+defvoidused='15'
+direntrytype='struct direct'
+dlext='dll'
+eagain='EAGAIN'
+echo='echo'
+egrep='egrep'
+emacs=''
+eunicefix=':'
+exe_ext='.exe'
+expr='expr'
+find='find'
+firstmakefile='makefile'
+flex=''
+fpostype='fpos_t'
+freetype='void'
+full_csh=''
+full_sed=''
+gcc=''
+gccversion=''
+gidtype='gid_t'
+glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib '
+grep='grep'
+groupcat=''
+groupstype='gid_t'
+h_fcntl='false'
+h_sysfile='true'
+hint='recommended'
+hostcat='ypcat hosts'
+huge=''
+i_bsdioctl=''
+i_db='undef'
+i_dbm='undef'
+i_dirent='define'
+i_dld='undef'
+i_dlfcn='define'
+i_fcntl='define'
+i_float='define'
+i_gdbm='define'
+i_grp='define'
+i_limits='define'
+i_locale='define'
+i_malloc='define'
+i_math='define'
+i_memory='undef'
+i_ndbm='undef'
+i_neterrno='undef'
+i_niin='undef'
+i_pwd='undef'
+i_rpcsvcdbm='define'
+i_sfio='undef'
+i_sgtty='undef'
+i_stdarg='define'
+i_stddef='define'
+i_stdlib='define'
+i_string='define'
+i_sysdir='undef'
+i_sysfile='undef'
+i_sysfilio='define'
+i_sysin='undef'
+i_sysioctl='undef'
+i_sysndir='undef'
+i_sysparam='undef'
+i_sysresrc='undef'
+i_sysselct='undef'
+i_syssockio=''
+i_sysstat='define'
+i_systime='undef'
+i_systimek='undef'
+i_systimes='undef'
+i_systypes='define'
+i_sysun='undef'
+i_syswait='undef'
+i_termio='undef'
+i_termios='undef'
+i_time='define'
+i_unistd='undef'
+i_utime='define'
+i_values='undef'
+i_varargs='undef'
+i_varhdr='varargs.h'
+i_vfork='undef'
+incpath=''
+inews=''
+installbin='~INST_TOP~\bin'
+installman1dir='~INST_TOP~\man\man1'
+installman3dir='~INST_TOP~\man\man3'
+installscript='~INST_TOP~\bin'
+installsitearch='~INST_TOP~\lib\site'
+installsitelib='~INST_TOP~\lib\site'
+intsize='4'
+known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket'
+ksh=''
+large=''
+ld='tlink32'
+lddlflags='-Tpd'
+ldflags=''
+less='less'
+lib_ext='.lib'
+libc='cw32mti.lib'
+libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
+line='line'
+lint=''
+lkflags=''
+ln=''
+lns='copy'
+locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include'
+loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib'
+longsize='4'
+lp=''
+lpr=''
+ls='dir'
+lseektype='off_t'
+mail=''
+mailx=''
+make='dmake'
+mallocobj='malloc.o'
+mallocsrc='malloc.c'
+malloctype='void *'
+man1dir='~INST_TOP~\man\man1'
+man1direxp='~INST_TOP~\man\man1'
+man1ext='1'
+man3dir='~INST_TOP~\man\man3'
+man3direxp='~INST_TOP~\man\man3'
+man3ext='3'
+medium=''
+mips=''
+mips_type=''
+mkdir='mkdir'
+models='none'
+modetype='mode_t'
+more='more /e'
+mv=''
+myarchname='MSWin32'
+mydomain=''
+myhostname=''
+myuname=''
+n='-n'
+nm_opt=''
+nm_so_opt=''
+nroff=''
+o_nonblock='O_NONBLOCK'
+obj_ext='.obj'
+oldarchlib=''
+oldarchlibexp=''
+optimize='-O'
+orderlib='false'
+package='perl5'
+pager='more /e'
+passcat=''
+patchlevel='2'
+path_sep=';'
+perl='perl'
+perladmin=''
+perlpath='~INST_TOP~\bin\perl.exe'
+pg=''
+phostname='hostname'
+plibpth=''
+pmake=''
+pr=''
+prefixexp='~INST_DRV~'
+privlib='~INST_TOP~\lib'
+prototype='define'
+randbits='15'
+ranlib=''
+rd_nodata='-1'
+rm='del'
+rmail=''
+runnm='true'
+scriptdir='~INST_TOP~\bin'
+scriptdirexp='~INST_TOP~\bin'
+sed='sed'
+selecttype='int *'
+sendmail='blat'
+sh='cmd /x /c'
+shar=''
+shmattype='void *'
+shortsize='2'
+shrpdir='none'
+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 32 33 34 35 36 37 38 39 40 41 42 43 6 18 22'
+signal_t='void'
+sitearch='~INST_TOP~\lib\site'
+sitearchexp='~INST_TOP~\lib\site'
+sitelib='~INST_TOP~\lib\site'
+sitelibexp='~INST_TOP~\lib\site'
+sizetype='size_t'
+sleep=''
+smail=''
+small=''
+sockethdr=''
+socketlib=''
+sort='sort'
+spackage='Perl5'
+spitshell=''
+split=''
+ssizetype='int'
+startperl='#perl'
+stdchar='unsigned char'
+stdio_base='((fp)->buffer)'
+stdio_bufsiz='((fp)->level + (fp)->curp - (fp)->buffer)'
+stdio_cnt='((fp)->level)'
+stdio_ptr='((fp)->curp)'
+strings='/usr/include/string.h'
+submit=''
+sysman='/usr/man/man1'
+tail=''
+tar=''
+tbl=''
+test=''
+timeincl='/usr/include/sys/time.h '
+timetype='time_t'
+touch='touch'
+tr=''
+troff=''
+uidtype='uid_t'
+uname='uname'
+uniq='uniq'
+usedl='define'
+usemymalloc='n'
+usenm='false'
+useperlio='undef'
+useposix='true'
+usesafe='true'
+usevfork='false'
+usrinc='/usr/include'
+uuname=''
+vi=''
+voidflags='15'
+xlibpth='/usr/lib/386 /lib/386'
+zcat=''
diff --git a/gnu/usr.bin/perl/win32/config.vc b/gnu/usr.bin/perl/win32/config.vc
new file mode 100644
index 00000000000..7cc91dabd3b
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/config.vc
@@ -0,0 +1,498 @@
+#
+## This file was hand coded and a lot of information is invalid
+#
+## Configured by: ~cf_email~
+## Target system: WIN32
+#
+
+archlibexp='~INST_TOP~\lib'
+archname='MSWin32'
+cc='cl'
+ccflags='-MD -DWIN32'
+cppflags='-DWIN32'
+dlsrc='dl_win32.xs'
+dynamic_ext='Fcntl IO Opcode SDBM_File Socket'
+extensions='Fcntl IO Opcode SDBM_File Socket'
+installarchlib='~INST_TOP~\lib'
+installprivlib='~INST_TOP~\lib'
+libpth=''
+libs=''
+osname='MSWin32'
+osvers='4.0'
+prefix='~INST_DRV~'
+privlibexp='~INST_TOP~\lib'
+sharpbang='#!'
+shsharp='true'
+sig_name='ZERO HUP INT QUIT ILL TRAP ABRT EMT FPE KILL BUS SEGV SYS PIPE ALRM TERM USR1 USR2 CHLD PWR WINCH URG IO STOP TSTP CONT TTIN TTOU VTALRM PROF XCPU XFSZ WAITING LWP FREEZE THAW RTMIN NUM37 NUM38 NUM39 NUM40 NUM41 NUM42 RTMAX IOT CLD POLL'
+so='dll'
+startsh='#!/bin/sh'
+static_ext=' '
+Author=''
+CONFIG='true'
+Date='$Date'
+Header=''
+Id='$Id'
+Locker=''
+Log='$Log'
+Mcc='Mcc'
+PATCHLEVEL='~PATCHLEVEL~'
+POSIX_cflags='ccflags="$ccflags -DSTRUCT_TM_HASZONE"'
+RCSfile='$RCSfile'
+Revision='$Revision'
+SUBVERSION='~SUBVERSION~'
+Source=''
+State=''
+afs='false'
+alignbytes='8'
+aphostname=''
+ar='lib'
+archlib='~INST_TOP~\lib'
+archobjs=''
+awk='awk'
+baserev='5.0'
+bash=''
+bin='~INST_TOP~\bin'
+binexp='~INST_TOP~\bin'
+bison=''
+byacc='byacc'
+byteorder='1234'
+c=''
+castflags='0'
+cat='type'
+cccdlflags=''
+ccdlflags=' '
+cf_by='garyng'
+cf_email='71564.1743@compuserve.com'
+cf_time='Thu Apr 11 06:20:49 PDT 1996'
+chgrp=''
+chmod=''
+chown=''
+clocktype='clock_t'
+comm=''
+compress=''
+contains='grep'
+cp='copy'
+cpio=''
+cpp='cpp'
+cpp_stuff='42'
+cpplast=''
+cppminus=''
+cpprun='cl -E'
+cppstdin='cl -E'
+cryptlib=''
+csh='undef'
+d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+d_access='define'
+d_alarm='undef'
+d_archlib='define'
+d_attribut='undef'
+d_bcmp='undef'
+d_bcopy='undef'
+d_bincompat3='undef'
+d_bsd='define'
+d_bsdgetpgrp='undef'
+d_bsdpgrp='undef'
+d_bsdsetpgrp='undef'
+d_bzero='undef'
+d_casti32='define'
+d_castneg='define'
+d_charvspr='undef'
+d_chown='undef'
+d_chroot='undef'
+d_chsize='define'
+d_closedir='define'
+d_const='define'
+d_crypt='undef'
+d_csh='undef'
+d_cuserid='undef'
+d_dbl_dig='define'
+d_difftime='define'
+d_dirnamlen='define'
+d_dlerror='define'
+d_dlopen='define'
+d_dlsymun='undef'
+d_dosuid='undef'
+d_dup2='define'
+d_eofnblk='define'
+d_eunice='undef'
+d_fchmod='undef'
+d_fchown='undef'
+d_fcntl='undef'
+d_fd_macros='define'
+d_fd_set='define'
+d_fds_bits='define'
+d_fgetpos='define'
+d_flexfnam='define'
+d_flock='define'
+d_fork='undef'
+d_fpathconf='undef'
+d_fsetpos='define'
+d_getgrps='undef'
+d_setgrps='undef'
+d_gethent='undef'
+d_gethname='undef'
+d_getlogin='undef'
+d_getpgrp2='undef'
+d_getpgrp='undef'
+d_getpgid='undef'
+d_getppid='undef'
+d_getprior='undef'
+d_gettimeod='undef'
+d_htonl='define'
+d_index='undef'
+d_inetaton='undef'
+d_isascii='define'
+d_killpg='undef'
+d_link='undef'
+d_locconv='define'
+d_lockf='undef'
+d_lstat='undef'
+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='undef'
+d_mktime='define'
+d_msg='undef'
+d_msgctl='define'
+d_msgget='define'
+d_msgrcv='define'
+d_msgsnd='define'
+d_mymalloc='undef'
+d_nice='undef'
+d_oldarchlib='undef'
+d_oldsock='undef'
+d_open3='undef'
+d_pathconf='undef'
+d_pause='define'
+d_phostname='undef'
+d_pipe='define'
+d_poll='undef'
+d_portable='define'
+d_pwage='undef'
+d_pwchange='undef'
+d_pwclass='undef'
+d_pwcomment='undef'
+d_pwexpire='undef'
+d_pwquota='undef'
+d_readdir='define'
+d_readlink='undef'
+d_rename='define'
+d_rewinddir='define'
+d_rmdir='define'
+d_safebcpy='undef'
+d_safemcpy='undef'
+d_sanemcmp='define'
+d_seekdir='define'
+d_select='define'
+d_sem='undef'
+d_semctl='define'
+d_semget='define'
+d_semop='define'
+d_setegid='undef'
+d_seteuid='undef'
+d_setlinebuf='undef'
+d_setlocale='define'
+d_setpgid='undef'
+d_setpgrp2='undef'
+d_setpgrp='undef'
+d_setprior='undef'
+d_setregid='undef'
+d_setresgid='undef'
+d_setresuid='undef'
+d_setreuid='undef'
+d_setrgid='undef'
+d_setruid='undef'
+d_setsid='undef'
+d_sfio='undef'
+d_shm='undef'
+d_shmat='undef'
+d_shmatprototype='undef'
+d_shmctl='define'
+d_shmdt='define'
+d_shmget='define'
+d_shrplib='undef'
+d_sigaction='undef'
+d_sigintrp=''
+d_sigsetjmp='undef'
+d_sigvec='define'
+d_sigvectr='undef'
+d_socket='define'
+d_sockpair='undef'
+d_statblks='undef'
+d_stdio_cnt_lval='define'
+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='undef'
+d_syscall='undef'
+d_sysconf='undef'
+d_sysernlst=''
+d_syserrlst='define'
+d_system='define'
+d_tcgetpgrp='undef'
+d_tcsetpgrp='undef'
+d_telldir='define'
+d_time='define'
+d_times='define'
+d_truncate='undef'
+d_tzname='define'
+d_umask='define'
+d_uname='undef'
+d_vfork='undef'
+d_void_closedir='undef'
+d_voidsig='define'
+d_voidtty=''
+d_volatile='define'
+d_vprintf='define'
+d_wait4='undef'
+d_waitpid='undef'
+d_wcstombs='define'
+d_wctomb='define'
+d_xenix='undef'
+date='date'
+db_hashtype='int'
+db_prefixtype='int'
+defvoidused='15'
+direntrytype='struct direct'
+dlext='dll'
+eagain='EAGAIN'
+echo='echo'
+egrep='egrep'
+emacs=''
+eunicefix=':'
+exe_ext='.exe'
+expr='expr'
+find='find'
+firstmakefile='makefile'
+flex=''
+fpostype='fpos_t'
+freetype='void'
+full_csh=''
+full_sed=''
+gcc=''
+gccversion=''
+gidtype='gid_t'
+glibpth='/usr/shlib /lib/pa1.1 /usr/lib/large /lib /usr/lib /usr/lib/386 /lib/386 /lib/large /usr/lib/small /lib/small /usr/ccs/lib /usr/ucblib /usr/shlib '
+grep='grep'
+groupcat=''
+groupstype='gid_t'
+h_fcntl='false'
+h_sysfile='true'
+hint='recommended'
+hostcat='ypcat hosts'
+huge=''
+i_bsdioctl=''
+i_db='undef'
+i_dbm='undef'
+i_dirent='define'
+i_dld='undef'
+i_dlfcn='define'
+i_fcntl='define'
+i_float='define'
+i_gdbm='define'
+i_grp='define'
+i_limits='define'
+i_locale='define'
+i_malloc='define'
+i_math='define'
+i_memory='undef'
+i_ndbm='undef'
+i_neterrno='undef'
+i_niin='undef'
+i_pwd='undef'
+i_rpcsvcdbm='define'
+i_sfio='undef'
+i_sgtty='undef'
+i_stdarg='define'
+i_stddef='define'
+i_stdlib='define'
+i_string='define'
+i_sysdir='undef'
+i_sysfile='undef'
+i_sysfilio='define'
+i_sysin='undef'
+i_sysioctl='undef'
+i_sysndir='undef'
+i_sysparam='undef'
+i_sysresrc='undef'
+i_sysselct='undef'
+i_syssockio=''
+i_sysstat='define'
+i_systime='undef'
+i_systimek='undef'
+i_systimes='undef'
+i_systypes='define'
+i_sysun='undef'
+i_syswait='undef'
+i_termio='undef'
+i_termios='undef'
+i_time='define'
+i_unistd='undef'
+i_utime='define'
+i_values='undef'
+i_varargs='undef'
+i_varhdr='varargs.h'
+i_vfork='undef'
+incpath=''
+inews=''
+installbin='~INST_TOP~\bin'
+installman1dir='~INST_TOP~\man\man1'
+installman3dir='~INST_TOP~\man\man3'
+installscript='~INST_TOP~\bin'
+installsitearch='~INST_TOP~\lib\site'
+installsitelib='~INST_TOP~\lib\site'
+intsize='4'
+known_extensions='DB_File Fcntl GDBM_File NDBM_File ODBM_File Opcode POSIX SDBM_File Socket'
+ksh=''
+large=''
+ld='link'
+lddlflags='-dll'
+ldflags='-nologo -subsystem:windows'
+less='less'
+lib_ext='.lib'
+libc='msvcrt.lib'
+libswanted='net socket inet nsl nm ndbm gdbm dbm db malloc dl dld ld sun m c cposix posix ndir dir crypt ucb bsd BSD PW x'
+line='line'
+lint=''
+lkflags=''
+ln=''
+lns='copy'
+locincpth='/usr/local/include /opt/local/include /usr/gnu/include /opt/gnu/include /usr/GNU/include /opt/GNU/include'
+loclibpth='/usr/local/lib /opt/local/lib /usr/gnu/lib /opt/gnu/lib /usr/GNU/lib /opt/GNU/lib'
+longsize='4'
+lp=''
+lpr=''
+ls='dir'
+lseektype='off_t'
+mail=''
+mailx=''
+make='nmake'
+mallocobj='malloc.o'
+mallocsrc='malloc.c'
+malloctype='void *'
+man1dir='~INST_TOP~\man\man1'
+man1direxp='~INST_TOP~\man\man1'
+man1ext='1'
+man3dir='~INST_TOP~\man\man3'
+man3direxp='~INST_TOP~\man\man3'
+man3ext='3'
+medium=''
+mips=''
+mips_type=''
+mkdir='mkdir'
+models='none'
+modetype='mode_t'
+more='more /e'
+mv=''
+myarchname='MSWin32'
+mydomain=''
+myhostname=''
+myuname=''
+n='-n'
+nm_opt=''
+nm_so_opt=''
+nroff=''
+o_nonblock='O_NONBLOCK'
+obj_ext='.obj'
+oldarchlib=''
+oldarchlibexp=''
+optimize='-O'
+orderlib='false'
+package='perl5'
+pager='more /e'
+passcat=''
+patchlevel='2'
+path_sep=';'
+perl='perl'
+perladmin=''
+perlpath='~INST_TOP~\bin\perl.exe'
+pg=''
+phostname='hostname'
+plibpth=''
+pmake=''
+pr=''
+prefixexp='~INST_DRV~'
+privlib='~INST_TOP~\lib'
+prototype='define'
+randbits='15'
+ranlib=''
+rd_nodata='-1'
+rm='del'
+rmail=''
+runnm='true'
+scriptdir='~INST_TOP~\bin'
+scriptdirexp='~INST_TOP~\bin'
+sed='sed'
+selecttype='int *'
+sendmail='blat'
+sh='cmd /x /c'
+shar=''
+shmattype='void *'
+shortsize='2'
+shrpdir='none'
+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 32 33 34 35 36 37 38 39 40 41 42 43 6 18 22'
+signal_t='void'
+sitearch='~INST_TOP~\lib\site'
+sitearchexp='~INST_TOP~\lib\site'
+sitelib='~INST_TOP~\lib\site'
+sitelibexp='~INST_TOP~\lib\site'
+sizetype='size_t'
+sleep=''
+smail=''
+small=''
+sockethdr=''
+socketlib=''
+sort='sort'
+spackage='Perl5'
+spitshell=''
+split=''
+ssizetype='int'
+startperl='#perl'
+stdchar='unsigned char'
+stdio_base='((fp)->_base)'
+stdio_bufsiz='((fp)->_cnt + (fp)->_ptr - (fp)->_base)'
+stdio_cnt='((fp)->_cnt)'
+stdio_ptr='((fp)->_ptr)'
+strings='/usr/include/string.h'
+submit=''
+sysman='/usr/man/man1'
+tail=''
+tar=''
+tbl=''
+test=''
+timeincl='/usr/include/sys/time.h '
+timetype='time_t'
+touch='touch'
+tr=''
+troff=''
+uidtype='uid_t'
+uname='uname'
+uniq='uniq'
+usedl='define'
+usemymalloc='n'
+usenm='false'
+useperlio='undef'
+useposix='true'
+usesafe='true'
+usevfork='false'
+usrinc='/usr/include'
+uuname=''
+vi=''
+voidflags='15'
+xlibpth='/usr/lib/386 /lib/386'
+zcat=''
diff --git a/gnu/usr.bin/perl/win32/config_H.bc b/gnu/usr.bin/perl/win32/config_H.bc
new file mode 100644
index 00000000000..61fb5a32412
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/config_H.bc
@@ -0,0 +1,1802 @@
+/*
+ * 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.4 1995/09/25 09:10:49 ram Exp $
+ */
+
+/* Configuration time: Thu Apr 11 06:20:49 PDT 1996
+ * Configured by: garyng
+ * Target system:
+ */
+
+#ifndef _config_h_
+#define _config_h_
+
+/* 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.
+ */
+#ifndef NeXT
+#define MEM_ALIGNBYTES 8 /**/
+#else /* NeXT */
+#ifdef __m68k__
+#define MEM_ALIGNBYTES 2
+#else
+#ifdef __i386__
+#define MEM_ALIGNBYTES 4
+#else /* __hppa__, __sparc__ and default for unknown architectures */
+#define MEM_ALIGNBYTES 8
+#endif /* __i386__ */
+#endif /* __m68k__ */
+#endif /* NeXT */
+
+/* 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.
+ */
+#ifdef _ALPHA_
+#define ARCHNAME "alpha-mswin32" /**/
+#else
+#define ARCHNAME "x86-mswin32" /**/
+#endif
+
+/* BIN:
+ * This symbol holds the path of the bin directory where the package will
+ * be installed. Program must be prepared to deal with ~name substitution.
+ */
+/* BIN_EXP:
+ * This symbol is the filename expanded version of the BIN symbol, for
+ * programs that do not want to deal with that at run-time.
+ */
+#define BIN "c:\\perl\\bin" /**/
+#define BIN_EXP "c:\\perl\\bin" /**/
+
+/* 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 CAT3(a,b,c)a/**/b/**/c
+#define CAT4(a,b,c,d)a/**/b/**/c/**/d
+#define CAT5(a,b,c,d,e)a/**/b/**/c/**/d/**/e
+#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 CAT3(a,b,c)a ## b ## c
+#define CAT4(a,b,c,d)a ## b ## c ## d
+#define CAT5(a,b,c,d,e)a ## b ## c ## d ## e
+#define StGiFy(a)# a
+#define STRINGIFY(a)StGiFy(a)
+#define SCAT2(a,b)StGiFy(a) StGiFy(b)
+#define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c)
+#define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d)
+#define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e)
+#endif
+#ifndef CAT2
+#include "Bletch: How does this C preprocessor catenate tokens?"
+#endif
+
+/* CPPSTDIN:
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp", but it can also
+ * call a wrapper. See CPPRUN.
+ */
+/* CPPMINUS:
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+#define CPPSTDIN ""
+#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 /**/
+
+/* 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 /**/
+
+/* 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 /**/
+
+/* VOID_CLOSEDIR:
+ * This symbol, if defined, indicates that the closedir() routine
+ * does not return a value.
+ */
+/*#define VOID_CLOSEDIR /**/
+
+/* HASCONST:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the const type. There is no need to actually test for that symbol
+ * within your programs. The mere use of the "const" keyword will
+ * trigger the necessary tests.
+ */
+#define HASCONST /**/
+#ifndef HASCONST
+#define const
+#endif
+
+/* HAS_CRYPT:
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+/*#define HAS_CRYPT /**/
+
+/* HAS_CUSERID:
+ * This symbol, if defined, indicates that the cuserid routine is
+ * available to get character login names.
+ */
+/*#define HAS_CUSERID /**/
+
+/* HAS_DBL_DIG:
+ * This symbol, if defined, indicates that this system's <float.h>
+ * or <limits.h> defines the symbol DBL_DIG, which is the number
+ * of significant digits in a double precision number. If this
+ * symbol is not defined, a guess of 15 is usually pretty good.
+ */
+#define HAS_DBL_DIG /**/
+
+/* HAS_DIFFTIME:
+ * This symbol, if defined, indicates that the difftime routine is
+ * available.
+ */
+#define HAS_DIFFTIME /**/
+
+/* HAS_DLERROR:
+ * This symbol, if defined, indicates that the dlerror routine is
+ * available to return a string describing the last error that
+ * occurred from a call to dlopen(), dlclose() or dlsym().
+ */
+#define HAS_DLERROR /**/
+
+/* HAS_DUP2:
+ * This symbol, if defined, indicates that the dup2 routine is
+ * available to duplicate file descriptors.
+ */
+#define HAS_DUP2 /**/
+
+/* HAS_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.
+ */
+/* 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_GETGROUPS /**/
+/*#define HAS_SETGROUPS /**/
+
+/* HAS_GETHOSTENT:
+ * This symbol, if defined, indicates that the gethostent routine is
+ * available to lookup host names in some data base or other.
+ */
+/*#define HAS_GETHOSTENT /**/
+
+/* 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_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_ISASCII:
+ * This manifest constant lets the C program know that isascii
+ * is available.
+ */
+#define HAS_ISASCII /**/
+
+/* 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_OPEN3:
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+/*#define HAS_OPEN3 /**/
+
+/* 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.
+ */
+/*#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_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_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_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 /**/
+
+/* HAS_SIGACTION:
+ * This symbol, if defined, indicates that Vr4's sigaction() routine
+ * is available.
+ */
+/*#define HAS_SIGACTION /**/
+
+/* 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 /**/
+
+/* USE_STAT_BLOCKS:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+/*#define USE_STAT_BLOCKS /**/
+
+/* 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)->curp)
+#define STDIO_PTR_LVALUE /**/
+#define FILE_cnt(fp) ((fp)->level)
+#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)->buffer)
+#define FILE_bufsiz(fp) ((fp)->level + (fp)->curp - (fp)->buffer)
+#endif
+
+/* 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 /**/
+
+/* Time_t:
+ * This symbol holds the type returned by time(). It can be long,
+ * or time_t on BSD sites (in which case <sys/types.h> should be
+ * included).
+ */
+#define Time_t time_t /* Time type */
+
+/* HAS_TIMES:
+ * This symbol, if defined, indicates that the times() routine exists.
+ * Note that this became obsolete on some systems (SUNOS), which now
+ * use getrusage(). It may be necessary to include <sys/times.h>.
+ */
+#define HAS_TIMES /**/
+
+/* HAS_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 /**/
+
+/* 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 */
+
+/* HASVOLATILE:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+#define HASVOLATILE /**/
+#ifndef HASVOLATILE
+#define volatile
+#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 /**/
+
+/* 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 /**/
+
+/* 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... */
+
+/* Groups_t:
+ * This symbol holds the type used for the second argument to
+ * [gs]etgroups(). Usually, this is the same of gidtype, 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 setgroups().
+ */
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+#define Groups_t gid_t /* Type for 2nd arg to [gs]etgroups() */
+#endif
+
+/* DB_Prefix_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is u_int32_t.
+ */
+/* DB_Hash_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is size_t.
+ */
+#define DB_Hash_t int /**/
+#define DB_Prefix_t int /**/
+
+/* 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 direct
+
+/* 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>.
+ */
+#define I_GRP /**/
+
+/* 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_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_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.
+ */
+/*#define I_PWD /**/
+/*#define PWQUOTA /**/
+/*#define PWAGE /**/
+/*#define PWCHANGE /**/
+/*#define PWCLASS /**/
+/*#define PWEXPIRE /**/
+/*#define PWCOMMENT /**/
+
+/* 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_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_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+/* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+/* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+#define I_TIME /**/
+/*#define I_SYS_TIME /**/
+/*#define I_SYS_TIME_KERNEL /**/
+
+/* I_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_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 /**/
+
+/* 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 /**/
+
+/* 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 */
+
+/* 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
+
+/* 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
+
+/* RANDBITS:
+ * This symbol contains the number of bits of random number the rand()
+ * function produces. Usual values are 15, 16, and 31.
+ */
+#define RANDBITS 15 /**/
+
+/* 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 int * /**/
+
+/* 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 */
+
+/* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+#define SSize_t int /* signed count of bytes */
+
+/* STDCHAR:
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+#define STDCHAR unsigned char /**/
+
+/* 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 */
+
+/* LOC_SED:
+ * This symbol holds the complete pathname to the sed program.
+ */
+#define LOC_SED "" /**/
+
+/* 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 "MSWin32" /**/
+
+/* ARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user wants to put architecture-dependent public
+ * library files for perl5. It is most often a local directory
+ * such as /usr/local/lib. Programs using this variable must be
+ * prepared to deal with filename expansion. If ARCHLIB is the
+ * same as PRIVLIB, it is not defined, since presumably the
+ * program already searches PRIVLIB.
+ */
+/* ARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of ARCHLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define ARCHLIB "c:\\perl\\lib" /**/
+#define ARCHLIB_EXP (win32PerlLibPath()) /**/
+
+/* BINCOMPAT3:
+ * This symbol, if defined, indicates that Perl 5.004 should be
+ * binary-compatible with Perl 5.003.
+ */
+/*#define BINCOMPAT3 /**/
+
+/* 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 */
+
+/* CSH:
+ * This symbol, if defined, indicates that the C-shell exists.
+ * If defined, contains the full pathname of csh.
+ */
+/*#define CSH "" /**/
+
+/* 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 /**/
+
+/* 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 /**/
+
+/* 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_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_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_SETPGID:
+ * This symbol, if defined, indicates to the C program that
+ * the setpgid(pid, gpid) function is available to set the
+ * 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.
+ */
+/* USE_BSDPGRP:
+ * This symbol, if defined, indicates that the BSD notion of process
+ * group is to be used. For instance, you have to say setpgrp(pid, pgrp)
+ * instead of the USG setpgrp(). This should be obsolete since
+ * there are systems which have BSD-ish setpgrp but USG-ish getpgrp.
+ */
+/*#define HAS_SETPGRP /**/
+/*#define USE_BSD_SETPGRP /**/
+/*#define USE_BSDPGRP /**/
+
+/* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+/*#define USE_SFIO /**/
+
+/* 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_DYNAMIC_LOADING:
+ * This symbol, if defined, indicates that dynamic loading of
+ * some sort is available.
+ */
+#define USE_DYNAMIC_LOADING /**/
+
+/* 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_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
+#define I_LOCALE /**/
+
+/* I_SFIO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sfio.h>.
+ */
+/*#define I_SFIO /**/
+
+/* I_SYS_STAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/stat.h>.
+ */
+#define I_SYS_STAT /**/
+
+/* 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 /**/
+
+/* 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 /**/
+
+/* OLDARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user has perl5.000 or perl5.001 architecture-dependent
+ * public library files for perl5. For the most part, these
+ * files will work with 5.002 (and later), but that is not
+ * guaranteed.
+ */
+/* OLDARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of OLDARCHLIB, to be
+ * used in programs that are not prepared to deal with ~ expansion at
+ * run-time.
+ */
+/*#define OLDARCHLIB "" /**/
+/*#define OLDARCHLIB_EXP "" /**/
+
+/* 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 "c:\\perl\\lib" /**/
+#define PRIVLIB_EXP "c:\\perl\\lib" /**/
+
+/* SH_PATH:
+ * This symbol contains the full pathname to the shell used on this
+ * on this system to execute Bourne shell scripts. Usually, this will be
+ * /bin/sh, though it's possible that some systems will have /bin/ksh,
+ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as
+ * D:/bin/sh.exe.
+ */
+#define SH_PATH "cmd.exe" /**/
+
+/* 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","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","CHLD","PWR","WINCH","URG","IO","STOP","TSTP","CONT","TTIN","TTOU","VTALRM","PROF","XCPU","XFSZ","WAITING","LWP","FREEZE","THAW","RTMIN","NUM37","NUM38","NUM39","NUM40","NUM41","NUM42","RTMAX","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,32,33,34,35,36,37,38,39,40,41,42,43,6,18,22,0 /**/
+
+/* 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 "c:\\perl\\lib\\site" /**/
+#define SITEARCH_EXP "c:\\perl\\lib\\site" /**/
+
+/* 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 "c:\\perl\\lib\\site" /**/
+#define SITELIB_EXP "c:\\perl\\lib\\site" /**/
+
+/* STARTPERL:
+ * This variable contains the string to put in front of a perl
+ * script to make sure (one hopes) that it runs with perl and not
+ * some shell.
+ */
+#define STARTPERL "#perl" /**/
+
+/* 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 /**/
+
+/* 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
+
+#endif
+#include <win32.h>
+#ifndef DEBUGGING
+#define DEBUGGING
+#endif
diff --git a/gnu/usr.bin/perl/win32/config_H.vc b/gnu/usr.bin/perl/win32/config_H.vc
new file mode 100644
index 00000000000..76f19f1d872
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/config_H.vc
@@ -0,0 +1,1802 @@
+/*
+ * 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.4 1995/09/25 09:10:49 ram Exp $
+ */
+
+/* Configuration time: Thu Apr 11 06:20:49 PDT 1996
+ * Configured by: garyng
+ * Target system:
+ */
+
+#ifndef _config_h_
+#define _config_h_
+
+/* 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.
+ */
+#ifndef NeXT
+#define MEM_ALIGNBYTES 8 /**/
+#else /* NeXT */
+#ifdef __m68k__
+#define MEM_ALIGNBYTES 2
+#else
+#ifdef __i386__
+#define MEM_ALIGNBYTES 4
+#else /* __hppa__, __sparc__ and default for unknown architectures */
+#define MEM_ALIGNBYTES 8
+#endif /* __i386__ */
+#endif /* __m68k__ */
+#endif /* NeXT */
+
+/* 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.
+ */
+#ifdef _ALPHA_
+#define ARCHNAME "alpha-mswin32" /**/
+#else
+#define ARCHNAME "x86-mswin32" /**/
+#endif
+
+/* BIN:
+ * This symbol holds the path of the bin directory where the package will
+ * be installed. Program must be prepared to deal with ~name substitution.
+ */
+/* BIN_EXP:
+ * This symbol is the filename expanded version of the BIN symbol, for
+ * programs that do not want to deal with that at run-time.
+ */
+#define BIN "c:\\perl\\bin" /**/
+#define BIN_EXP "c:\\perl\\bin" /**/
+
+/* 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 CAT3(a,b,c)a/**/b/**/c
+#define CAT4(a,b,c,d)a/**/b/**/c/**/d
+#define CAT5(a,b,c,d,e)a/**/b/**/c/**/d/**/e
+#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 CAT3(a,b,c)a ## b ## c
+#define CAT4(a,b,c,d)a ## b ## c ## d
+#define CAT5(a,b,c,d,e)a ## b ## c ## d ## e
+#define StGiFy(a)# a
+#define STRINGIFY(a)StGiFy(a)
+#define SCAT2(a,b)StGiFy(a) StGiFy(b)
+#define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c)
+#define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d)
+#define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e)
+#endif
+#ifndef CAT2
+#include "Bletch: How does this C preprocessor catenate tokens?"
+#endif
+
+/* CPPSTDIN:
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp", but it can also
+ * call a wrapper. See CPPRUN.
+ */
+/* CPPMINUS:
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+#define CPPSTDIN "cl -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 /**/
+
+/* 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 /**/
+
+/* 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 /**/
+
+/* VOID_CLOSEDIR:
+ * This symbol, if defined, indicates that the closedir() routine
+ * does not return a value.
+ */
+/*#define VOID_CLOSEDIR /**/
+
+/* HASCONST:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the const type. There is no need to actually test for that symbol
+ * within your programs. The mere use of the "const" keyword will
+ * trigger the necessary tests.
+ */
+#define HASCONST /**/
+#ifndef HASCONST
+#define const
+#endif
+
+/* HAS_CRYPT:
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+/*#define HAS_CRYPT /**/
+
+/* HAS_CUSERID:
+ * This symbol, if defined, indicates that the cuserid routine is
+ * available to get character login names.
+ */
+/*#define HAS_CUSERID /**/
+
+/* HAS_DBL_DIG:
+ * This symbol, if defined, indicates that this system's <float.h>
+ * or <limits.h> defines the symbol DBL_DIG, which is the number
+ * of significant digits in a double precision number. If this
+ * symbol is not defined, a guess of 15 is usually pretty good.
+ */
+#define HAS_DBL_DIG /**/
+
+/* HAS_DIFFTIME:
+ * This symbol, if defined, indicates that the difftime routine is
+ * available.
+ */
+#define HAS_DIFFTIME /**/
+
+/* HAS_DLERROR:
+ * This symbol, if defined, indicates that the dlerror routine is
+ * available to return a string describing the last error that
+ * occurred from a call to dlopen(), dlclose() or dlsym().
+ */
+#define HAS_DLERROR /**/
+
+/* HAS_DUP2:
+ * This symbol, if defined, indicates that the dup2 routine is
+ * available to duplicate file descriptors.
+ */
+#define HAS_DUP2 /**/
+
+/* HAS_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.
+ */
+/* 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_GETGROUPS /**/
+/*#define HAS_SETGROUPS /**/
+
+/* HAS_GETHOSTENT:
+ * This symbol, if defined, indicates that the gethostent routine is
+ * available to lookup host names in some data base or other.
+ */
+/*#define HAS_GETHOSTENT /**/
+
+/* 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_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_ISASCII:
+ * This manifest constant lets the C program know that isascii
+ * is available.
+ */
+#define HAS_ISASCII /**/
+
+/* 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_OPEN3:
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+/*#define HAS_OPEN3 /**/
+
+/* 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.
+ */
+/*#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_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_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_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 /**/
+
+/* HAS_SIGACTION:
+ * This symbol, if defined, indicates that Vr4's sigaction() routine
+ * is available.
+ */
+/*#define HAS_SIGACTION /**/
+
+/* 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 /**/
+
+/* USE_STAT_BLOCKS:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+/*#define USE_STAT_BLOCKS /**/
+
+/* 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)->_ptr)
+#define STDIO_PTR_LVALUE /**/
+#define FILE_cnt(fp) ((fp)->_cnt)
+#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)->_base)
+#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
+#endif
+
+/* 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 /**/
+
+/* Time_t:
+ * This symbol holds the type returned by time(). It can be long,
+ * or time_t on BSD sites (in which case <sys/types.h> should be
+ * included).
+ */
+#define Time_t time_t /* Time type */
+
+/* HAS_TIMES:
+ * This symbol, if defined, indicates that the times() routine exists.
+ * Note that this became obsolete on some systems (SUNOS), which now
+ * use getrusage(). It may be necessary to include <sys/times.h>.
+ */
+#define HAS_TIMES /**/
+
+/* HAS_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 /**/
+
+/* 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 */
+
+/* HASVOLATILE:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+#define HASVOLATILE /**/
+#ifndef HASVOLATILE
+#define volatile
+#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 /**/
+
+/* 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 /**/
+
+/* 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... */
+
+/* Groups_t:
+ * This symbol holds the type used for the second argument to
+ * [gs]etgroups(). Usually, this is the same of gidtype, 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 setgroups().
+ */
+#if defined(HAS_GETGROUPS) || defined(HAS_SETGROUPS)
+#define Groups_t gid_t /* Type for 2nd arg to [gs]etgroups() */
+#endif
+
+/* DB_Prefix_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is u_int32_t.
+ */
+/* DB_Hash_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is size_t.
+ */
+#define DB_Hash_t int /**/
+#define DB_Prefix_t int /**/
+
+/* 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 direct
+
+/* 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>.
+ */
+#define I_GRP /**/
+
+/* 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_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_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.
+ */
+/*#define I_PWD /**/
+/*#define PWQUOTA /**/
+/*#define PWAGE /**/
+/*#define PWCHANGE /**/
+/*#define PWCLASS /**/
+/*#define PWEXPIRE /**/
+/*#define PWCOMMENT /**/
+
+/* 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_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_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+/* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+/* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+#define I_TIME /**/
+/*#define I_SYS_TIME /**/
+/*#define I_SYS_TIME_KERNEL /**/
+
+/* I_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_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 /**/
+
+/* 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 /**/
+
+/* 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 */
+
+/* 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
+
+/* 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
+
+/* RANDBITS:
+ * This symbol contains the number of bits of random number the rand()
+ * function produces. Usual values are 15, 16, and 31.
+ */
+#define RANDBITS 15 /**/
+
+/* 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 int * /**/
+
+/* 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 */
+
+/* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+#define SSize_t int /* signed count of bytes */
+
+/* STDCHAR:
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+#define STDCHAR unsigned char /**/
+
+/* 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 */
+
+/* LOC_SED:
+ * This symbol holds the complete pathname to the sed program.
+ */
+#define LOC_SED "" /**/
+
+/* 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 "MSWin32" /**/
+
+/* ARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user wants to put architecture-dependent public
+ * library files for perl5. It is most often a local directory
+ * such as /usr/local/lib. Programs using this variable must be
+ * prepared to deal with filename expansion. If ARCHLIB is the
+ * same as PRIVLIB, it is not defined, since presumably the
+ * program already searches PRIVLIB.
+ */
+/* ARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of ARCHLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+#define ARCHLIB "c:\\perl\\lib" /**/
+#define ARCHLIB_EXP (win32PerlLibPath()) /**/
+
+/* BINCOMPAT3:
+ * This symbol, if defined, indicates that Perl 5.004 should be
+ * binary-compatible with Perl 5.003.
+ */
+/*#define BINCOMPAT3 /**/
+
+/* 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 */
+
+/* CSH:
+ * This symbol, if defined, indicates that the C-shell exists.
+ * If defined, contains the full pathname of csh.
+ */
+/*#define CSH "" /**/
+
+/* 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 /**/
+
+/* 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 /**/
+
+/* Gconvert:
+ * This preprocessor macro is defined to convert a floating point
+ * number to a string without a trailing decimal point. This
+ * emulates the behavior of sprintf("%g"), but is sometimes much more
+ * efficient. If gconvert() is not available, but gcvt() drops the
+ * trailing decimal point, then gcvt() is used. If all else fails,
+ * a macro using sprintf("%g") is used. Arguments for the Gconvert
+ * macro are: value, number of digits, whether trailing zeros should
+ * be retained, and the output buffer.
+ * Possible values are:
+ * d_Gconvert='gconvert((x),(n),(t),(b))'
+ * d_Gconvert='gcvt((x),(n),(b))'
+ * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ * The last two assume trailing zeros should not be kept.
+ */
+#define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
+
+/* HAS_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_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_SETPGID:
+ * This symbol, if defined, indicates to the C program that
+ * the setpgid(pid, gpid) function is available to set the
+ * 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.
+ */
+/* USE_BSDPGRP:
+ * This symbol, if defined, indicates that the BSD notion of process
+ * group is to be used. For instance, you have to say setpgrp(pid, pgrp)
+ * instead of the USG setpgrp(). This should be obsolete since
+ * there are systems which have BSD-ish setpgrp but USG-ish getpgrp.
+ */
+/*#define HAS_SETPGRP /**/
+/*#define USE_BSD_SETPGRP /**/
+/*#define USE_BSDPGRP /**/
+
+/* USE_SFIO:
+ * This symbol, if defined, indicates that sfio should
+ * be used.
+ */
+/*#define USE_SFIO /**/
+
+/* 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_DYNAMIC_LOADING:
+ * This symbol, if defined, indicates that dynamic loading of
+ * some sort is available.
+ */
+#define USE_DYNAMIC_LOADING /**/
+
+/* 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_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
+#define I_LOCALE /**/
+
+/* I_SFIO:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sfio.h>.
+ */
+/*#define I_SFIO /**/
+
+/* I_SYS_STAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/stat.h>.
+ */
+#define I_SYS_STAT /**/
+
+/* 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 /**/
+
+/* 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 /**/
+
+/* OLDARCHLIB:
+ * This variable, if defined, holds the name of the directory in
+ * which the user has perl5.000 or perl5.001 architecture-dependent
+ * public library files for perl5. For the most part, these
+ * files will work with 5.002 (and later), but that is not
+ * guaranteed.
+ */
+/* OLDARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of OLDARCHLIB, to be
+ * used in programs that are not prepared to deal with ~ expansion at
+ * run-time.
+ */
+/*#define OLDARCHLIB "" /**/
+/*#define OLDARCHLIB_EXP "" /**/
+
+/* 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 "c:\\perl\\lib" /**/
+#define PRIVLIB_EXP "c:\\perl\\lib" /**/
+
+/* SH_PATH:
+ * This symbol contains the full pathname to the shell used on this
+ * on this system to execute Bourne shell scripts. Usually, this will be
+ * /bin/sh, though it's possible that some systems will have /bin/ksh,
+ * /bin/pdksh, /bin/ash, /bin/bash, or even something such as
+ * D:/bin/sh.exe.
+ */
+#define SH_PATH "cmd.exe" /**/
+
+/* 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","EMT","FPE","KILL","BUS","SEGV","SYS","PIPE","ALRM","TERM","USR1","USR2","CHLD","PWR","WINCH","URG","IO","STOP","TSTP","CONT","TTIN","TTOU","VTALRM","PROF","XCPU","XFSZ","WAITING","LWP","FREEZE","THAW","RTMIN","NUM37","NUM38","NUM39","NUM40","NUM41","NUM42","RTMAX","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,32,33,34,35,36,37,38,39,40,41,42,43,6,18,22,0 /**/
+
+/* 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 "c:\\perl\\lib\\site" /**/
+#define SITEARCH_EXP "c:\\perl\\lib\\site" /**/
+
+/* 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 "c:\\perl\\lib\\site" /**/
+#define SITELIB_EXP "c:\\perl\\lib\\site" /**/
+
+/* STARTPERL:
+ * This variable contains the string to put in front of a perl
+ * script to make sure (one hopes) that it runs with perl and not
+ * some shell.
+ */
+#define STARTPERL "#perl" /**/
+
+/* 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 /**/
+
+/* 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
+
+#endif
+#include <win32.h>
+#ifndef DEBUGGING
+#define DEBUGGING
+#endif
diff --git a/gnu/usr.bin/perl/win32/config_h.PL b/gnu/usr.bin/perl/win32/config_h.PL
new file mode 100644
index 00000000000..5d47016dc97
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/config_h.PL
@@ -0,0 +1,92 @@
+#
+use Config;
+use File::Compare qw(compare);
+use File::Copy qw(copy);
+my $name = $0;
+$name =~ s#^(.*)\.PL$#../$1.SH#;
+open(SH,"<$name") || die "Cannot open $name:$!";
+while (<SH>)
+ {
+ last if /^sed/;
+ }
+($term,$file,$pat) = /^sed\s+<<(\S+)\s+>(\S+)\s+(.*)$/;
+
+my $str = "sub munge\n{\n";
+
+while ($pat =~ s/-e\s+'([^']*)'\s*//)
+ {
+ my $e = $1;
+ $e =~ s/\\([\(\)])/$1/g;
+ $e =~ s/\\(\d)/\$$1/g;
+ $str .= "$e;\n";
+ }
+$str .= "}\n";
+
+eval $str;
+
+die "$str:$@" if $@;
+
+open(H,">$file.new") || die "Cannot open $file.new:$!";
+while (<SH>)
+ {
+ last if /^$term$/o;
+ s/\$([\w_]+)/Config($1)/eg;
+ s/`([^\`]*)`/BackTick($1)/eg;
+ munge();
+ s/\\\$/\$/g;
+ s#/[ *\*]*\*/#/**/#;
+ if (/^\s*#define\s+ARCHLIB_EXP/)
+ {
+ $_ = "#define ARCHLIB_EXP (win32PerlLibPath())\t/**/\n"
+ . "#define APPLLIB_EXP (win32SiteLibPath())\t/**/\n";
+ }
+ print H;
+ }
+print H "#include <win32.h>
+#ifndef DEBUGGING
+#define DEBUGGING
+#endif
+";
+close(H);
+close(SH);
+
+
+chmod(0666,"../lib/CORE/config.h");
+copy("$file.new","../lib/CORE/config.h") || die "Cannot copy:$!";
+chmod(0444,"../lib/CORE/config.h");
+
+if (compare("$file.new",$file))
+ {
+ warn "$file has changed\n";
+ chmod(0666,$file);
+ unlink($file);
+ rename("$file.new",$file);
+ chmod(0444,$file);
+ exit(1);
+ }
+
+sub Config
+{
+ my $var = shift;
+ my $val = $Config{$var};
+ $val = 'undef' unless defined $val;
+ $val =~ s/\\/\\\\/g;
+ return $val;
+}
+
+sub BackTick
+{
+ my $cmd = shift;
+ if ($cmd =~ /^echo\s+(.*?)\s*\|\s+sed\s+'(.*)'\s*$/)
+ {
+ local ($data,$pat) = ($1,$2);
+ $data =~ s/\s+/ /g;
+ eval "\$data =~ $pat";
+ return $data;
+ }
+ else
+ {
+ die "Cannot handle \`$cmd\`";
+ }
+ return $cmd;
+}
diff --git a/gnu/usr.bin/perl/win32/config_sh.PL b/gnu/usr.bin/perl/win32/config_sh.PL
new file mode 100644
index 00000000000..0769ef31120
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/config_sh.PL
@@ -0,0 +1,23 @@
+my %opt;
+while (@ARGV && $ARGV[0] =~ /^([\w_]+)=(.*)$/)
+ {
+ $opt{$1}=$2;
+ shift(@ARGV);
+ }
+
+if ($] =~ /\.(\d\d\d)?(\d\d)?$/) { # should always be true
+ $opt{PATCHLEVEL} = int($1 || 0);
+ $opt{SUBVERSION} = $2 || '00';
+}
+
+$opt{'cf_by'} = $ENV{USERNAME} unless $opt{'cf_by'};
+$opt{'cf_email'} = $opt{'cf_by'} . '@' . (gethostbyname('localhost'))[0]
+ unless $opt{'cf_email'};
+
+while (<>)
+ {
+ s/~([\w_]+)~/$opt{$1}/g;
+ $_ = "$1='$opt{$1}'\n" if (/^([\w_]+)=/ && exists($opt{$1}));
+ print;
+ }
+
diff --git a/gnu/usr.bin/perl/win32/dl_win32.xs b/gnu/usr.bin/perl/win32/dl_win32.xs
new file mode 100644
index 00000000000..7b227e299c9
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/dl_win32.xs
@@ -0,0 +1,112 @@
+/* dl_win32.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!)
+ */
+
+/* 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
+#include <windows.h>
+#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();
+}
+
+static int
+dl_static_linked(char *filename)
+{
+ char **p;
+ for (p = staticlinkmodules; *p;p++) {
+ if (strstr(filename, *p)) return 1;
+ };
+ return 0;
+}
+
+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));
+ if (dl_static_linked(filename) == 0)
+ RETVAL = (void*) LoadLibraryEx(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ;
+ else
+ RETVAL = (void*) GetModuleHandle(NULL);
+ DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL));
+ ST(0) = sv_newmortal() ;
+ if (RETVAL == NULL)
+ SaveError("%d",GetLastError()) ;
+ else
+ 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(*)(CV*))symref, filename)));
+
+
+char *
+dl_error()
+ CODE:
+ RETVAL = LastError ;
+ OUTPUT:
+ RETVAL
+
+# end.
diff --git a/gnu/usr.bin/perl/win32/genxsdef.pl b/gnu/usr.bin/perl/win32/genxsdef.pl
new file mode 100644
index 00000000000..b00a57e7787
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/genxsdef.pl
@@ -0,0 +1,5 @@
+print "LIBRARY $ARGV[0]\n";
+print "CODE LOADONCALL\n";
+print "DATA LOADONCALL NONSHARED MULTIPLE\n";
+print "EXPORTS\n";
+print "\tboot_$ARGV[0]\n"
diff --git a/gnu/usr.bin/perl/win32/include/arpa/inet.h b/gnu/usr.bin/perl/win32/include/arpa/inet.h
new file mode 100644
index 00000000000..0303df0876b
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/include/arpa/inet.h
@@ -0,0 +1,4 @@
+/*
+ * this is a dummy header file for Socket.xs
+ */
+
diff --git a/gnu/usr.bin/perl/win32/include/dirent.h b/gnu/usr.bin/perl/win32/include/dirent.h
new file mode 100644
index 00000000000..8cc7e11479b
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/include/dirent.h
@@ -0,0 +1,49 @@
+// dirent.h
+
+// djl
+// Provide UNIX compatibility
+
+#ifndef _INC_DIRENT
+#define _INC_DIRENT
+
+//
+// NT versions of readdir(), etc
+// From the MSDOS implementation
+//
+
+// Directory entry size
+#ifdef DIRSIZ
+#undef DIRSIZ
+#endif
+#define DIRSIZ(rp) (sizeof(struct direct))
+
+// needed to compile directory stuff
+#define DIRENT direct
+
+// structure of a directory entry
+typedef struct direct
+{
+ long d_ino; // inode number (not used by MS-DOS)
+ int d_namlen; // Name length
+ char d_name[257]; // file name
+} _DIRECT;
+
+// structure for dir operations
+typedef struct _dir_struc
+{
+ char *start; // Starting position
+ char *curr; // Current position
+ long size; // Size of string table
+ long nfiles; // number if filenames in table
+ struct direct dirstr; // Directory structure to return
+} DIR;
+
+DIR *opendir(char *filename);
+struct direct *readdir(DIR *dirp);
+long telldir(DIR *dirp);
+void seekdir(DIR *dirp,long loc);
+void rewinddir(DIR *dirp);
+int closedir(DIR *dirp);
+
+
+#endif //_INC_DIRENT
diff --git a/gnu/usr.bin/perl/win32/include/netdb.h b/gnu/usr.bin/perl/win32/include/netdb.h
new file mode 100644
index 00000000000..b0c5ea1949d
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/include/netdb.h
@@ -0,0 +1,12 @@
+// netdb.h
+
+// djl
+// Provide UNIX compatibility
+
+
+#ifndef _INC_NETDB
+#define _INC_NETDB
+
+#include <sys/socket.h>
+
+#endif //_INC_NETDB
diff --git a/gnu/usr.bin/perl/win32/include/sys/socket.h b/gnu/usr.bin/perl/win32/include/sys/socket.h
new file mode 100644
index 00000000000..9e5259b254f
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/include/sys/socket.h
@@ -0,0 +1,149 @@
+// sys/socket.h
+
+// djl
+// Provide UNIX compatibility
+
+#ifndef _INC_SYS_SOCKET
+#define _INC_SYS_SOCKET
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifndef _WINDOWS_
+#define _WINDOWS_
+
+#define FAR
+#define PASCAL __stdcall
+#define WINAPI __stdcall
+
+#undef WORD
+typedef int BOOL;
+typedef unsigned short WORD;
+typedef void* HANDLE;
+typedef void* HWND;
+typedef int (FAR WINAPI *FARPROC)();
+
+typedef unsigned long DWORD;
+typedef void *PVOID;
+
+#define IN
+#define OUT
+
+typedef struct _OVERLAPPED {
+ DWORD Internal;
+ DWORD InternalHigh;
+ DWORD Offset;
+ DWORD OffsetHigh;
+ HANDLE hEvent;
+} OVERLAPPED, *LPOVERLAPPED;
+
+#endif //_WINDOWS_
+#include <winsock.h>
+
+#define ENOTSOCK WSAENOTSOCK
+#undef HOST_NOT_FOUND
+
+
+SOCKET win32_accept (SOCKET s, struct sockaddr *addr, int *addrlen);
+int win32_bind (SOCKET s, const struct sockaddr *addr, int namelen);
+int win32_closesocket (SOCKET s);
+int win32_connect (SOCKET s, const struct sockaddr *name, int namelen);
+int win32_ioctlsocket (SOCKET s, long cmd, u_long *argp);
+int win32_getpeername (SOCKET s, struct sockaddr *name, int * namelen);
+int win32_getsockname (SOCKET s, struct sockaddr *name, int * namelen);
+int win32_getsockopt (SOCKET s, int level, int optname, char * optval, int *optlen);
+u_long win32_htonl (u_long hostlong);
+u_short win32_htons (u_short hostshort);
+unsigned long win32_inet_addr (const char * cp);
+char * win32_inet_ntoa (struct in_addr in);
+int win32_listen (SOCKET s, int backlog);
+u_long win32_ntohl (u_long netlong);
+u_short win32_ntohs (u_short netshort);
+int win32_recv (SOCKET s, char * buf, int len, int flags);
+int win32_recvfrom (SOCKET s, char * buf, int len, int flags,
+ struct sockaddr *from, int * fromlen);
+int win32_select (int nfds, int *readfds, int *writefds, int *exceptfds, const struct timeval *timeout);
+int win32_send (SOCKET s, const char * buf, int len, int flags);
+int win32_sendto (SOCKET s, const char * buf, int len, int flags,
+ const struct sockaddr *to, int tolen);
+int win32_setsockopt (SOCKET s, int level, int optname,
+ const char * optval, int optlen);
+SOCKET win32_socket (int af, int type, int protocol);
+int win32_shutdown (SOCKET s, int how);
+
+/* Database function prototypes */
+
+struct hostent * win32_gethostbyaddr(const char * addr, int len, int type);
+struct hostent * win32_gethostbyname(const char * name);
+int win32_gethostname (char * name, int namelen);
+struct servent * win32_getservbyport(int port, const char * proto);
+struct servent * win32_getservbyname(const char * name, const char * proto);
+struct protoent * win32_getprotobynumber(int proto);
+struct protoent * win32_getprotobyname(const char * name);
+struct protoent *win32_getprotoent(void);
+struct servent *win32_getservent(void);
+void win32_sethostent(int stayopen);
+void win32_setnetent(int stayopen);
+struct netent * win32_getnetent(void);
+struct netent * win32_getnetbyname(char *name);
+struct netent * win32_getnetbyaddr(long net, int type);
+void win32_setprotoent(int stayopen);
+void win32_setservent(int stayopen);
+void win32_endhostent(void);
+void win32_endnetent(void);
+void win32_endprotoent(void);
+void win32_endservent(void);
+
+//
+// direct to our version
+//
+#define htonl win32_htonl
+#define htons win32_htons
+#define ntohl win32_ntohl
+#define ntohs win32_ntohs
+#define inet_addr win32_inet_addr
+#define inet_ntoa win32_inet_ntoa
+
+#define socket win32_socket
+#define bind win32_bind
+#define listen win32_listen
+#define accept win32_accept
+#define connect win32_connect
+#define send win32_send
+#define sendto win32_sendto
+#define recv win32_recv
+#define recvfrom win32_recvfrom
+#define shutdown win32_shutdown
+#define ioctlsocket win32_ioctlsocket
+#define setsockopt win32_setsockopt
+#define getsockopt win32_getsockopt
+#define getpeername win32_getpeername
+#define getsockname win32_getsockname
+#define gethostname win32_gethostname
+#define gethostbyname win32_gethostbyname
+#define gethostbyaddr win32_gethostbyaddr
+#define getprotobyname win32_getprotobyname
+#define getprotobynumber win32_getprotobynumber
+#define getservbyname win32_getservbyname
+#define getservbyport win32_getservbyport
+#define select win32_select
+#define endhostent win32_endhostent
+#define endnetent win32_endnetent
+#define endprotoent win32_endprotoent
+#define endservent win32_endservent
+#define getnetent win32_getnetent
+#define getnetbyname win32_getnetbyname
+#define getnetbyaddr win32_getnetbyaddr
+#define getprotoent win32_getprotoent
+#define getservent win32_getservent
+#define sethostent win32_sethostent
+#define setnetent win32_setnetent
+#define setprotoent win32_setprotoent
+#define setservent win32_setservent
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif // _INC_SYS_SOCKET
diff --git a/gnu/usr.bin/perl/win32/makedef.pl b/gnu/usr.bin/perl/win32/makedef.pl
new file mode 100644
index 00000000000..b4883ccb593
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/makedef.pl
@@ -0,0 +1,347 @@
+#!../miniperl
+
+# Written: 10 April 1996 Gary Ng (71564.1743@compuserve.com)
+
+# Create the export list for perl.
+# Needed by WIN32 for creating perl.dll
+# based on perl_exp.SH in the main perl distribution directory
+
+# This simple program relys on 'global.sym' being up to date
+# with all of the global symbols that a dynamicly link library
+# might want to access.
+
+# There is some symbol defined in global.sym and interp.sym
+# that does not present in the WIN32 port but there is no easy
+# way to find them so I just put a exception list here
+
+my $CCTYPE = shift || "MSVC";
+
+$skip_sym=<<'!END!OF!SKIP!';
+Perl_SvIV
+Perl_SvNV
+Perl_SvTRUE
+Perl_SvUV
+Perl_block_type
+Perl_sv_pvn
+Perl_additem
+Perl_cast_ulong
+Perl_check_uni
+Perl_checkcomma
+Perl_chsize
+Perl_ck_aelem
+Perl_cryptseen
+Perl_cx_dump
+Perl_deb
+Perl_deb_growlevel
+Perl_debop
+Perl_debprofdump
+Perl_debstack
+Perl_debstackptrs
+Perl_do_ipcctl
+Perl_do_ipcget
+Perl_do_msgrcv
+Perl_do_msgsnd
+Perl_do_semop
+Perl_do_shmio
+Perl_doeval
+Perl_dofindlabel
+Perl_dopoptoeval
+Perl_dump_eval
+Perl_dump_fds
+Perl_dump_form
+Perl_dump_gv
+Perl_dump_mstats
+Perl_dump_op
+Perl_dump_packsubs
+Perl_dump_pm
+Perl_dump_sub
+Perl_expectterm
+Perl_fetch_gv
+Perl_fetch_io
+Perl_force_ident
+Perl_force_next
+Perl_force_word
+Perl_hv_stashpv
+Perl_intuit_more
+Perl_know_next
+Perl_modkids
+Perl_mstats
+Perl_my_bzero
+Perl_my_htonl
+Perl_my_ntohl
+Perl_my_swap
+Perl_my_chsize
+Perl_newXSUB
+Perl_no_fh_allowed
+Perl_no_op
+Perl_nointrp
+Perl_nomem
+Perl_pp_cswitch
+Perl_pp_entersubr
+Perl_pp_evalonce
+Perl_pp_interp
+Perl_pp_map
+Perl_pp_nswitch
+Perl_q
+Perl_reall_srchlen
+Perl_regdump
+Perl_regfold
+Perl_regmyendp
+Perl_regmyp_size
+Perl_regmystartp
+Perl_regnarrate
+Perl_regprop
+Perl_same_dirent
+Perl_saw_return
+Perl_scan_const
+Perl_scan_formline
+Perl_scan_heredoc
+Perl_scan_ident
+Perl_scan_inputsymbol
+Perl_scan_pat
+Perl_scan_prefix
+Perl_scan_str
+Perl_scan_subst
+Perl_scan_trans
+Perl_scan_word
+Perl_setenv_getix
+Perl_skipspace
+Perl_sublex_done
+Perl_sublex_start
+Perl_sv_peek
+Perl_sv_ref
+Perl_sv_setptrobj
+Perl_timesbuf
+Perl_too_few_arguments
+Perl_too_many_arguments
+Perl_unlnk
+Perl_wait4pid
+Perl_watch
+Perl_yyname
+Perl_yyrule
+allgvs
+curblock
+curcsv
+lastretstr
+mystack_mark
+perl_init_ext
+perl_requirepv
+stack
+statusvalue_vms
+Perl_safexcalloc
+Perl_safexmalloc
+Perl_safexfree
+Perl_safexrealloc
+Perl_my_memcmp
+Perl_my_memset
+Perl_cshlen
+Perl_cshname
+!END!OF!SKIP!
+
+# All symbols have a Perl_ prefix because that's what embed.h
+# sticks in front of them.
+
+
+print "LIBRARY Perl\n";
+print "DESCRIPTION 'Perl interpreter, export autogenerated'\n";
+print "CODE LOADONCALL\n";
+print "DATA LOADONCALL NONSHARED MULTIPLE\n";
+print "EXPORTS\n";
+
+open (GLOBAL, "<../global.sym") || die "failed to open global.sym" . $!;
+while (<GLOBAL>) {
+ my $symbol;
+ next if (!/^[A-Za-z]/);
+ next if (/_amg[ \t]*$/);
+ $symbol = "Perl_$_";
+ next if ($skip_sym =~ m/$symbol/m);
+ emit_symbol($symbol);
+}
+close(GLOBAL);
+
+# also add symbols from interp.sym
+# They are only needed if -DMULTIPLICITY is not set but it
+# doesn't hurt to include them anyway.
+# these don't have Perl prefix
+
+open (INTERP, "<../interp.sym") || die "failed to open interp.sym" . $!;
+while (<INTERP>) {
+ my $symbol;
+ next if (!/^[A-Za-z]/);
+ next if (/_amg[ \t]*$/);
+ $symbol = $_;
+ next if ($skip_sym =~ m/$symbol/m);
+ #print "\t$symbol";
+ emit_symbol("Perl_" . $symbol);
+}
+
+#close(INTERP);
+
+while (<DATA>) {
+ my $symbol;
+ next if (!/^[A-Za-z]/);
+ next if (/^#/);
+ $symbol = $_;
+ next if ($skip_sym =~ m/^$symbol/m);
+ emit_symbol($symbol);
+}
+
+sub emit_symbol {
+ my $symbol = shift;
+ chomp $symbol;
+ if ($CCTYPE eq "BORLAND") {
+ # workaround Borland quirk by exporting both the straight
+ # name and a name with leading underscore. Note the
+ # alias *must* come after the symbol itself, if both
+ # are to be exported. (Linker bug?)
+ print "\t_$symbol\n";
+ print "\t$symbol = _$symbol\n";
+ }
+ else {
+ # for binary coexistence, export both the symbol and
+ # alias with leading underscore
+ print "\t$symbol\n";
+ print "\t_$symbol = $symbol\n";
+ }
+}
+
+1;
+__DATA__
+# extra globals not included above.
+perl_init_i18nl10n
+perl_init_ext
+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_require_pv
+perl_eval_pv
+perl_eval_sv
+boot_DynaLoader
+win32_errno
+win32_environ
+win32_stdin
+win32_stdout
+win32_stderr
+win32_ferror
+win32_feof
+win32_strerror
+win32_fprintf
+win32_printf
+win32_vfprintf
+win32_vprintf
+win32_fread
+win32_fwrite
+win32_fopen
+win32_fdopen
+win32_freopen
+win32_fclose
+win32_fputs
+win32_fputc
+win32_ungetc
+win32_getc
+win32_fileno
+win32_clearerr
+win32_fflush
+win32_ftell
+win32_fseek
+win32_fgetpos
+win32_fsetpos
+win32_rewind
+win32_tmpfile
+win32_abort
+win32_fstat
+win32_stat
+win32_pipe
+win32_popen
+win32_pclose
+win32_setmode
+win32_lseek
+win32_tell
+win32_dup
+win32_dup2
+win32_open
+win32_close
+win32_eof
+win32_read
+win32_write
+win32_spawnvp
+win32_mkdir
+win32_rmdir
+win32_chdir
+win32_flock
+win32_execvp
+win32_htons
+win32_ntohs
+win32_htonl
+win32_ntohl
+win32_inet_addr
+win32_inet_ntoa
+win32_socket
+win32_bind
+win32_listen
+win32_accept
+win32_connect
+win32_send
+win32_sendto
+win32_recv
+win32_recvfrom
+win32_shutdown
+win32_ioctlsocket
+win32_setsockopt
+win32_getsockopt
+win32_getpeername
+win32_getsockname
+win32_gethostname
+win32_gethostbyname
+win32_gethostbyaddr
+win32_getprotobyname
+win32_getprotobynumber
+win32_getservbyname
+win32_getservbyport
+win32_select
+win32_endhostent
+win32_endnetent
+win32_endprotoent
+win32_endservent
+win32_getnetent
+win32_getnetbyname
+win32_getnetbyaddr
+win32_getprotoent
+win32_getservent
+win32_sethostent
+win32_setnetent
+win32_setprotoent
+win32_setservent
+win32_getenv
+win32_perror
+win32_setbuf
+win32_setvbuf
+win32_flushall
+win32_fcloseall
+win32_fgets
+win32_gets
+win32_fgetc
+win32_putc
+win32_puts
+win32_getchar
+win32_putchar
+win32_malloc
+win32_calloc
+win32_realloc
+win32_free
+win32stdio
+Perl_win32_init
+RunPerl
+SetIOSubSystem
+GetIOSubSystem
diff --git a/gnu/usr.bin/perl/win32/makefile.mk b/gnu/usr.bin/perl/win32/makefile.mk
new file mode 100644
index 00000000000..dbac98f7ffd
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/makefile.mk
@@ -0,0 +1,607 @@
+#
+# Makefile to build perl on Windowns NT using Microsoft NMAKE.
+#
+#
+# This is set up to build a perl.exe that runs off a shared library
+# (perl.dll). Also makes individual DLLs for the XS extensions.
+#
+
+#
+# Set these to wherever you want "nmake install" to put your
+# newly built perl.
+INST_DRV=c:
+INST_TOP=$(INST_DRV)\perl
+
+#
+# uncomment one if you are using Visual C++ 2.x or Borland
+# comment out both if you are using Visual C++ 4.x and above
+#CCTYPE=MSVC20
+CCTYPE=BORLAND
+
+#
+# uncomment next line if you want debug version of perl (big,slow)
+#CFG=Debug
+
+#
+# set the install locations of the compiler include/libraries
+#CCHOME = f:\msdev\vc
+CCHOME = D:\bc5
+CCINCDIR = $(CCHOME)\include
+CCLIBDIR = $(CCHOME)\lib
+
+#
+# set this to point to cmd.exe (only needed if you use some
+# alternate shell that doesn't grok cmd.exe style commands)
+SHELL = g:\winnt\system32\cmd.exe
+
+#
+# set this to your email address (perl will guess a value from
+# from your loginname and your hostname, which may not be right)
+#EMAIL =
+
+##################### CHANGE THESE ONLY IF YOU MUST #####################
+
+#
+# Programs to compile, build .lib files and link
+#
+
+.USESHELL :
+
+.IF "$(CCTYPE)" == "BORLAND"
+
+CC = bcc32
+LINK32 = tlink32
+LIB32 = tlib
+IMPLIB = implib
+
+#
+# Options
+#
+RUNTIME = -D_RTLDLL
+INCLUDES = -I.\include -I. -I.. -I$(CCINCDIR)
+#PCHFLAGS = -H -H$(INTDIR)\bcmoduls.pch
+DEFINES = -DWIN32 -DPERLDLL
+SUBSYS = console
+LIBC = cw32mti.lib
+LIBFILES = import32.lib $(LIBC) odbc32.lib odbccp32.lib
+
+WINIOMAYBE =
+
+.IF "$(CFG)" == "Debug"
+OPTIMIZE = -v $(RUNTIME)
+LINK_DBG = -v
+.ELSE
+OPTIMIZE = -O $(RUNTIME)
+LINK_DBG =
+.ENDIF
+
+CFLAGS = -w -tWM -tWD $(INCLUDES) $(DEFINES) $(PCHFLAGS) $(OPTIMIZE)
+LINK_FLAGS = $(LINK_DBG) -L$(CCLIBDIR)
+OBJOUT_FLAG = -o
+
+.ELSE
+
+CC=cl.exe
+LINK32=link.exe
+LIB32=$(LINK32) -lib
+#
+# Options
+#
+.IF "$(RUNTIME)" == ""
+RUNTIME = -MD
+.ENDIF
+INCLUDES = -I.\include -I. -I..
+#PCHFLAGS = -Fp$(INTDIR)\vcmoduls.pch -YX
+DEFINES = -DWIN32 -D_CONSOLE -DPERLDLL
+SUBSYS = console
+
+.IF "$(RUNTIME)" == "-MD"
+LIBC = msvcrt.lib
+WINIOMAYBE =
+.ELSE
+LIBC = libcmt.lib
+WINIOMAYBE = win32io.obj
+.ENDIF
+
+.IF "$(CFG)" == "Debug"
+.IF "$(CCTYPE)" == "MSVC20"
+OPTIMIZE = -Od $(RUNTIME) -Z7 -D_DEBUG
+.ELSE
+OPTIMIZE = -Od $(RUNTIME)d -Z7 -D_DEBUG
+.ENDIF
+LINK_DBG = -debug -pdb:none
+.ELSE
+.IF "$(CCTYPE)" == "MSVC20"
+OPTIMIZE = -Od $(RUNTIME) -DNDEBUG
+.ELSE
+OPTIMIZE = -Od $(RUNTIME) -DNDEBUG
+.ENDIF
+LINK_DBG = -release
+.ENDIF
+
+# we don't add LIBC here, the compiler do it based on -MD/-MT
+LIBFILES = oldnames.lib kernel32.lib user32.lib gdi32.lib \
+ winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib \
+ oleaut32.lib netapi32.lib uuid.lib wsock32.lib mpr.lib winmm.lib \
+ version.lib odbc32.lib odbccp32.lib
+
+CFLAGS = -nologo -W3 $(INCLUDES) $(DEFINES) $(PCHFLAGS) $(OPTIMIZE)
+LINK_FLAGS = -nologo $(LIBFILES) $(LINK_DBG) -machine:I386
+OBJOUT_FLAG = -Fo
+
+.ENDIF
+
+#################### do not edit below this line #######################
+############# NO USER-SERVICEABLE PARTS BEYOND THIS POINT ##############
+
+#
+# Rules
+#
+.SUFFIXES :
+.SUFFIXES : .c .obj .dll .lib .exe
+
+.c.obj:
+ $(CC) -c $(CFLAGS) $(OBJOUT_FLAG)$@ $<
+
+.IF "$(CCTYPE)" == "BORLAND"
+
+.obj.dll:
+ $(LINK32) -Tpd -ap $(LINK_FLAGS) c0d32.obj $<,$@,,$(LIBFILES),$(*B).def
+ $(IMPLIB) $(*B).lib $@
+.ELSE
+
+.obj.dll:
+ $(LINK32) -dll -subsystem:windows -implib:$(*B).lib -def:$(*B).def \
+ -out:$@ $(LINK_FLAGS) $< $(LIBPERL)
+
+.ENDIF
+
+#
+INST_BIN=$(INST_TOP)\bin
+INST_LIB=$(INST_TOP)\lib
+INST_POD=$(INST_LIB)\pod
+INST_HTML=$(INST_POD)\html
+LIBDIR=..\lib
+EXTDIR=..\ext
+PODDIR=..\pod
+EXTUTILSDIR=$(LIBDIR)\extutils
+
+#
+# various targets
+PERLIMPLIB=..\perl.lib
+MINIPERL=..\miniperl.exe
+PERLDLL=..\perl.dll
+PERLEXE=..\perl.exe
+GLOBEXE=..\perlglob.exe
+CONFIGPM=..\lib\Config.pm
+MINIMOD=..\lib\ExtUtils\Miniperl.pm
+
+PL2BAT=bin\pl2bat.pl
+GLOBBAT = bin\perlglob.bat
+
+.IF "$(CCTYPE)" == "BORLAND"
+
+# Borland wildargs is incompatible with MS setargv
+CFGSH_TMPL = config.bc
+CFGH_TMPL = config_H.bc
+# Borland's perl.exe will work on W95, so we don't make this
+
+.ELSE
+
+MAKE = nmake -nologo
+CFGSH_TMPL = config.vc
+CFGH_TMPL = config_H.vc
+PERL95EXE=..\perl95.exe
+
+.ENDIF
+
+XCOPY=xcopy /f /r /i /d
+RCOPY=xcopy /f /r /i /e /d
+#NULL=
+
+#
+# filenames given to xsubpp must have forward slashes (since it puts
+# full pathnames in #line strings)
+XSUBPP=..\$(MINIPERL) -I..\..\lib ..\$(EXTUTILSDIR)\xsubpp -C++ -prototypes
+
+CORE_C= ..\av.c \
+ ..\deb.c \
+ ..\doio.c \
+ ..\doop.c \
+ ..\dump.c \
+ ..\globals.c \
+ ..\gv.c \
+ ..\hv.c \
+ ..\mg.c \
+ ..\op.c \
+ ..\perl.c \
+ ..\perlio.c \
+ ..\perly.c \
+ ..\pp.c \
+ ..\pp_ctl.c \
+ ..\pp_hot.c \
+ ..\pp_sys.c \
+ ..\regcomp.c \
+ ..\regexec.c \
+ ..\run.c \
+ ..\scope.c \
+ ..\sv.c \
+ ..\taint.c \
+ ..\toke.c \
+ ..\universal.c \
+ ..\util.c
+
+CORE_OBJ= ..\av.obj \
+ ..\deb.obj \
+ ..\doio.obj \
+ ..\doop.obj \
+ ..\dump.obj \
+ ..\globals.obj \
+ ..\gv.obj \
+ ..\hv.obj \
+ ..\mg.obj \
+ ..\op.obj \
+ ..\perl.obj \
+ ..\perlio.obj \
+ ..\perly.obj \
+ ..\pp.obj \
+ ..\pp_ctl.obj \
+ ..\pp_hot.obj \
+ ..\pp_sys.obj \
+ ..\regcomp.obj \
+ ..\regexec.obj \
+ ..\run.obj \
+ ..\scope.obj \
+ ..\sv.obj \
+ ..\taint.obj \
+ ..\toke.obj \
+ ..\universal.obj\
+ ..\util.obj
+
+WIN32_C = perllib.c \
+ win32.c \
+ win32io.c \
+ win32sck.c
+
+WIN32_OBJ = win32.obj \
+ win32io.obj \
+ win32sck.obj
+
+PERL95_OBJ = perl95.obj \
+ win32mt.obj \
+ win32iomt.obj \
+ win32sckmt.obj
+
+DLL_OBJ = perllib.obj $(DYNALOADER).obj
+
+CORE_H = ..\av.h \
+ ..\cop.h \
+ ..\cv.h \
+ ..\dosish.h \
+ ..\embed.h \
+ ..\form.h \
+ ..\gv.h \
+ ..\handy.h \
+ ..\hv.h \
+ ..\mg.h \
+ ..\nostdio.h \
+ ..\op.h \
+ ..\opcode.h \
+ ..\perl.h \
+ ..\perlio.h \
+ ..\perlsdio.h \
+ ..\perlsfio.h \
+ ..\perly.h \
+ ..\pp.h \
+ ..\proto.h \
+ ..\regexp.h \
+ ..\scope.h \
+ ..\sv.h \
+ ..\unixish.h \
+ ..\util.h \
+ ..\XSUB.h \
+ .\config.h \
+ ..\EXTERN.h \
+ .\include\dirent.h \
+ .\include\netdb.h \
+ .\include\sys\socket.h \
+ .\win32.h
+
+
+EXTENSIONS=DynaLoader Socket IO Fcntl Opcode SDBM_File
+
+DYNALOADER=$(EXTDIR)\DynaLoader\DynaLoader
+SOCKET=$(EXTDIR)\Socket\Socket
+FCNTL=$(EXTDIR)\Fcntl\Fcntl
+OPCODE=$(EXTDIR)\Opcode\Opcode
+SDBM_FILE=$(EXTDIR)\SDBM_File\SDBM_File
+IO=$(EXTDIR)\IO\IO
+
+SOCKET_DLL=..\lib\auto\Socket\Socket.dll
+FCNTL_DLL=..\lib\auto\Fcntl\Fcntl.dll
+OPCODE_DLL=..\lib\auto\Opcode\Opcode.dll
+SDBM_FILE_DLL=..\lib\auto\SDBM_File\SDBM_File.dll
+IO_DLL=..\lib\auto\IO\IO.dll
+
+STATICLINKMODULES=DynaLoader
+DYNALOADMODULES= \
+ $(SOCKET_DLL) \
+ $(FCNTL_DLL) \
+ $(OPCODE_DLL) \
+ $(SDBM_FILE_DLL)\
+ $(IO_DLL)
+
+POD2HTML=$(PODDIR)\pod2html
+POD2MAN=$(PODDIR)\pod2man
+POD2LATEX=$(PODDIR)\pod2latex
+POD2TEXT=$(PODDIR)\pod2text
+
+#
+# Top targets
+#
+
+all: $(PERLEXE) $(PERL95EXE) $(GLOBEXE) $(DYNALOADMODULES) $(MINIMOD) $(GLOBBAT)
+
+$(DYNALOADER).obj : $(DYNALOADER).c $(CORE_H) $(EXTDIR)\DynaLoader\dlutils.c
+
+#------------------------------------------------------------
+
+$(GLOBEXE): perlglob.obj
+.IF "$(CCTYPE)" == "BORLAND"
+ $(CC) -c -w -v -tWM -I$(CCINCDIR) perlglob.c
+ $(LINK32) -Tpe -ap $(LINK_FLAGS) c0x32.obj perlglob.obj \
+ $(CCLIBDIR)\32BIT\wildargs.obj,$@,,import32.lib cw32mt.lib,
+.ELSE
+ $(LINK32) $(LINK_FLAGS) -out:$@ -subsystem:$(SUBSYS) perlglob.obj setargv.obj
+.ENDIF
+
+$(GLOBBAT) : ..\lib\File\DosGlob.pm $(MINIPERL)
+ $(MINIPERL) $(PL2BAT) - < ..\lib\File\DosGlob.pm > $(GLOBBAT)
+
+perlglob.obj : perlglob.c
+
+..\miniperlmain.obj : ..\miniperlmain.c $(CORE_H)
+
+config.w32 : $(CFGSH_TMPL)
+ copy $(CFGSH_TMPL) config.w32
+
+.\config.h : $(CFGSH_TMPL)
+ -del /f config.h
+ copy $(CFGH_TMPL) config.h
+
+..\config.sh : config.w32 $(MINIPERL) config_sh.PL
+ $(MINIPERL) -I..\lib config_sh.PL "INST_DRV=$(INST_DRV)" \
+ "INST_TOP=$(INST_TOP)" "cc=$(CC)" "ccflags=$(RUNTIME) -DWIN32" \
+ "cf_email=$(EMAIL)" "libs=$(LIBFILES:f)" "incpath=$(CCINCDIR)" \
+ "libpth=$(strip $(CCLIBDIR) $(LIBFILES:d))" "libc=$(LIBC)" \
+ config.w32 > ..\config.sh
+
+$(CONFIGPM) : $(MINIPERL) ..\config.sh config_h.PL ..\minimod.pl
+ cd .. && miniperl configpm
+ if exist lib\* $(RCOPY) lib\*.* ..\lib\$(NULL)
+ $(XCOPY) ..\*.h ..\lib\CORE\*.*
+ $(XCOPY) *.h ..\lib\CORE\*.*
+ $(RCOPY) include ..\lib\CORE\*.*
+ $(MINIPERL) -I..\lib config_h.PL || $(MAKE) CCTYPE=$(CCTYPE) \
+ RUNTIME=$(RUNTIME) CFG=$(CFG) $(CONFIGPM)
+
+$(MINIPERL) : ..\miniperlmain.obj $(CORE_OBJ) $(WIN32_OBJ)
+.IF "$(CCTYPE)" == "BORLAND"
+ $(LINK32) -Tpe -ap $(LINK_FLAGS) \
+ @$(mktmp c0x32.obj ..\miniperlmain.obj \
+ $(CORE_OBJ:s,\,\\) $(WIN32_OBJ:s,\,\\),$@,,$(LIBFILES),)
+.ELSE
+ $(LINK32) -subsystem:console -out:$@ \
+ @$(mktmp $(LINK_FLAGS) ..\miniperlmain.obj \
+ $(CORE_OBJ:s,\,\\) $(WIN32_OBJ:s,\,\\))
+.ENDIF
+
+$(WIN32_OBJ) : $(CORE_H)
+$(CORE_OBJ) : $(CORE_H)
+$(DLL_OBJ) : $(CORE_H)
+
+perldll.def : $(MINIPERL) $(CONFIGPM)
+ $(MINIPERL) -w makedef.pl $(CCTYPE) > perldll.def
+
+$(PERLDLL): perldll.def $(CORE_OBJ) $(WIN32_OBJ) $(DLL_OBJ)
+.IF "$(CCTYPE)" == "BORLAND"
+ $(LINK32) -Tpd -ap $(LINK_FLAGS) \
+ @$(mktmp c0d32.obj $(CORE_OBJ:s,\,\\) \
+ $(WIN32_OBJ:s,\,\\) $(DLL_OBJ:s,\,\\)\n \
+ $@,\n \
+ $(LIBFILES)\n \
+ perldll.def\n)
+ $(IMPLIB) $*.lib $@
+.ELSE
+ $(LINK32) -dll -def:perldll.def -out:$@ \
+ @$(mktmp $(LINK_FLAGS) $(CORE_OBJ:s,\,\\) \
+ $(WIN32_OBJ:s,\,\\) $(DLL_OBJ:s,\,\\))
+.ENDIF
+ $(XCOPY) $(PERLIMPLIB) ..\lib\CORE
+
+perl.def : $(MINIPERL) makeperldef.pl
+ $(MINIPERL) -I..\lib makeperldef.pl $(NULL) > perl.def
+
+$(MINIMOD) : $(MINIPERL) ..\minimod.pl
+ cd .. && miniperl minimod.pl > lib\ExtUtils\Miniperl.pm
+
+perlmain.c : runperl.c
+ copy runperl.c perlmain.c
+
+perlmain.obj : perlmain.c
+ $(CC) $(CFLAGS) -UPERLDLL -c perlmain.c
+
+
+$(PERLEXE): $(PERLDLL) $(CONFIGPM) perlmain.obj
+.IF "$(CCTYPE)" == "BORLAND"
+ $(LINK32) -Tpe -ap $(LINK_FLAGS) \
+ @$(mktmp c0x32.obj perlmain.obj $(WINIOMAYBE)\n \
+ $@,\n \
+ $(PERLIMPLIB) $(LIBFILES)\n)
+.ELSE
+ $(LINK32) -subsystem:console -out:perl.exe $(LINK_FLAGS) \
+ perlmain.obj $(WINIOMAYBE) $(PERLIMPLIB)
+ copy perl.exe $@
+ del perl.exe
+.ENDIF
+ copy splittree.pl ..
+ $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto"
+ attrib -r ..\t\*.*
+ copy test ..\t
+
+.IF "$(CCTYPE)" != "BORLAND"
+
+perl95.c : runperl.c
+ copy runperl.c perl95.c
+
+perl95.obj : perl95.c
+ $(CC) $(CFLAGS) -MT -UPERLDLL -c perl95.c
+
+win32iomt.obj : win32io.c
+ $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32iomt.obj win32io.c
+
+win32sckmt.obj : win32sck.c
+ $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32sckmt.obj win32sck.c
+
+win32mt.obj : win32.c
+ $(CC) $(CFLAGS) -MT -c $(OBJOUT_FLAG)win32mt.obj win32.c
+
+$(PERL95EXE): $(PERLDLL) $(CONFIGPM) $(PERL95_OBJ)
+ $(LINK32) -subsystem:console -out:perl95.exe $(LINK_FLAGS) \
+ $(PERL95_OBJ) $(PERLIMPLIB)
+ copy perl95.exe $@
+ del perl95.exe
+
+.ENDIF
+
+$(DYNALOADER).c: $(MINIPERL) $(EXTDIR)\DynaLoader\dl_win32.xs $(CONFIGPM)
+ if not exist ..\lib\auto mkdir ..\lib\auto
+ $(XCOPY) $(EXTDIR)\$(*B)\$(*B).pm $(LIBDIR)\$(NULL)
+ cd $(EXTDIR)\$(*B) && $(XSUBPP) dl_win32.xs > $(*B).c
+ $(XCOPY) $(EXTDIR)\$(*B)\dlutils.c .
+
+$(EXTDIR)\DynaLoader\dl_win32.xs: dl_win32.xs
+ copy dl_win32.xs $(EXTDIR)\DynaLoader\dl_win32.xs
+
+$(IO_DLL): $(PERLEXE) $(CONFIGPM) $(IO).xs
+ cd $(EXTDIR)\$(*B) && \
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ cd $(EXTDIR)\$(*B) && $(MAKE)
+
+$(SDBM_FILE_DLL) : $(PERLEXE) $(SDBM_FILE).xs
+ cd $(EXTDIR)\$(*B) && \
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ cd $(EXTDIR)\$(*B) && $(MAKE)
+
+$(FCNTL_DLL): $(PERLEXE) $(FCNTL).xs
+ cd $(EXTDIR)\$(*B) && \
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ cd $(EXTDIR)\$(*B) && $(MAKE)
+
+$(OPCODE_DLL): $(PERLEXE) $(OPCODE).xs
+ cd $(EXTDIR)\$(*B) && \
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ cd $(EXTDIR)\$(*B) && $(MAKE)
+
+$(SOCKET_DLL): $(SOCKET).xs $(PERLEXE)
+ cd $(EXTDIR)\$(*B) && \
+ ..\..\miniperl -I..\..\lib Makefile.PL INSTALLDIRS=perl
+ cd $(EXTDIR)\$(*B) && $(MAKE)
+
+doc: $(PERLEXE)
+ cd ..\pod && $(MAKE) -f ..\win32\pod.mak checkpods \
+ pod2html pod2latex pod2man pod2text
+ cd ..\pod && $(XCOPY) *.bat ..\win32\bin\*.*
+ copy ..\README.win32 ..\pod\perlwin32.pod
+ $(PERLEXE) ..\installhtml --podroot=.. --htmldir=./html \
+ --podpath=pod:lib:ext:utils --htmlroot="//$(INST_HTML:s,:,|,)" \
+ --libpod=perlfunc:perlguts:perlvar:perlrun:perlop --recurse
+
+utils: $(PERLEXE)
+ cd ..\utils && $(MAKE) PERL=$(MINIPERL)
+ cd ..\utils && $(PERLEXE) ..\win32\$(PL2BAT) h2ph splain perlbug \
+ pl2pm c2ph h2xs perldoc pstruct
+ $(XCOPY) ..\utils\*.bat bin\*.*
+ $(PERLEXE) $(PL2BAT) bin\network.pl bin\www.pl bin\runperl.pl \
+ bin\pl2bat.pl
+
+distclean: clean
+ -del /f $(MINIPERL) $(PERLEXE) $(PERLDLL) $(GLOBEXE) \
+ $(PERLIMPLIB) ..\miniperl.lib $(MINIMOD)
+ -del /f *.def *.map
+ -del /f $(SOCKET_DLL) $(IO_DLL) $(SDBM_FILE_DLL) $(FCNTL_DLL) \
+ $(OPCODE_DLL)
+ -del /f $(SOCKET).c $(IO).c $(SDBM_FILE).c $(FCNTL).c $(OPCODE).c \
+ $(DYNALOADER).c
+ -del /f $(PODDIR)\*.html
+ -del /f $(PODDIR)\*.bat
+ -del /f ..\config.sh ..\splittree.pl perlmain.c dlutils.c config.h.new
+.IF "$(PERL95EXE)" != ""
+ -del /f perl95.c
+.ENDIF
+ -del /f bin\*.bat
+ -cd $(EXTDIR) && del /s *.lib *.def *.map *.bs Makefile *.obj pm_to_blib
+ -rmdir /s /q ..\lib\auto
+ -rmdir /s /q ..\lib\CORE
+
+install : all doc utils
+ if not exist $(INST_TOP) mkdir $(INST_TOP)
+ echo I $(INST_TOP) L $(LIBDIR)
+ $(XCOPY) $(PERLEXE) $(INST_BIN)\*.*
+.IF "$(PERL95EXE)" != ""
+ $(XCOPY) $(PERL95EXE) $(INST_BIN)\*.*
+.ENDIF
+ $(XCOPY) $(GLOBEXE) $(INST_BIN)\*.*
+ $(XCOPY) $(PERLDLL) $(INST_BIN)\*.*
+ $(XCOPY) bin\*.bat $(INST_BIN)\*.*
+ $(RCOPY) ..\lib $(INST_LIB)\*.*
+ $(XCOPY) ..\pod\*.bat $(INST_BIN)\*.*
+ $(XCOPY) ..\pod\*.pod $(INST_POD)\*.*
+ $(RCOPY) html\*.* $(INST_HTML)\*.*
+
+inst_lib : $(CONFIGPM)
+ copy splittree.pl ..
+ $(MINIPERL) -I..\lib ..\splittree.pl "../LIB" "../LIB/auto"
+ $(RCOPY) ..\lib $(INST_LIB)\*.*
+
+minitest : $(MINIPERL) $(GLOBEXE) $(CONFIGPM)
+ $(XCOPY) $(MINIPERL) ..\t\perl.exe
+.IF "$(CCTYPE)" == "BORLAND"
+ $(XCOPY) $(GLOBBAT) ..\t\$(NULL)
+.ELSE
+ $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
+.ENDIF
+ attrib -r ..\t\*.*
+ copy test ..\t
+ cd ..\t && \
+ $(MINIPERL) -I..\lib test base/*.t comp/*.t cmd/*.t io/*.t op/*.t pragma/*.t
+
+test : all
+ $(XCOPY) $(PERLEXE) ..\t\$(NULL)
+ $(XCOPY) $(PERLDLL) ..\t\$(NULL)
+.IF "$(CCTYPE)" == "BORLAND"
+ $(XCOPY) $(GLOBBAT) ..\t\$(NULL)
+.ELSE
+ $(XCOPY) $(GLOBEXE) ..\t\$(NULL)
+.ENDIF
+ cd ..\t && $(PERLEXE) -I..\lib harness
+
+clean :
+ -@erase miniperlmain.obj
+ -@erase $(MINIPERL)
+ -@erase perlglob.obj
+ -@erase perlmain.obj
+ -@erase config.w32
+ -@erase /f config.h
+ -@erase $(GLOBEXE)
+ -@erase $(PERLEXE)
+ -@erase $(PERLDLL)
+ -@erase $(CORE_OBJ)
+ -@erase $(WIN32_OBJ)
+ -@erase $(DLL_OBJ)
+ -@erase ..\*.obj ..\*.lib ..\*.exp *.obj *.lib *.exp
+ -@erase ..\t\*.exe ..\t\*.dll ..\t\*.bat
+ -@erase *.ilk
+ -@erase *.pdb
+
+
diff --git a/gnu/usr.bin/perl/win32/makemain.pl b/gnu/usr.bin/perl/win32/makemain.pl
new file mode 100644
index 00000000000..740b6a212a0
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/makemain.pl
@@ -0,0 +1,45 @@
+open (MINIMAIN, "<../miniperlmain.c") || die "failed to open miniperlmain.c" . $!;
+
+while (<MINIMAIN>) {
+ if (/Do not delete this line--writemain depends on it/) {
+ last;
+ }
+ else {
+ print $_;
+ }
+ };
+
+close(MINIMAIN);
+
+print "char *staticlinkmodules[]={\n";
+foreach (@ARGV) {
+ print "\t\"".$_."\",\n";
+ }
+print "\tNULL,\n";
+print "\t};\n";
+print "\n";
+foreach (@ARGV) {
+ print "EXTERN_C void boot_$_ _((CV* cv));\n"
+ }
+
+print <<EOP;
+
+static void
+xs_init()
+{
+ dXSUB_SYS;
+ char *file = __FILE__;
+EOP
+
+foreach (@ARGV) {
+ if (/DynaLoader/) {
+ print "\tnewXS(\"$_\:\:boot_$_\", boot_$_, file);\n";
+ }
+ else {
+ print "\tnewXS(\"$_\:\:bootstrap\", boot_$_, file);\n";
+ };
+ }
+
+print <<EOP;
+}
+EOP
diff --git a/gnu/usr.bin/perl/win32/makeperldef.pl b/gnu/usr.bin/perl/win32/makeperldef.pl
new file mode 100644
index 00000000000..620d2ebab30
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/makeperldef.pl
@@ -0,0 +1,23 @@
+my $CCTYPE = "";
+print "EXPORTS\n";
+foreach (@ARGV) {
+ if (/CCTYPE=(.*)$/) {
+ $CCTYPE = $1;
+ next;
+ }
+ emit_symbol("boot_$_");
+}
+
+sub emit_symbol {
+ my $symbol = shift;
+ if ($CCTYPE eq "BORLAND") {
+ # workaround Borland quirk by export both the straight
+ # name and a name with leading underscore
+ print "\t$symbol=_$symbol\n";
+ print "\t_$symbol\n";
+ }
+ else {
+ print "\t$symbol\n";
+ }
+}
+
diff --git a/gnu/usr.bin/perl/win32/perlglob.c b/gnu/usr.bin/perl/win32/perlglob.c
new file mode 100644
index 00000000000..b2fdca2f71e
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/perlglob.c
@@ -0,0 +1,42 @@
+/*
+ * Globbing for NT. Relies on the expansion done by the library
+ * startup code.
+ */
+
+#include <stdio.h>
+#include <io.h>
+#include <fcntl.h>
+#include <string.h>
+#include <windows.h>
+
+int
+main(int argc, char *argv[])
+{
+ int i;
+ int len;
+ char root[MAX_PATH];
+ char *dummy;
+ char volname[MAX_PATH];
+ DWORD serial, maxname, flags;
+ BOOL downcase = TRUE;
+
+ /* check out the file system characteristics */
+ if (GetFullPathName(".", MAX_PATH, root, &dummy)) {
+ if (dummy = strchr(root, '\\'))
+ *++dummy = '\0';
+ if (GetVolumeInformation(root, volname, MAX_PATH,
+ &serial, &maxname, &flags, 0, 0)) {
+ downcase = !(flags & FS_CASE_IS_PRESERVED);
+ }
+ }
+
+ setmode(fileno(stdout), O_BINARY);
+ for (i = 1; i < argc; i++) {
+ len = strlen(argv[i]);
+ if (downcase)
+ strlwr(argv[i]);
+ if (i > 1) fwrite("\0", sizeof(char), 1, stdout);
+ fwrite(argv[i], sizeof(char), len, stdout);
+ }
+ return 0;
+}
diff --git a/gnu/usr.bin/perl/win32/perllib.c b/gnu/usr.bin/perl/win32/perllib.c
new file mode 100644
index 00000000000..391b4d375f0
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/perllib.c
@@ -0,0 +1,113 @@
+/*
+ * "The Road goes ever on and on, down from the door where it began."
+ */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef __cplusplus
+}
+# define EXTERN_C extern "C"
+#else
+# define EXTERN_C extern
+#endif
+
+static void xs_init _((void));
+
+__declspec(dllexport) int
+RunPerl(int argc, char **argv, char **env, void *iosubsystem)
+{
+ int exitstatus;
+ PerlInterpreter *my_perl;
+ void *pOldIOSubsystem;
+
+ pOldIOSubsystem = SetIOSubSystem(iosubsystem);
+
+ PERL_SYS_INIT(&argc,&argv);
+
+ perl_init_i18nl10n(1);
+
+ if (!(my_perl = perl_alloc()))
+ return (1);
+ perl_construct( my_perl );
+ perl_destruct_level = 0;
+
+ exitstatus = perl_parse( my_perl, xs_init, argc, argv, env);
+ if (!exitstatus) {
+ exitstatus = perl_run( my_perl );
+ }
+
+ perl_destruct( my_perl );
+ perl_free( my_perl );
+
+ PERL_SYS_TERM();
+
+ SetIOSubSystem(pOldIOSubsystem);
+
+ return (exitstatus);
+}
+
+extern HANDLE PerlDllHandle;
+
+BOOL APIENTRY
+DllMain(HANDLE hModule, /* DLL module handle */
+ DWORD fdwReason, /* reason called */
+ LPVOID lpvReserved) /* reserved */
+{
+ switch (fdwReason) {
+ /* The DLL is attaching to a process due to process
+ * initialization or a call to LoadLibrary.
+ */
+ case DLL_PROCESS_ATTACH:
+/* #define DEFAULT_BINMODE */
+#ifdef DEFAULT_BINMODE
+ setmode( fileno( stdin ), O_BINARY );
+ setmode( fileno( stdout ), O_BINARY );
+ setmode( fileno( stderr ), O_BINARY );
+ _fmode = O_BINARY;
+#endif
+ PerlDllHandle = hModule;
+ break;
+
+ /* The DLL is detaching from a process due to
+ * process termination or call to FreeLibrary.
+ */
+ case DLL_PROCESS_DETACH:
+ break;
+
+ /* The attached process creates a new thread. */
+ case DLL_THREAD_ATTACH:
+ break;
+
+ /* The thread of the attached process terminates. */
+ case DLL_THREAD_DETACH:
+ break;
+
+ default:
+ break;
+ }
+ return TRUE;
+}
+
+/* Register any extra external extensions */
+
+char *staticlinkmodules[] = {
+ "DynaLoader",
+ NULL,
+};
+
+EXTERN_C void boot_DynaLoader _((CV* cv));
+
+static void
+xs_init()
+{
+ char *file = __FILE__;
+ dXSUB_SYS;
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+}
+
diff --git a/gnu/usr.bin/perl/win32/pod.mak b/gnu/usr.bin/perl/win32/pod.mak
new file mode 100644
index 00000000000..9881ed882d6
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/pod.mak
@@ -0,0 +1,272 @@
+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) html
+
+PERL = ..\miniperl.exe
+PL2BAT = ..\win32\bin\pl2bat.pl
+
+POD = \
+ perl.pod \
+ perldelta.pod \
+ perldata.pod \
+ perlsyn.pod \
+ perlop.pod \
+ perlre.pod \
+ perlrun.pod \
+ perlfunc.pod \
+ perlvar.pod \
+ perlsub.pod \
+ perlmod.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 \
+ 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 \
+ 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 \
+ 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 \
+ 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 \
+ 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 \
+ 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 \
+ 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:
+ $(PERL) -I..\lib pod2man $*.pm >$*.man
+
+.pod.man:
+ $(PERL) -I..\lib pod2man $*.pod >$*.man
+
+.SUFFIXES: .html
+
+.pm.html:
+ $(PERL) -I..\lib $(POD2HTML) --infile=$*.pm --outfile=$*.html
+
+.pod.html:
+ $(PERL) -I..\lib $(POD2HTML) --infile=$*.pod --outfile=$*.html
+
+.SUFFIXES: .tex
+
+.pm.tex:
+ $(PERL) -I..\lib pod2latex $*.pm
+
+.pod.tex:
+ $(PERL) -I..\lib pod2latex $*.pod
+
+clean:
+ del /f $(MAN) $(HTML) $(TEX)
+ del /f pod2html-*cache
+ del /f *.aux *.log
+
+realclean: clean
+ del /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
+ $(PERL) $(PL2BAT) pod2latex
+
+pod2html: pod2html.PL ..\lib\Config.pm
+ $(PERL) -I..\lib pod2html.PL
+ $(PERL) $(PL2BAT) pod2html
+
+pod2man: pod2man.PL ..\lib\Config.pm
+ $(PERL) -I..\lib pod2man.PL
+ $(PERL) $(PL2BAT) pod2man
+
+pod2text: pod2text.PL ..\lib\Config.pm
+ $(PERL) -I..\lib pod2text.PL
+ $(PERL) $(PL2BAT) pod2text
+
+checkpods: checkpods.PL ..\lib\Config.pm
+ $(PERL) -I..\lib checkpods.PL
+ $(PERL) $(PL2BAT) checkpods
+
+
diff --git a/gnu/usr.bin/perl/win32/runperl.c b/gnu/usr.bin/perl/win32/runperl.c
new file mode 100644
index 00000000000..07e2bd6f835
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/runperl.c
@@ -0,0 +1,18 @@
+#include <stdio.h>
+#include <win32io.h>
+
+#ifndef _DLL
+extern WIN32_IOSUBSYSTEM win32stdio;
+#endif
+
+extern int RunPerl(int argc, char **argv, char **env, void *iosubsystem);
+
+int
+main(int argc, char **argv, char **env)
+{
+#ifdef _DLL
+ return (RunPerl(argc, argv, env, NULL));
+#else
+ return (RunPerl(argc, argv, env, &win32stdio));
+#endif
+}
diff --git a/gnu/usr.bin/perl/win32/splittree.pl b/gnu/usr.bin/perl/win32/splittree.pl
new file mode 100644
index 00000000000..3c76daadb1c
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/splittree.pl
@@ -0,0 +1,24 @@
+use DirHandle;
+use AutoSplit;
+
+sub splitthis {
+my ($top,$base,$dest) = @_;
+my $d = new DirHandle $base;
+if (defined $d) {
+ while (defined($_ = $d->read)) {
+ next if $_ eq ".";
+ next if $_ eq "..";
+ my $entry = "$base\\$_";
+ my $entrywithouttop = $entry;
+ $entrywithouttop =~ s/^$top//;
+ if (-d $entry) {splitthis ($top,$entry,$dest);}
+ else {
+ next unless ($entry=~/pm$/i);
+ #print "Will run autosplit on $entry to $dest\n";
+ autosplit($entry,$dest,0,1,1);
+ };
+ };
+ };
+}
+
+splitthis $ARGV[0],$ARGV[0],$ARGV[1];
diff --git a/gnu/usr.bin/perl/win32/win32.c b/gnu/usr.bin/perl/win32/win32.c
new file mode 100644
index 00000000000..7cbfae8a83d
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/win32.c
@@ -0,0 +1,1639 @@
+/* WIN32.C
+ *
+ * (c) 1995 Microsoft Corporation. All rights reserved.
+ * Developed by hip communications inc., http://info.hip.com/info/
+ * Portions (c) 1993 Intergraph Corporation. All rights reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ */
+
+#define WIN32_LEAN_AND_MEAN
+#define WIN32IO_IS_STDIO
+#include <tchar.h>
+#include <windows.h>
+
+/* #include "config.h" */
+
+#define PERLIO_NOT_STDIO 0
+#if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
+#define PerlIO FILE
+#endif
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+#include <fcntl.h>
+#include <sys/stat.h>
+#include <assert.h>
+#include <string.h>
+#include <stdarg.h>
+#include <float.h>
+
+#define CROAK croak
+#define WARN warn
+
+#define EXECF_EXEC 1
+#define EXECF_SPAWN 2
+#define EXECF_SPAWN_NOWAIT 3
+
+static DWORD IdOS(void);
+
+extern WIN32_IOSUBSYSTEM win32stdio;
+static PWIN32_IOSUBSYSTEM pIOSubSystem = &win32stdio;
+
+BOOL ProbeEnv = FALSE;
+DWORD Win32System = (DWORD)-1;
+char szShellPath[MAX_PATH+1];
+char szPerlLibRoot[MAX_PATH+1];
+HANDLE PerlDllHandle = INVALID_HANDLE_VALUE;
+
+static int do_spawn2(char *cmd, int exectype);
+
+int
+IsWin95(void) {
+ return (IdOS() == VER_PLATFORM_WIN32_WINDOWS);
+}
+
+int
+IsWinNT(void) {
+ return (IdOS() == VER_PLATFORM_WIN32_NT);
+}
+
+DllExport PWIN32_IOSUBSYSTEM
+SetIOSubSystem(void *p)
+{
+ PWIN32_IOSUBSYSTEM old = pIOSubSystem;
+ if (p) {
+ PWIN32_IOSUBSYSTEM pio = (PWIN32_IOSUBSYSTEM)p;
+ if (pio->signature_begin == 12345678L
+ && pio->signature_end == 87654321L) {
+ pIOSubSystem = pio;
+ }
+ }
+ else {
+ pIOSubSystem = &win32stdio;
+ }
+ return old;
+}
+
+DllExport PWIN32_IOSUBSYSTEM
+GetIOSubSystem(void)
+{
+ return pIOSubSystem;
+}
+
+char *
+win32PerlLibPath(void)
+{
+ char *end;
+ GetModuleFileName((PerlDllHandle == INVALID_HANDLE_VALUE)
+ ? GetModuleHandle(NULL)
+ : PerlDllHandle,
+ szPerlLibRoot,
+ sizeof(szPerlLibRoot));
+
+ *(end = strrchr(szPerlLibRoot, '\\')) = '\0';
+ if (stricmp(end-4,"\\bin") == 0)
+ end -= 4;
+ strcpy(end,"\\lib");
+ return (szPerlLibRoot);
+}
+
+char *
+win32SiteLibPath(void)
+{
+ static char szPerlSiteLib[MAX_PATH+1];
+ strcpy(szPerlSiteLib, win32PerlLibPath());
+ strcat(szPerlSiteLib, "\\site");
+ return (szPerlSiteLib);
+}
+
+BOOL
+HasRedirection(char *ptr)
+{
+ int inquote = 0;
+ char quote = '\0';
+
+ /*
+ * Scan string looking for redirection (< or >) or pipe
+ * characters (|) that are not in a quoted string
+ */
+ while(*ptr) {
+ switch(*ptr) {
+ case '\'':
+ case '\"':
+ if(inquote) {
+ if(quote == *ptr) {
+ inquote = 0;
+ quote = '\0';
+ }
+ }
+ else {
+ quote = *ptr;
+ inquote++;
+ }
+ break;
+ case '>':
+ case '<':
+ case '|':
+ if(!inquote)
+ return TRUE;
+ default:
+ break;
+ }
+ ++ptr;
+ }
+ return FALSE;
+}
+
+/* since the current process environment is being updated in util.c
+ * the library functions will get the correct environment
+ */
+PerlIO *
+my_popen(char *cmd, char *mode)
+{
+#ifdef FIXCMD
+#define fixcmd(x) { \
+ char *pspace = strchr((x),' '); \
+ if (pspace) { \
+ char *p = (x); \
+ while (p < pspace) { \
+ if (*p == '/') \
+ *p = '\\'; \
+ p++; \
+ } \
+ } \
+ }
+#else
+#define fixcmd(x)
+#endif
+
+#if 1
+/* was #ifndef PERLDLL, but the #else stuff doesn't work on NT
+ * GSAR 97/03/13
+ */
+ fixcmd(cmd);
+#ifdef __BORLANDC__ /* workaround a Borland stdio bug */
+ win32_fflush(stdout);
+ win32_fflush(stderr);
+#endif
+ return win32_popen(cmd, mode);
+#else
+/*
+ * There seems to be some problems for the _popen call in a DLL
+ * this trick at the moment seems to work but it is never test
+ * on NT yet
+ *
+ */
+# ifdef __cplusplus
+#define EXT_C_FUNC extern "C"
+# else
+#define EXT_C_FUNC extern
+# endif
+
+ EXT_C_FUNC int __cdecl _set_osfhnd(int fh, long value);
+ EXT_C_FUNC void __cdecl _lock_fhandle(int);
+ EXT_C_FUNC void __cdecl _unlock_fhandle(int);
+
+ BOOL fSuccess;
+ PerlIO *pf; /* to store the _popen return value */
+ int tm = 0; /* flag indicating tDllExport or binary mode */
+ int fhNeeded, fhInherited, fhDup;
+ int ineeded, iinherited;
+ DWORD dwDup;
+ int phdls[2]; /* I/O handles for pipe */
+ HANDLE hPIn, hPOut, hPErr,
+ hSaveStdin, hSaveStdout, hSaveStderr,
+ hPNeeded, hPInherited, hPDuped;
+
+ /* first check for errors in the arguments */
+ if ( (cmd == NULL) || (mode == NULL)
+ || ((*mode != 'w') && (*mode != _T('r'))) )
+ goto error1;
+
+ if ( *(mode + 1) == _T('t') )
+ tm = O_TEXT;
+ else if ( *(mode + 1) == _T('b') )
+ tm = O_BINARY;
+ else
+ tm = (*mode == 'w' ? O_BINARY : O_TEXT);
+
+
+ fixcmd(cmd);
+ if (&win32stdio != pIOSubSystem)
+ return win32_popen(cmd, mode);
+
+#ifdef EFG
+ if ( _pipe( phdls, 1024, tm ) == -1 )
+#else
+ if ( win32_pipe( phdls, 1024, tm ) == -1 )
+#endif
+ goto error1;
+
+ /* save the current situation */
+ hSaveStdin = GetStdHandle(STD_INPUT_HANDLE);
+ hSaveStdout = GetStdHandle(STD_OUTPUT_HANDLE);
+ hSaveStderr = GetStdHandle(STD_ERROR_HANDLE);
+
+ if (*mode == _T('w')) {
+ ineeded = 1;
+ dwDup = STD_INPUT_HANDLE;
+ iinherited = 0;
+ }
+ else {
+ ineeded = 0;
+ dwDup = STD_OUTPUT_HANDLE;
+ iinherited = 1;
+ }
+
+ fhNeeded = phdls[ineeded];
+ fhInherited = phdls[iinherited];
+
+ fSuccess = DuplicateHandle(GetCurrentProcess(),
+ (HANDLE) stolen_get_osfhandle(fhNeeded),
+ GetCurrentProcess(),
+ &hPNeeded,
+ 0,
+ FALSE, /* not inherited */
+ DUPLICATE_SAME_ACCESS);
+
+ if (!fSuccess)
+ goto error2;
+
+ fhDup = stolen_open_osfhandle((long) hPNeeded, tm);
+ win32_dup2(fhDup, fhNeeded);
+ win32_close(fhDup);
+
+#ifdef AAA
+ /* Close the Out pipe, child won't need it */
+ hPDuped = (HANDLE) stolen_get_osfhandle(fhNeeded);
+
+ _lock_fhandle(fhNeeded);
+ _set_osfhnd(fhNeeded, (long)hPNeeded); /* put in ours duplicated one */
+ _unlock_fhandle(fhNeeded);
+
+ CloseHandle(hPDuped); /* close the handle first */
+#endif
+
+ if (!SetStdHandle(dwDup, (HANDLE) stolen_get_osfhandle(fhInherited)))
+ goto error2;
+
+ /*
+ * make sure the child see the same stderr as the calling program
+ */
+ if (!SetStdHandle(STD_ERROR_HANDLE,
+ (HANDLE)stolen_get_osfhandle(win32_fileno(win32_stderr()))))
+ goto error2;
+
+ pf = win32_popen(cmd, mode); /* ask _popen to do the job */
+
+ /* restore to where we were */
+ SetStdHandle(STD_INPUT_HANDLE, hSaveStdin);
+ SetStdHandle(STD_OUTPUT_HANDLE, hSaveStdout);
+ SetStdHandle(STD_ERROR_HANDLE, hSaveStderr);
+
+ /* we don't need it any more, that's for the child */
+ win32_close(fhInherited);
+
+ if (NULL == pf) {
+ /* something wrong */
+ win32_close(fhNeeded);
+ goto error1;
+ }
+ else {
+ /*
+ * here we steal the file handle in pf and stuff ours in
+ */
+ win32_dup2(fhNeeded, win32_fileno(pf));
+ win32_close(fhNeeded);
+ }
+ return (pf);
+
+error2:
+ win32_close(fhNeeded);
+ win32_close(fhInherited);
+
+error1:
+ return (NULL);
+
+#endif
+}
+
+long
+my_pclose(PerlIO *fp)
+{
+ return win32_pclose(fp);
+}
+
+static DWORD
+IdOS(void)
+{
+ static OSVERSIONINFO osver;
+
+ if (osver.dwPlatformId != Win32System) {
+ memset(&osver, 0, sizeof(OSVERSIONINFO));
+ osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+ GetVersionEx(&osver);
+ Win32System = osver.dwPlatformId;
+ }
+ return (Win32System);
+}
+
+static char *
+GetShell(void)
+{
+ if (!ProbeEnv) {
+ char* defaultshell = (IsWinNT() ? "cmd.exe" : "command.com");
+ /* we don't use COMSPEC here for two reasons:
+ * 1. the same reason perl on UNIX doesn't use SHELL--rampant and
+ * uncontrolled unportability of the ensuing scripts.
+ * 2. PERL5SHELL could be set to a shell that may not be fit for
+ * interactive use (which is what most programs look in COMSPEC
+ * for).
+ */
+ char *usershell = getenv("PERL5SHELL");
+
+ ProbeEnv = TRUE;
+ strcpy(szShellPath, usershell ? usershell : defaultshell);
+ }
+ return szShellPath;
+}
+
+int
+do_aspawn(void* really, void** mark, void** arglast)
+{
+ char **argv;
+ char *strPtr;
+ char *cmd;
+ int status;
+ unsigned int length;
+ int index = 0;
+ SV *sv = (SV*)really;
+ SV** pSv = (SV**)mark;
+
+ New(1310, argv, (arglast - mark) + 4, char*);
+
+ if(sv != Nullsv) {
+ cmd = SvPV(sv, length);
+ }
+ else {
+ argv[index++] = cmd = GetShell();
+ if (IsWinNT())
+ argv[index++] = "/x"; /* always enable command extensions */
+ argv[index++] = "/c";
+ }
+
+ while(++pSv <= (SV**)arglast) {
+ sv = *pSv;
+ strPtr = SvPV(sv, length);
+ if(strPtr != NULL && *strPtr != '\0')
+ argv[index++] = strPtr;
+ }
+ argv[index++] = 0;
+
+ status = win32_spawnvp(P_WAIT, cmd, (const char* const*)argv);
+
+ Safefree(argv);
+
+ if (status < 0) {
+ if (dowarn)
+ warn("Can't spawn \"%s\": %s", cmd, strerror(errno));
+ status = 255 << 8;
+ }
+ return (status);
+}
+
+int
+do_spawn2(char *cmd, int exectype)
+{
+ char **a;
+ char *s;
+ char **argv;
+ int status = -1;
+ BOOL needToTry = TRUE;
+ char *shell, *cmd2;
+
+ /* save an extra exec if possible */
+ shell = GetShell();
+
+ /* see if there are shell metacharacters in it */
+ if(!HasRedirection(cmd)) {
+ New(1301,argv, strlen(cmd) / 2 + 2, char*);
+ New(1302,cmd2, strlen(cmd) + 1, char);
+ strcpy(cmd2, cmd);
+ a = argv;
+ for (s = cmd2; *s;) {
+ while (*s && isspace(*s))
+ s++;
+ if (*s)
+ *(a++) = s;
+ while(*s && !isspace(*s))
+ s++;
+ if(*s)
+ *s++ = '\0';
+ }
+ *a = Nullch;
+ if(argv[0]) {
+ switch (exectype) {
+ case EXECF_SPAWN:
+ status = win32_spawnvp(P_WAIT, argv[0],
+ (const char* const*)argv);
+ break;
+ case EXECF_SPAWN_NOWAIT:
+ status = win32_spawnvp(P_NOWAIT, argv[0],
+ (const char* const*)argv);
+ break;
+ case EXECF_EXEC:
+ status = win32_execvp(argv[0], (const char* const*)argv);
+ break;
+ }
+ if(status != -1 || errno == 0)
+ needToTry = FALSE;
+ }
+ Safefree(argv);
+ Safefree(cmd2);
+ }
+ if(needToTry) {
+ char *argv[5];
+ int i = 0;
+ argv[i++] = shell;
+ if (IsWinNT())
+ argv[i++] = "/x";
+ argv[i++] = "/c"; argv[i++] = cmd; argv[i] = Nullch;
+ switch (exectype) {
+ case EXECF_SPAWN:
+ status = win32_spawnvp(P_WAIT, argv[0],
+ (const char* const*)argv);
+ break;
+ case EXECF_SPAWN_NOWAIT:
+ status = win32_spawnvp(P_NOWAIT, argv[0],
+ (const char* const*)argv);
+ break;
+ case EXECF_EXEC:
+ status = win32_execvp(argv[0], (const char* const*)argv);
+ break;
+ }
+ }
+ if (status < 0) {
+ if (dowarn)
+ warn("Can't %s \"%s\": %s",
+ (exectype == EXECF_EXEC ? "exec" : "spawn"),
+ needToTry ? shell : argv[0],
+ strerror(errno));
+ status = 255 << 8;
+ }
+ return (status);
+}
+
+int
+do_spawn(char *cmd)
+{
+ return do_spawn2(cmd, EXECF_SPAWN);
+}
+
+bool
+do_exec(char *cmd)
+{
+ do_spawn2(cmd, EXECF_EXEC);
+ return FALSE;
+}
+
+
+#define PATHLEN 1024
+
+/* The idea here is to read all the directory names into a string table
+ * (separated by nulls) and when one of the other dir functions is called
+ * return the pointer to the current file name.
+ */
+DIR *
+opendir(char *filename)
+{
+ DIR *p;
+ long len;
+ long idx;
+ char scannamespc[PATHLEN];
+ char *scanname = scannamespc;
+ struct stat sbuf;
+ WIN32_FIND_DATA FindData;
+ HANDLE fh;
+/* char root[_MAX_PATH];*/
+/* char volname[_MAX_PATH];*/
+/* DWORD serial, maxname, flags;*/
+/* BOOL downcase;*/
+/* char *dummy;*/
+
+ /* check to see if filename is a directory */
+ if (win32_stat(filename, &sbuf) < 0 || sbuf.st_mode & S_IFDIR == 0) {
+ return NULL;
+ }
+
+ /* get the file system characteristics */
+/* if(GetFullPathName(filename, MAX_PATH, root, &dummy)) {
+ * if(dummy = strchr(root, '\\'))
+ * *++dummy = '\0';
+ * if(GetVolumeInformation(root, volname, MAX_PATH, &serial,
+ * &maxname, &flags, 0, 0)) {
+ * downcase = !(flags & FS_CASE_IS_PRESERVED);
+ * }
+ * }
+ * else {
+ * downcase = TRUE;
+ * }
+ */
+ /* Get us a DIR structure */
+ Newz(1303, p, 1, DIR);
+ if(p == NULL)
+ return NULL;
+
+ /* Create the search pattern */
+ strcpy(scanname, filename);
+
+ if(index("/\\", *(scanname + strlen(scanname) - 1)) == NULL)
+ strcat(scanname, "/*");
+ else
+ strcat(scanname, "*");
+
+ /* do the FindFirstFile call */
+ fh = FindFirstFile(scanname, &FindData);
+ if(fh == INVALID_HANDLE_VALUE) {
+ return NULL;
+ }
+
+ /* now allocate the first part of the string table for
+ * the filenames that we find.
+ */
+ idx = strlen(FindData.cFileName)+1;
+ New(1304, p->start, idx, char);
+ if(p->start == NULL) {
+ CROAK("opendir: malloc failed!\n");
+ }
+ strcpy(p->start, FindData.cFileName);
+/* if(downcase)
+ * strlwr(p->start);
+ */
+ p->nfiles++;
+
+ /* loop finding all the files that match the wildcard
+ * (which should be all of them in this directory!).
+ * the variable idx should point one past the null terminator
+ * of the previous string found.
+ */
+ while (FindNextFile(fh, &FindData)) {
+ len = strlen(FindData.cFileName);
+ /* bump the string table size by enough for the
+ * new name and it's null terminator
+ */
+ Renew(p->start, idx+len+1, char);
+ if(p->start == NULL) {
+ CROAK("opendir: malloc failed!\n");
+ }
+ strcpy(&p->start[idx], FindData.cFileName);
+/* if (downcase)
+ * strlwr(&p->start[idx]);
+ */
+ p->nfiles++;
+ idx += len+1;
+ }
+ FindClose(fh);
+ p->size = idx;
+ p->curr = p->start;
+ return p;
+}
+
+
+/* Readdir just returns the current string pointer and bumps the
+ * string pointer to the nDllExport entry.
+ */
+struct direct *
+readdir(DIR *dirp)
+{
+ int len;
+ static int dummy = 0;
+
+ if (dirp->curr) {
+ /* first set up the structure to return */
+ len = strlen(dirp->curr);
+ strcpy(dirp->dirstr.d_name, dirp->curr);
+ dirp->dirstr.d_namlen = len;
+
+ /* Fake an inode */
+ dirp->dirstr.d_ino = dummy++;
+
+ /* Now set up for the nDllExport call to readdir */
+ dirp->curr += len + 1;
+ if (dirp->curr >= (dirp->start + dirp->size)) {
+ dirp->curr = NULL;
+ }
+
+ return &(dirp->dirstr);
+ }
+ else
+ return NULL;
+}
+
+/* Telldir returns the current string pointer position */
+long
+telldir(DIR *dirp)
+{
+ return (long) dirp->curr;
+}
+
+
+/* Seekdir moves the string pointer to a previously saved position
+ *(Saved by telldir).
+ */
+void
+seekdir(DIR *dirp, long loc)
+{
+ dirp->curr = (char *)loc;
+}
+
+/* Rewinddir resets the string pointer to the start */
+void
+rewinddir(DIR *dirp)
+{
+ dirp->curr = dirp->start;
+}
+
+/* free the memory allocated by opendir */
+int
+closedir(DIR *dirp)
+{
+ Safefree(dirp->start);
+ Safefree(dirp);
+ return 1;
+}
+
+
+/*
+ * various stubs
+ */
+
+
+/* Ownership
+ *
+ * Just pretend that everyone is a superuser. NT will let us know if
+ * we don\'t really have permission to do something.
+ */
+
+#define ROOT_UID ((uid_t)0)
+#define ROOT_GID ((gid_t)0)
+
+uid_t
+getuid(void)
+{
+ return ROOT_UID;
+}
+
+uid_t
+geteuid(void)
+{
+ return ROOT_UID;
+}
+
+gid_t
+getgid(void)
+{
+ return ROOT_GID;
+}
+
+gid_t
+getegid(void)
+{
+ return ROOT_GID;
+}
+
+int
+setuid(uid_t uid)
+{
+ return (uid == ROOT_UID ? 0 : -1);
+}
+
+int
+setgid(gid_t gid)
+{
+ return (gid == ROOT_GID ? 0 : -1);
+}
+
+/*
+ * pretended kill
+ */
+int
+kill(int pid, int sig)
+{
+ HANDLE hProcess= OpenProcess(PROCESS_ALL_ACCESS, TRUE, pid);
+
+ if (hProcess == NULL) {
+ CROAK("kill process failed!\n");
+ }
+ else {
+ if (!TerminateProcess(hProcess, sig))
+ CROAK("kill process failed!\n");
+ CloseHandle(hProcess);
+ }
+ return 0;
+}
+
+/*
+ * File system stuff
+ */
+
+#if 0
+int
+ioctl(int i, unsigned int u, char *data)
+{
+ CROAK("ioctl not implemented!\n");
+ return -1;
+}
+#endif
+
+unsigned int
+sleep(unsigned int t)
+{
+ Sleep(t*1000);
+ return 0;
+}
+
+
+#undef rename
+
+int
+myrename(char *OldFileName, char *newname)
+{
+ if(_access(newname, 0) != -1) { /* file exists */
+ _unlink(newname);
+ }
+ return rename(OldFileName, newname);
+}
+
+
+DllExport int
+win32_stat(const char *path, struct stat *buffer)
+{
+ char t[MAX_PATH];
+ const char *p = path;
+ int l = strlen(path);
+ int res;
+
+ if (l > 1) {
+ switch(path[l - 1]) {
+ case '\\':
+ case '/':
+ if (path[l - 2] != ':') {
+ strncpy(t, path, l - 1);
+ t[l - 1] = 0;
+ p = t;
+ };
+ }
+ }
+ res = pIOSubSystem->pfnstat(p,buffer);
+#ifdef __BORLANDC__
+ if (res == 0) {
+ if (S_ISDIR(buffer->st_mode))
+ buffer->st_mode |= S_IWRITE | S_IEXEC;
+ else if (S_ISREG(buffer->st_mode)) {
+ if (l >= 4 && path[l-4] == '.') {
+ const char *e = path + l - 3;
+ if (strnicmp(e,"exe",3)
+ && strnicmp(e,"bat",3)
+ && strnicmp(e,"com",3)
+ && (IsWin95() || strnicmp(e,"cmd",3)))
+ buffer->st_mode &= ~S_IEXEC;
+ else
+ buffer->st_mode |= S_IEXEC;
+ }
+ else
+ buffer->st_mode &= ~S_IEXEC;
+ }
+ }
+#endif
+ return res;
+}
+
+#ifndef USE_WIN32_RTL_ENV
+
+DllExport char *
+win32_getenv(const char *name)
+{
+ static char *curitem = Nullch;
+ static DWORD curlen = 512;
+ DWORD needlen;
+ if (!curitem)
+ New(1305,curitem,curlen,char);
+ if (!(needlen = GetEnvironmentVariable(name,curitem,curlen)))
+ return Nullch;
+ while (needlen > curlen) {
+ Renew(curitem,needlen,char);
+ curlen = needlen;
+ needlen = GetEnvironmentVariable(name,curitem,curlen);
+ }
+ return curitem;
+}
+
+#endif
+
+#undef times
+int
+mytimes(struct tms *timebuf)
+{
+ clock_t t = clock();
+ timebuf->tms_utime = t;
+ timebuf->tms_stime = 0;
+ timebuf->tms_cutime = 0;
+ timebuf->tms_cstime = 0;
+
+ return 0;
+}
+
+#undef alarm
+unsigned int
+myalarm(unsigned int sec)
+{
+ /* we warn the usuage of alarm function */
+ if (sec != 0)
+ WARN("dummy function alarm called, program might not function as expected\n");
+ return 0;
+}
+
+/*
+ * redirected io subsystem for all XS modules
+ *
+ */
+
+DllExport int *
+win32_errno(void)
+{
+ return (pIOSubSystem->pfnerrno());
+}
+
+DllExport char ***
+win32_environ(void)
+{
+ return (pIOSubSystem->pfnenviron());
+}
+
+/* the rest are the remapped stdio routines */
+DllExport FILE *
+win32_stderr(void)
+{
+ return (pIOSubSystem->pfnstderr());
+}
+
+DllExport FILE *
+win32_stdin(void)
+{
+ return (pIOSubSystem->pfnstdin());
+}
+
+DllExport FILE *
+win32_stdout()
+{
+ return (pIOSubSystem->pfnstdout());
+}
+
+DllExport int
+win32_ferror(FILE *fp)
+{
+ return (pIOSubSystem->pfnferror(fp));
+}
+
+
+DllExport int
+win32_feof(FILE *fp)
+{
+ return (pIOSubSystem->pfnfeof(fp));
+}
+
+/*
+ * Since the errors returned by the socket error function
+ * WSAGetLastError() are not known by the library routine strerror
+ * we have to roll our own.
+ */
+
+__declspec(thread) char strerror_buffer[512];
+
+DllExport char *
+win32_strerror(int e)
+{
+#ifndef __BORLANDC__ /* Borland intolerance */
+ extern int sys_nerr;
+#endif
+ DWORD source = 0;
+
+ if(e < 0 || e > sys_nerr) {
+ if(e < 0)
+ e = GetLastError();
+
+ if(FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, &source, e, 0,
+ strerror_buffer, sizeof(strerror_buffer), NULL) == 0)
+ strcpy(strerror_buffer, "Unknown Error");
+
+ return strerror_buffer;
+ }
+ return pIOSubSystem->pfnstrerror(e);
+}
+
+DllExport int
+win32_fprintf(FILE *fp, const char *format, ...)
+{
+ va_list marker;
+ va_start(marker, format); /* Initialize variable arguments. */
+
+ return (pIOSubSystem->pfnvfprintf(fp, format, marker));
+}
+
+DllExport int
+win32_printf(const char *format, ...)
+{
+ va_list marker;
+ va_start(marker, format); /* Initialize variable arguments. */
+
+ return (pIOSubSystem->pfnvprintf(format, marker));
+}
+
+DllExport int
+win32_vfprintf(FILE *fp, const char *format, va_list args)
+{
+ return (pIOSubSystem->pfnvfprintf(fp, format, args));
+}
+
+DllExport int
+win32_vprintf(const char *format, va_list args)
+{
+ return (pIOSubSystem->pfnvprintf(format, args));
+}
+
+DllExport size_t
+win32_fread(void *buf, size_t size, size_t count, FILE *fp)
+{
+ return pIOSubSystem->pfnfread(buf, size, count, fp);
+}
+
+DllExport size_t
+win32_fwrite(const void *buf, size_t size, size_t count, FILE *fp)
+{
+ return pIOSubSystem->pfnfwrite(buf, size, count, fp);
+}
+
+DllExport FILE *
+win32_fopen(const char *filename, const char *mode)
+{
+ if (stricmp(filename, "/dev/null")==0)
+ return pIOSubSystem->pfnfopen("NUL", mode);
+ return pIOSubSystem->pfnfopen(filename, mode);
+}
+
+DllExport FILE *
+win32_fdopen( int handle, const char *mode)
+{
+ return pIOSubSystem->pfnfdopen(handle, mode);
+}
+
+DllExport FILE *
+win32_freopen( const char *path, const char *mode, FILE *stream)
+{
+ if (stricmp(path, "/dev/null")==0)
+ return pIOSubSystem->pfnfreopen("NUL", mode, stream);
+ return pIOSubSystem->pfnfreopen(path, mode, stream);
+}
+
+DllExport int
+win32_fclose(FILE *pf)
+{
+ return pIOSubSystem->pfnfclose(pf);
+}
+
+DllExport int
+win32_fputs(const char *s,FILE *pf)
+{
+ return pIOSubSystem->pfnfputs(s, pf);
+}
+
+DllExport int
+win32_fputc(int c,FILE *pf)
+{
+ return pIOSubSystem->pfnfputc(c,pf);
+}
+
+DllExport int
+win32_ungetc(int c,FILE *pf)
+{
+ return pIOSubSystem->pfnungetc(c,pf);
+}
+
+DllExport int
+win32_getc(FILE *pf)
+{
+ return pIOSubSystem->pfngetc(pf);
+}
+
+DllExport int
+win32_fileno(FILE *pf)
+{
+ return pIOSubSystem->pfnfileno(pf);
+}
+
+DllExport void
+win32_clearerr(FILE *pf)
+{
+ pIOSubSystem->pfnclearerr(pf);
+ return;
+}
+
+DllExport int
+win32_fflush(FILE *pf)
+{
+ return pIOSubSystem->pfnfflush(pf);
+}
+
+DllExport long
+win32_ftell(FILE *pf)
+{
+ return pIOSubSystem->pfnftell(pf);
+}
+
+DllExport int
+win32_fseek(FILE *pf,long offset,int origin)
+{
+ return pIOSubSystem->pfnfseek(pf, offset, origin);
+}
+
+DllExport int
+win32_fgetpos(FILE *pf,fpos_t *p)
+{
+ return pIOSubSystem->pfnfgetpos(pf, p);
+}
+
+DllExport int
+win32_fsetpos(FILE *pf,const fpos_t *p)
+{
+ return pIOSubSystem->pfnfsetpos(pf, p);
+}
+
+DllExport void
+win32_rewind(FILE *pf)
+{
+ pIOSubSystem->pfnrewind(pf);
+ return;
+}
+
+DllExport FILE*
+win32_tmpfile(void)
+{
+ return pIOSubSystem->pfntmpfile();
+}
+
+DllExport void
+win32_abort(void)
+{
+ pIOSubSystem->pfnabort();
+ return;
+}
+
+DllExport int
+win32_fstat(int fd,struct stat *bufptr)
+{
+ return pIOSubSystem->pfnfstat(fd,bufptr);
+}
+
+DllExport int
+win32_pipe(int *pfd, unsigned int size, int mode)
+{
+ return pIOSubSystem->pfnpipe(pfd, size, mode);
+}
+
+DllExport FILE*
+win32_popen(const char *command, const char *mode)
+{
+ return pIOSubSystem->pfnpopen(command, mode);
+}
+
+DllExport int
+win32_pclose(FILE *pf)
+{
+ return pIOSubSystem->pfnpclose(pf);
+}
+
+DllExport int
+win32_setmode(int fd, int mode)
+{
+ return pIOSubSystem->pfnsetmode(fd, mode);
+}
+
+DllExport long
+win32_lseek(int fd, long offset, int origin)
+{
+ return pIOSubSystem->pfnlseek(fd, offset, origin);
+}
+
+DllExport long
+win32_tell(int fd)
+{
+ return pIOSubSystem->pfntell(fd);
+}
+
+DllExport int
+win32_open(const char *path, int flag, ...)
+{
+ va_list ap;
+ int pmode;
+
+ va_start(ap, flag);
+ pmode = va_arg(ap, int);
+ va_end(ap);
+
+ if (stricmp(path, "/dev/null")==0)
+ return pIOSubSystem->pfnopen("NUL", flag, pmode);
+ return pIOSubSystem->pfnopen(path,flag,pmode);
+}
+
+DllExport int
+win32_close(int fd)
+{
+ return pIOSubSystem->pfnclose(fd);
+}
+
+DllExport int
+win32_eof(int fd)
+{
+ return pIOSubSystem->pfneof(fd);
+}
+
+DllExport int
+win32_dup(int fd)
+{
+ return pIOSubSystem->pfndup(fd);
+}
+
+DllExport int
+win32_dup2(int fd1,int fd2)
+{
+ return pIOSubSystem->pfndup2(fd1,fd2);
+}
+
+DllExport int
+win32_read(int fd, void *buf, unsigned int cnt)
+{
+ return pIOSubSystem->pfnread(fd, buf, cnt);
+}
+
+DllExport int
+win32_write(int fd, const void *buf, unsigned int cnt)
+{
+ return pIOSubSystem->pfnwrite(fd, buf, cnt);
+}
+
+DllExport int
+win32_mkdir(const char *dir, int mode)
+{
+ return pIOSubSystem->pfnmkdir(dir); /* just ignore mode */
+}
+
+DllExport int
+win32_rmdir(const char *dir)
+{
+ return pIOSubSystem->pfnrmdir(dir);
+}
+
+DllExport int
+win32_chdir(const char *dir)
+{
+ return pIOSubSystem->pfnchdir(dir);
+}
+
+DllExport int
+win32_spawnvp(int mode, const char *cmdname, const char *const *argv)
+{
+ return pIOSubSystem->pfnspawnvp(mode, cmdname, argv);
+}
+
+DllExport int
+win32_execvp(const char *cmdname, const char *const *argv)
+{
+ return pIOSubSystem->pfnexecvp(cmdname, argv);
+}
+
+DllExport void
+win32_perror(const char *str)
+{
+ pIOSubSystem->pfnperror(str);
+}
+
+DllExport void
+win32_setbuf(FILE *pf, char *buf)
+{
+ pIOSubSystem->pfnsetbuf(pf, buf);
+}
+
+DllExport int
+win32_setvbuf(FILE *pf, char *buf, int type, size_t size)
+{
+ return pIOSubSystem->pfnsetvbuf(pf, buf, type, size);
+}
+
+DllExport int
+win32_flushall(void)
+{
+ return pIOSubSystem->pfnflushall();
+}
+
+DllExport int
+win32_fcloseall(void)
+{
+ return pIOSubSystem->pfnfcloseall();
+}
+
+DllExport char*
+win32_fgets(char *s, int n, FILE *pf)
+{
+ return pIOSubSystem->pfnfgets(s, n, pf);
+}
+
+DllExport char*
+win32_gets(char *s)
+{
+ return pIOSubSystem->pfngets(s);
+}
+
+DllExport int
+win32_fgetc(FILE *pf)
+{
+ return pIOSubSystem->pfnfgetc(pf);
+}
+
+DllExport int
+win32_putc(int c, FILE *pf)
+{
+ return pIOSubSystem->pfnputc(c,pf);
+}
+
+DllExport int
+win32_puts(const char *s)
+{
+ return pIOSubSystem->pfnputs(s);
+}
+
+DllExport int
+win32_getchar(void)
+{
+ return pIOSubSystem->pfngetchar();
+}
+
+DllExport int
+win32_putchar(int c)
+{
+ return pIOSubSystem->pfnputchar(c);
+}
+
+DllExport void*
+win32_malloc(size_t size)
+{
+ return pIOSubSystem->pfnmalloc(size);
+}
+
+DllExport void*
+win32_calloc(size_t numitems, size_t size)
+{
+ return pIOSubSystem->pfncalloc(numitems,size);
+}
+
+DllExport void*
+win32_realloc(void *block, size_t size)
+{
+ return pIOSubSystem->pfnrealloc(block,size);
+}
+
+DllExport void
+win32_free(void *block)
+{
+ pIOSubSystem->pfnfree(block);
+}
+
+int
+stolen_open_osfhandle(long handle, int flags)
+{
+ return pIOSubSystem->pfn_open_osfhandle(handle, flags);
+}
+
+long
+stolen_get_osfhandle(int fd)
+{
+ return pIOSubSystem->pfn_get_osfhandle(fd);
+}
+
+/*
+ * Extras.
+ */
+
+DllExport int
+win32_flock(int fd, int oper)
+{
+ if (!IsWinNT()) {
+ croak("flock() unimplemented on this platform");
+ return -1;
+ }
+ return pIOSubSystem->pfnflock(fd, oper);
+}
+
+static
+XS(w32_GetCwd)
+{
+ dXSARGS;
+ SV *sv = sv_newmortal();
+ /* Make one call with zero size - return value is required size */
+ DWORD len = GetCurrentDirectory((DWORD)0,NULL);
+ SvUPGRADE(sv,SVt_PV);
+ SvGROW(sv,len);
+ SvCUR(sv) = GetCurrentDirectory((DWORD) SvLEN(sv), SvPVX(sv));
+ /*
+ * If result != 0
+ * then it worked, set PV valid,
+ * else leave it 'undef'
+ */
+ if (SvCUR(sv))
+ SvPOK_on(sv);
+ EXTEND(sp,1);
+ ST(0) = sv;
+ XSRETURN(1);
+}
+
+static
+XS(w32_SetCwd)
+{
+ dXSARGS;
+ if (items != 1)
+ croak("usage: Win32::SetCurrentDirectory($cwd)");
+ if (SetCurrentDirectory(SvPV(ST(0),na)))
+ XSRETURN_YES;
+
+ XSRETURN_NO;
+}
+
+static
+XS(w32_GetNextAvailDrive)
+{
+ dXSARGS;
+ char ix = 'C';
+ char root[] = "_:\\";
+ while (ix <= 'Z') {
+ root[0] = ix++;
+ if (GetDriveType(root) == 1) {
+ root[2] = '\0';
+ XSRETURN_PV(root);
+ }
+ }
+ XSRETURN_UNDEF;
+}
+
+static
+XS(w32_GetLastError)
+{
+ dXSARGS;
+ XSRETURN_IV(GetLastError());
+}
+
+static
+XS(w32_LoginName)
+{
+ dXSARGS;
+ char name[256];
+ DWORD size = sizeof(name);
+ if (GetUserName(name,&size)) {
+ /* size includes NULL */
+ ST(0) = sv_2mortal(newSVpv(name,size-1));
+ XSRETURN(1);
+ }
+ XSRETURN_UNDEF;
+}
+
+static
+XS(w32_NodeName)
+{
+ dXSARGS;
+ char name[MAX_COMPUTERNAME_LENGTH+1];
+ DWORD size = sizeof(name);
+ if (GetComputerName(name,&size)) {
+ /* size does NOT include NULL :-( */
+ ST(0) = sv_2mortal(newSVpv(name,size));
+ XSRETURN(1);
+ }
+ XSRETURN_UNDEF;
+}
+
+
+static
+XS(w32_DomainName)
+{
+ dXSARGS;
+ char name[256];
+ DWORD size = sizeof(name);
+ if (GetUserName(name,&size)) {
+ char sid[1024];
+ DWORD sidlen = sizeof(sid);
+ char dname[256];
+ DWORD dnamelen = sizeof(dname);
+ SID_NAME_USE snu;
+ if (LookupAccountName(NULL, name, &sid, &sidlen,
+ dname, &dnamelen, &snu)) {
+ XSRETURN_PV(dname); /* all that for this */
+ }
+ }
+ XSRETURN_UNDEF;
+}
+
+static
+XS(w32_FsType)
+{
+ dXSARGS;
+ char fsname[256];
+ DWORD flags, filecomplen;
+ if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen,
+ &flags, fsname, sizeof(fsname))) {
+ if (GIMME == G_ARRAY) {
+ XPUSHs(sv_2mortal(newSVpv(fsname,0)));
+ XPUSHs(sv_2mortal(newSViv(flags)));
+ XPUSHs(sv_2mortal(newSViv(filecomplen)));
+ PUTBACK;
+ return;
+ }
+ XSRETURN_PV(fsname);
+ }
+ XSRETURN_UNDEF;
+}
+
+static
+XS(w32_GetOSVersion)
+{
+ dXSARGS;
+ OSVERSIONINFO osver;
+
+ osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+ if (GetVersionEx(&osver)) {
+ XPUSHs(newSVpv(osver.szCSDVersion, 0));
+ XPUSHs(newSViv(osver.dwMajorVersion));
+ XPUSHs(newSViv(osver.dwMinorVersion));
+ XPUSHs(newSViv(osver.dwBuildNumber));
+ XPUSHs(newSViv(osver.dwPlatformId));
+ PUTBACK;
+ return;
+ }
+ XSRETURN_UNDEF;
+}
+
+static
+XS(w32_IsWinNT)
+{
+ dXSARGS;
+ XSRETURN_IV(IsWinNT());
+}
+
+static
+XS(w32_IsWin95)
+{
+ dXSARGS;
+ XSRETURN_IV(IsWin95());
+}
+
+static
+XS(w32_FormatMessage)
+{
+ dXSARGS;
+ DWORD source = 0;
+ char msgbuf[1024];
+
+ if (items != 1)
+ croak("usage: Win32::FormatMessage($errno)");
+
+ if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM,
+ &source, SvIV(ST(0)), 0,
+ msgbuf, sizeof(msgbuf)-1, NULL))
+ XSRETURN_PV(msgbuf);
+
+ XSRETURN_UNDEF;
+}
+
+static
+XS(w32_Spawn)
+{
+ dXSARGS;
+ char *cmd, *args;
+ PROCESS_INFORMATION stProcInfo;
+ STARTUPINFO stStartInfo;
+ BOOL bSuccess = FALSE;
+
+ if(items != 3)
+ croak("usage: Win32::Spawn($cmdName, $args, $PID)");
+
+ cmd = SvPV(ST(0),na);
+ args = SvPV(ST(1), na);
+
+ memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */
+ stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */
+ stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */
+ stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */
+
+ if(CreateProcess(
+ cmd, /* Image path */
+ args, /* Arguments for command line */
+ NULL, /* Default process security */
+ NULL, /* Default thread security */
+ FALSE, /* Must be TRUE to use std handles */
+ NORMAL_PRIORITY_CLASS, /* No special scheduling */
+ NULL, /* Inherit our environment block */
+ NULL, /* Inherit our currrent directory */
+ &stStartInfo, /* -> Startup info */
+ &stProcInfo)) /* <- Process info (if OK) */
+ {
+ CloseHandle(stProcInfo.hThread);/* library source code does this. */
+ sv_setiv(ST(2), stProcInfo.dwProcessId);
+ bSuccess = TRUE;
+ }
+ XSRETURN_IV(bSuccess);
+}
+
+static
+XS(w32_GetTickCount)
+{
+ dXSARGS;
+ XSRETURN_IV(GetTickCount());
+}
+
+static
+XS(w32_GetShortPathName)
+{
+ dXSARGS;
+ SV *shortpath;
+ DWORD len;
+
+ if(items != 1)
+ croak("usage: Win32::GetShortPathName($longPathName)");
+
+ shortpath = sv_mortalcopy(ST(0));
+ SvUPGRADE(shortpath, SVt_PV);
+ /* src == target is allowed */
+ do {
+ len = GetShortPathName(SvPVX(shortpath),
+ SvPVX(shortpath),
+ SvLEN(shortpath));
+ } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1));
+ if (len) {
+ SvCUR_set(shortpath,len);
+ ST(0) = shortpath;
+ }
+ else
+ ST(0) = &sv_undef;
+ XSRETURN(1);
+}
+
+void
+init_os_extras()
+{
+ char *file = __FILE__;
+ dXSUB_SYS;
+
+ /* XXX should be removed after checking with Nick */
+ newXS("Win32::GetCurrentDirectory", w32_GetCwd, file);
+
+ /* these names are Activeware compatible */
+ newXS("Win32::GetCwd", w32_GetCwd, file);
+ newXS("Win32::SetCwd", w32_SetCwd, file);
+ newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file);
+ newXS("Win32::GetLastError", w32_GetLastError, file);
+ newXS("Win32::LoginName", w32_LoginName, file);
+ newXS("Win32::NodeName", w32_NodeName, file);
+ newXS("Win32::DomainName", w32_DomainName, file);
+ newXS("Win32::FsType", w32_FsType, file);
+ newXS("Win32::GetOSVersion", w32_GetOSVersion, file);
+ newXS("Win32::IsWinNT", w32_IsWinNT, file);
+ newXS("Win32::IsWin95", w32_IsWin95, file);
+ newXS("Win32::FormatMessage", w32_FormatMessage, file);
+ newXS("Win32::Spawn", w32_Spawn, file);
+ newXS("Win32::GetTickCount", w32_GetTickCount, file);
+ newXS("Win32::GetShortPathName", w32_GetShortPathName, file);
+
+ /* XXX Bloat Alert! The following Activeware preloads really
+ * ought to be part of Win32::Sys::*, so they're not included
+ * here.
+ */
+ /* LookupAccountName
+ * LookupAccountSID
+ * InitiateSystemShutdown
+ * AbortSystemShutdown
+ * ExpandEnvrironmentStrings
+ */
+}
+
+void
+Perl_win32_init(int *argcp, char ***argvp)
+{
+ /* Disable floating point errors, Perl will trap the ones we
+ * care about. VC++ RTL defaults to switching these off
+ * already, but the Borland RTL doesn't. Since we don't
+ * want to be at the vendor's whim on the default, we set
+ * it explicitly here.
+ */
+#if !defined(_ALPHA_)
+ _control87(MCW_EM, MCW_EM);
+#endif
+}
diff --git a/gnu/usr.bin/perl/win32/win32.h b/gnu/usr.bin/perl/win32/win32.h
new file mode 100644
index 00000000000..dc069ba366c
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/win32.h
@@ -0,0 +1,154 @@
+/* WIN32.H
+ *
+ * (c) 1995 Microsoft Corporation. All rights reserved.
+ * Developed by hip communications inc., http://info.hip.com/info/
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ */
+#ifndef _INC_WIN32_PERL5
+#define _INC_WIN32_PERL5
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+
+#ifdef WIN32_LEAN_AND_MEAN /* C file is NOT a Perl5 original. */
+#define CONTEXT PERL_CONTEXT /* Avoid conflict of CONTEXT defs. */
+#define index strchr /* Why 'index'? */
+#endif /*WIN32_LEAN_AND_MEAN */
+
+#include <dirent.h>
+#include <io.h>
+#include <process.h>
+#include <stdio.h>
+#include <direct.h>
+
+/* For UNIX compatibility. */
+
+#ifdef __BORLANDC__
+
+#define _access access
+#define _chdir chdir
+#include <sys/types.h>
+
+#ifndef DllMain
+#define DllMain DllEntryPoint
+#endif
+
+#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
+
+#else
+
+typedef long uid_t;
+typedef long gid_t;
+
+#endif
+
+extern uid_t getuid(void);
+extern gid_t getgid(void);
+extern uid_t geteuid(void);
+extern gid_t getegid(void);
+extern int setuid(uid_t uid);
+extern int setgid(gid_t gid);
+
+extern int kill(int pid, int sig);
+
+extern char *staticlinkmodules[];
+
+/* if USE_WIN32_RTL_ENV is not defined, Perl uses direct Win32 calls
+ * to read the environment, bypassing the runtime's (usually broken)
+ * facilities for accessing the same. See note in util.c/my_setenv().
+ */
+/*#define USE_WIN32_RTL_ENV */
+
+#ifndef USE_WIN32_RTL_ENV
+#include <stdlib.h>
+#ifndef EXT
+#include "EXTERN.h"
+#endif
+#undef getenv
+#define getenv win32_getenv
+EXT char *win32_getenv(const char *name);
+#endif
+
+EXT void Perl_win32_init(int *argcp, char ***argvp);
+
+#define USE_SOCKETS_AS_HANDLES
+#ifndef USE_SOCKETS_AS_HANDLES
+extern FILE *myfdopen(int, char *);
+
+#undef fdopen
+#define fdopen myfdopen
+#endif /* USE_SOCKETS_AS_HANDLES */
+
+#define STANDARD_C 1 /* Perl5 likes standard C. */
+#define DOSISH 1 /* Take advantage of DOSish code in Perl5. */
+
+#define OP_BINARY O_BINARY /* Mistake in in pp_sys.c. */
+
+#undef pipe
+#define pipe(fd) win32_pipe((fd), 512, O_BINARY) /* the pipe call is a bit different */
+
+#undef pause
+#define pause() sleep((32767L << 16) + 32767)
+
+
+#undef times
+#define times mytimes
+
+#undef alarm
+#define alarm myalarm
+
+struct tms {
+ long tms_utime;
+ long tms_stime;
+ long tms_cutime;
+ long tms_cstime;
+};
+
+unsigned int sleep(unsigned int);
+char *win32PerlLibPath(void);
+char *win32SiteLibPath(void);
+int mytimes(struct tms *timebuf);
+unsigned int myalarm(unsigned int sec);
+int do_aspawn(void* really, void** mark, void** arglast);
+int do_spawn(char *cmd);
+char do_exec(char *cmd);
+void init_os_extras(void);
+
+typedef char * caddr_t; /* In malloc.c (core address). */
+
+/*
+ * Extension Library, only good for VC
+ */
+
+#define DllExport __declspec(dllexport)
+#define DllImport __declspec(dllimport)
+
+/*
+ * handle socket stuff, assuming socket is always available
+ */
+
+#include <sys/socket.h>
+#include <netdb.h>
+
+#ifdef _MSC_VER
+#pragma warning(disable: 4018 4035 4101 4102 4244 4245 4761)
+#endif
+
+int IsWin95(void);
+int IsWinNT(void);
+
+#ifndef VER_PLATFORM_WIN32_WINDOWS /* VC-2.0 headers dont have this */
+#define VER_PLATFORM_WIN32_WINDOWS 1
+#endif
+
+#endif /* _INC_WIN32_PERL5 */
diff --git a/gnu/usr.bin/perl/win32/win32io.c b/gnu/usr.bin/perl/win32/win32io.c
new file mode 100644
index 00000000000..eeb684620bb
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/win32io.c
@@ -0,0 +1,327 @@
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#define WIN32_LEAN_AND_MEAN
+#define WIN32IO_IS_STDIO
+#define EXT
+#include <windows.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <io.h>
+#include <sys/stat.h>
+#include <sys/socket.h>
+#include <fcntl.h>
+#include <assert.h>
+#include <errno.h>
+#include <process.h>
+#include <direct.h>
+#include "win32iop.h"
+
+/*
+ * The following is just a basic wrapping of the stdio
+ *
+ * redirected io subsystem for all XS modules
+ */
+
+static int *
+dummy_errno(void)
+{
+ return (&(errno));
+}
+
+static char ***
+dummy_environ(void)
+{
+ return (&(_environ));
+}
+
+/* the rest are the remapped stdio routines */
+static FILE *
+dummy_stderr(void)
+{
+ return stderr;
+}
+
+static FILE *
+dummy_stdin(void)
+{
+ return stdin;
+}
+
+static FILE *
+dummy_stdout(void)
+{
+ return stdout;
+}
+
+static int
+dummy_globalmode(int mode)
+{
+ int o = _fmode;
+ _fmode = mode;
+
+ return o;
+}
+
+#if defined(_DLL) || defined(__BORLANDC__)
+/* It may or may not be fixed (ok on NT), but DLL runtime
+ does not export the functions used in the workround
+*/
+#define WIN95_OSFHANDLE_FIXED
+#endif
+
+#if defined(_WIN32) && !defined(WIN95_OSFHANDLE_FIXED) && defined(_M_IX86)
+
+# ifdef __cplusplus
+#define EXT_C_FUNC extern "C"
+# else
+#define EXT_C_FUNC extern
+# endif
+
+EXT_C_FUNC int __cdecl _alloc_osfhnd(void);
+EXT_C_FUNC int __cdecl _set_osfhnd(int fh, long value);
+EXT_C_FUNC void __cdecl _lock_fhandle(int);
+EXT_C_FUNC void __cdecl _unlock_fhandle(int);
+EXT_C_FUNC void __cdecl _unlock(int);
+
+#if (_MSC_VER >= 1000)
+typedef struct {
+ long osfhnd; /* underlying OS file HANDLE */
+ char osfile; /* attributes of file (e.g., open in text mode?) */
+ char pipech; /* one char buffer for handles opened on pipes */
+#if defined (_MT) && !defined (DLL_FOR_WIN32S)
+ int lockinitflag;
+ CRITICAL_SECTION lock;
+#endif /* defined (_MT) && !defined (DLL_FOR_WIN32S) */
+} ioinfo;
+
+EXT_C_FUNC ioinfo * __pioinfo[];
+
+#define IOINFO_L2E 5
+#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E)
+#define _pioinfo(i) (__pioinfo[i >> IOINFO_L2E] + (i & (IOINFO_ARRAY_ELTS - 1)))
+#define _osfile(i) (_pioinfo(i)->osfile)
+
+#else /* (_MSC_VER >= 1000) */
+extern char _osfile[];
+#endif /* (_MSC_VER >= 1000) */
+
+#define FOPEN 0x01 /* file handle open */
+#define FAPPEND 0x20 /* file handle opened O_APPEND */
+#define FDEV 0x40 /* file handle refers to device */
+#define FTEXT 0x80 /* file handle is in text mode */
+
+#define _STREAM_LOCKS 26 /* Table of stream locks */
+#define _LAST_STREAM_LOCK (_STREAM_LOCKS+_NSTREAM_-1) /* Last stream lock */
+#define _FH_LOCKS (_LAST_STREAM_LOCK+1) /* Table of fh locks */
+
+/***
+*int _patch_open_osfhandle(long osfhandle, int flags) - open C Runtime file handle
+*
+*Purpose:
+* This function allocates a free C Runtime file handle and associates
+* it with the Win32 HANDLE specified by the first parameter. This is a
+* temperary fix for WIN95's brain damage GetFileType() error on socket
+* we just bypass that call for socket
+*
+*Entry:
+* long osfhandle - Win32 HANDLE to associate with C Runtime file handle.
+* int flags - flags to associate with C Runtime file handle.
+*
+*Exit:
+* returns index of entry in fh, if successful
+* return -1, if no free entry is found
+*
+*Exceptions:
+*
+*******************************************************************************/
+
+int
+my_open_osfhandle(long osfhandle, int flags)
+{
+ int fh;
+ char fileflags; /* _osfile flags */
+
+ /* copy relevant flags from second parameter */
+ fileflags = FDEV;
+
+ if(flags & O_APPEND)
+ fileflags |= FAPPEND;
+
+ if(flags & O_TEXT)
+ fileflags |= FTEXT;
+
+ /* attempt to allocate a C Runtime file handle */
+ if((fh = _alloc_osfhnd()) == -1) {
+ errno = EMFILE; /* too many open files */
+ _doserrno = 0L; /* not an OS error */
+ return -1; /* return error to caller */
+ }
+
+ /* the file is open. now, set the info in _osfhnd array */
+ _set_osfhnd(fh, osfhandle);
+
+ fileflags |= FOPEN; /* mark as open */
+
+#if (_MSC_VER >= 1000)
+ _osfile(fh) = fileflags; /* set osfile entry */
+ _unlock_fhandle(fh);
+#else
+ _osfile[fh] = fileflags; /* set osfile entry */
+ _unlock(fh+_FH_LOCKS); /* unlock handle */
+#endif
+
+ return fh; /* return handle */
+}
+#else
+
+int __cdecl
+my_open_osfhandle(long osfhandle, int flags)
+{
+ return _open_osfhandle(osfhandle, flags);
+}
+#endif /* _M_IX86 */
+
+long
+my_get_osfhandle( int filehandle )
+{
+ return _get_osfhandle(filehandle);
+}
+
+#ifdef __BORLANDC__
+#define _chdir chdir
+#endif
+
+/* simulate flock by locking a range on the file */
+
+
+#define LK_ERR(f,i) ((f) ? (i = 0) : (errno = GetLastError()))
+#define LK_LEN 0xffff0000
+
+int
+my_flock(int fd, int oper)
+{
+ OVERLAPPED o;
+ int i = -1;
+ HANDLE fh;
+
+ fh = (HANDLE)my_get_osfhandle(fd);
+ memset(&o, 0, sizeof(o));
+
+ switch(oper) {
+ case LOCK_SH: /* shared lock */
+ LK_ERR(LockFileEx(fh, 0, 0, LK_LEN, 0, &o),i);
+ break;
+ case LOCK_EX: /* exclusive lock */
+ LK_ERR(LockFileEx(fh, LOCKFILE_EXCLUSIVE_LOCK, 0, LK_LEN, 0, &o),i);
+ break;
+ case LOCK_SH|LOCK_NB: /* non-blocking shared lock */
+ LK_ERR(LockFileEx(fh, LOCKFILE_FAIL_IMMEDIATELY, 0, LK_LEN, 0, &o),i);
+ break;
+ case LOCK_EX|LOCK_NB: /* non-blocking exclusive lock */
+ LK_ERR(LockFileEx(fh,
+ LOCKFILE_EXCLUSIVE_LOCK|LOCKFILE_FAIL_IMMEDIATELY,
+ 0, LK_LEN, 0, &o),i);
+ break;
+ case LOCK_UN: /* unlock lock */
+ LK_ERR(UnlockFileEx(fh, 0, LK_LEN, 0, &o),i);
+ break;
+ default: /* unknown */
+ errno = EINVAL;
+ break;
+ }
+ return i;
+}
+
+#undef LK_ERR
+#undef LK_LEN
+
+EXT int my_fclose(FILE *pf);
+
+#ifdef PERLDLL
+__declspec(dllexport)
+#endif
+WIN32_IOSUBSYSTEM win32stdio = {
+ 12345678L, /* begin of structure; */
+ dummy_errno, /* (*pfunc_errno)(void); */
+ dummy_environ, /* (*pfunc_environ)(void); */
+ dummy_stdin, /* (*pfunc_stdin)(void); */
+ dummy_stdout, /* (*pfunc_stdout)(void); */
+ dummy_stderr, /* (*pfunc_stderr)(void); */
+ ferror, /* (*pfunc_ferror)(FILE *fp); */
+ feof, /* (*pfunc_feof)(FILE *fp); */
+ strerror, /* (*strerror)(int e); */
+ vfprintf, /* (*pfunc_vfprintf)(FILE *pf, const char *format, va_list arg); */
+ vprintf, /* (*pfunc_vprintf)(const char *format, va_list arg); */
+ fread, /* (*pfunc_fread)(void *buf, size_t size, size_t count, FILE *pf); */
+ fwrite, /* (*pfunc_fwrite)(void *buf, size_t size, size_t count, FILE *pf); */
+ fopen, /* (*pfunc_fopen)(const char *path, const char *mode); */
+ fdopen, /* (*pfunc_fdopen)(int fh, const char *mode); */
+ freopen, /* (*pfunc_freopen)(const char *path, const char *mode, FILE *pf); */
+ my_fclose, /* (*pfunc_fclose)(FILE *pf); */
+ fputs, /* (*pfunc_fputs)(const char *s,FILE *pf); */
+ fputc, /* (*pfunc_fputc)(int c,FILE *pf); */
+ ungetc, /* (*pfunc_ungetc)(int c,FILE *pf); */
+ getc, /* (*pfunc_getc)(FILE *pf); */
+ fileno, /* (*pfunc_fileno)(FILE *pf); */
+ clearerr, /* (*pfunc_clearerr)(FILE *pf); */
+ fflush, /* (*pfunc_fflush)(FILE *pf); */
+ ftell, /* (*pfunc_ftell)(FILE *pf); */
+ fseek, /* (*pfunc_fseek)(FILE *pf,long offset,int origin); */
+ fgetpos, /* (*pfunc_fgetpos)(FILE *pf,fpos_t *p); */
+ fsetpos, /* (*pfunc_fsetpos)(FILE *pf,fpos_t *p); */
+ rewind, /* (*pfunc_rewind)(FILE *pf); */
+ tmpfile, /* (*pfunc_tmpfile)(void); */
+ abort, /* (*pfunc_abort)(void); */
+ fstat, /* (*pfunc_fstat)(int fd,struct stat *bufptr); */
+ stat, /* (*pfunc_stat)(const char *name,struct stat *bufptr); */
+ _pipe, /* (*pfunc_pipe)( int *phandles, unsigned int psize, int textmode ); */
+ _popen, /* (*pfunc_popen)( const char *command, const char *mode ); */
+ _pclose, /* (*pfunc_pclose)( FILE *pf); */
+ setmode, /* (*pfunc_setmode)( int fd, int mode); */
+ lseek, /* (*pfunc_lseek)( int fd, long offset, int origin); */
+ tell, /* (*pfunc_tell)( int fd); */
+ dup, /* (*pfunc_dup)( int fd); */
+ dup2, /* (*pfunc_dup2)(int h1, int h2); */
+ open, /* (*pfunc_open)(const char *path, int oflag,...); */
+ close, /* (*pfunc_close)(int fd); */
+ eof, /* (*pfunc_eof)(int fd); */
+ read, /* (*pfunc_read)(int fd, void *buf, unsigned int cnt); */
+ write, /* (*pfunc_write)(int fd, const void *buf, unsigned int cnt); */
+ dummy_globalmode, /* (*pfunc_globalmode)(int mode) */
+ my_open_osfhandle,
+ my_get_osfhandle,
+ spawnvp,
+ mkdir,
+ rmdir,
+ chdir,
+ my_flock, /* (*pfunc_flock)(int fd, int oper) */
+ execvp,
+ perror,
+ setbuf,
+ setvbuf,
+ flushall,
+ fcloseall,
+ fgets,
+ gets,
+ fgetc,
+ putc,
+ puts,
+ getchar,
+ putchar,
+ fscanf,
+ scanf,
+ malloc,
+ calloc,
+ realloc,
+ free,
+ 87654321L, /* end of structure */
+};
+
+
+#ifdef __cplusplus
+}
+#endif
+
diff --git a/gnu/usr.bin/perl/win32/win32io.h b/gnu/usr.bin/perl/win32/win32io.h
new file mode 100644
index 00000000000..ba4080c1521
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/win32io.h
@@ -0,0 +1,87 @@
+#ifndef WIN32IO_H
+#define WIN32IO_H
+
+#ifdef __BORLANDC__
+#include <stdarg.h>
+#endif
+
+typedef struct {
+int signature_begin;
+int * (*pfnerrno)(void);
+char ***(*pfnenviron)(void);
+FILE* (*pfnstdin)(void);
+FILE* (*pfnstdout)(void);
+FILE* (*pfnstderr)(void);
+int (*pfnferror)(FILE *fp);
+int (*pfnfeof)(FILE *fp);
+char* (*pfnstrerror)(int e);
+int (*pfnvfprintf)(FILE *pf, const char *format, va_list arg);
+int (*pfnvprintf)(const char *format, va_list arg);
+size_t (*pfnfread)(void *buf, size_t size, size_t count, FILE *pf);
+size_t (*pfnfwrite)(const void *buf, size_t size, size_t count, FILE *pf);
+FILE* (*pfnfopen)(const char *path, const char *mode);
+FILE* (*pfnfdopen)(int fh, const char *mode);
+FILE* (*pfnfreopen)(const char *path, const char *mode, FILE *pf);
+int (*pfnfclose)(FILE *pf);
+int (*pfnfputs)(const char *s,FILE *pf);
+int (*pfnfputc)(int c,FILE *pf);
+int (*pfnungetc)(int c,FILE *pf);
+int (*pfngetc)(FILE *pf);
+int (*pfnfileno)(FILE *pf);
+void (*pfnclearerr)(FILE *pf);
+int (*pfnfflush)(FILE *pf);
+long (*pfnftell)(FILE *pf);
+int (*pfnfseek)(FILE *pf,long offset,int origin);
+int (*pfnfgetpos)(FILE *pf,fpos_t *p);
+int (*pfnfsetpos)(FILE *pf,const fpos_t *p);
+void (*pfnrewind)(FILE *pf);
+FILE* (*pfntmpfile)(void);
+void (*pfnabort)(void);
+int (*pfnfstat)(int fd,struct stat *bufptr);
+int (*pfnstat)(const char *name,struct stat *bufptr);
+int (*pfnpipe)( int *phandles, unsigned int psize, int textmode );
+FILE* (*pfnpopen)( const char *command, const char *mode );
+int (*pfnpclose)( FILE *pf);
+int (*pfnsetmode)( int fd, int mode);
+long (*pfnlseek)( int fd, long offset, int origin);
+long (*pfntell)( int fd);
+int (*pfndup)( int fd);
+int (*pfndup2)(int h1, int h2);
+int (*pfnopen)(const char *path, int oflag,...);
+int (*pfnclose)(int fd);
+int (*pfneof)(int fd);
+int (*pfnread)(int fd, void *buf, unsigned int cnt);
+int (*pfnwrite)(int fd, const void *buf, unsigned int cnt);
+int (*pfnopenmode)(int mode);
+int (*pfn_open_osfhandle)(long handle, int flags);
+long (*pfn_get_osfhandle)(int fd);
+int (*pfnspawnvp)(int mode, const char *cmdname, const char *const *argv);
+int (*pfnmkdir)(const char *path);
+int (*pfnrmdir)(const char *path);
+int (*pfnchdir)(const char *path);
+int (*pfnflock)(int fd, int oper);
+int (*pfnexecvp)(const char *cmdname, const char *const *argv);
+void (*pfnperror)(const char *str);
+void (*pfnsetbuf)(FILE *pf, char *buf);
+int (*pfnsetvbuf)(FILE *pf, char *buf, int type, size_t size);
+int (*pfnflushall)(void);
+int (*pfnfcloseall)(void);
+char* (*pfnfgets)(char *s, int n, FILE *pf);
+char* (*pfngets)(char *s);
+int (*pfnfgetc)(FILE *pf);
+int (*pfnputc)(int c, FILE *pf);
+int (*pfnputs)(const char *s);
+int (*pfngetchar)(void);
+int (*pfnputchar)(int c);
+int (*pfnfscanf)(FILE *pf, const char *format, ...);
+int (*pfnscanf)(const char *format, ...);
+void* (*pfnmalloc)(size_t size);
+void* (*pfncalloc)(size_t numitems, size_t size);
+void* (*pfnrealloc)(void *block, size_t size);
+void (*pfnfree)(void *block);
+int signature_end;
+} WIN32_IOSUBSYSTEM;
+
+typedef WIN32_IOSUBSYSTEM *PWIN32_IOSUBSYSTEM;
+
+#endif /* WIN32IO_H */
diff --git a/gnu/usr.bin/perl/win32/win32iop.h b/gnu/usr.bin/perl/win32/win32iop.h
new file mode 100644
index 00000000000..4606563d0e8
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/win32iop.h
@@ -0,0 +1,200 @@
+#ifndef WIN32IOP_H
+#define WIN32IOP_H
+
+
+/*
+ * Make this as close to original stdio as possible.
+ */
+
+/*
+ * function prototypes for our own win32io layer
+ */
+EXT int * win32_errno(void);
+EXT char *** win32_environ(void);
+EXT FILE* win32_stdin(void);
+EXT FILE* win32_stdout(void);
+EXT FILE* win32_stderr(void);
+EXT int win32_ferror(FILE *fp);
+EXT int win32_feof(FILE *fp);
+EXT char* win32_strerror(int e);
+
+EXT int win32_fprintf(FILE *pf, const char *format, ...);
+EXT int win32_printf(const char *format, ...);
+EXT int win32_vfprintf(FILE *pf, const char *format, va_list arg);
+EXT int win32_vprintf(const char *format, va_list arg);
+EXT size_t win32_fread(void *buf, size_t size, size_t count, FILE *pf);
+EXT size_t win32_fwrite(const void *buf, size_t size, size_t count, FILE *pf);
+EXT FILE* win32_fopen(const char *path, const char *mode);
+EXT FILE* win32_fdopen(int fh, const char *mode);
+EXT FILE* win32_freopen(const char *path, const char *mode, FILE *pf);
+EXT int win32_fclose(FILE *pf);
+EXT int win32_fputs(const char *s,FILE *pf);
+EXT int win32_fputc(int c,FILE *pf);
+EXT int win32_ungetc(int c,FILE *pf);
+EXT int win32_getc(FILE *pf);
+EXT int win32_fileno(FILE *pf);
+EXT void win32_clearerr(FILE *pf);
+EXT int win32_fflush(FILE *pf);
+EXT long win32_ftell(FILE *pf);
+EXT int win32_fseek(FILE *pf,long offset,int origin);
+EXT int win32_fgetpos(FILE *pf,fpos_t *p);
+EXT int win32_fsetpos(FILE *pf,const fpos_t *p);
+EXT void win32_rewind(FILE *pf);
+EXT FILE* win32_tmpfile(void);
+EXT void win32_abort(void);
+EXT int win32_fstat(int fd,struct stat *bufptr);
+EXT int win32_stat(const char *name,struct stat *bufptr);
+EXT int win32_pipe( int *phandles, unsigned int psize, int textmode );
+EXT FILE* win32_popen( const char *command, const char *mode );
+EXT int win32_pclose( FILE *pf);
+EXT int win32_setmode( int fd, int mode);
+EXT long win32_lseek( int fd, long offset, int origin);
+EXT long win32_tell( int fd);
+EXT int win32_dup( int fd);
+EXT int win32_dup2(int h1, int h2);
+EXT int win32_open(const char *path, int oflag,...);
+EXT int win32_close(int fd);
+EXT int win32_eof(int fd);
+EXT int win32_read(int fd, void *buf, unsigned int cnt);
+EXT int win32_write(int fd, const void *buf, unsigned int cnt);
+EXT int win32_spawnvp(int mode, const char *cmdname,
+ const char *const *argv);
+EXT int win32_mkdir(const char *dir, int mode);
+EXT int win32_rmdir(const char *dir);
+EXT int win32_chdir(const char *dir);
+EXT int win32_flock(int fd, int oper);
+EXT int win32_execvp(const char *cmdname, const char *const *argv);
+EXT void win32_perror(const char *str);
+EXT void win32_setbuf(FILE *pf, char *buf);
+EXT int win32_setvbuf(FILE *pf, char *buf, int type, size_t size);
+EXT int win32_flushall(void);
+EXT int win32_fcloseall(void);
+EXT char* win32_fgets(char *s, int n, FILE *pf);
+EXT char* win32_gets(char *s);
+EXT int win32_fgetc(FILE *pf);
+EXT int win32_putc(int c, FILE *pf);
+EXT int win32_puts(const char *s);
+EXT int win32_getchar(void);
+EXT int win32_putchar(int c);
+EXT void* win32_malloc(size_t size);
+EXT void* win32_calloc(size_t numitems, size_t size);
+EXT void* win32_realloc(void *block, size_t size);
+EXT void win32_free(void *block);
+
+/*
+ * these two are win32 specific but still io related
+ */
+int stolen_open_osfhandle(long handle, int flags);
+long stolen_get_osfhandle(int fd);
+
+/*
+ * defines for flock emulation
+ */
+#define LOCK_SH 1
+#define LOCK_EX 2
+#define LOCK_NB 4
+#define LOCK_UN 8
+
+#include <win32io.h> /* pull in the io sub system structure */
+
+EXT PWIN32_IOSUBSYSTEM SetIOSubSystem(void *piosubsystem);
+EXT PWIN32_IOSUBSYSTEM GetIOSubSystem(void);
+
+/*
+ * the following six(6) is #define in stdio.h
+ */
+#ifndef WIN32IO_IS_STDIO
+#undef errno
+#undef environ
+#undef stderr
+#undef stdin
+#undef stdout
+#undef ferror
+#undef feof
+
+#ifdef __BORLANDC__
+#undef ungetc
+#undef getc
+#undef putc
+#undef getchar
+#undef putchar
+#undef fileno
+#endif
+
+#define stderr win32_stderr()
+#define stdout win32_stdout()
+#define stdin win32_stdin()
+#define feof(f) win32_feof(f)
+#define ferror(f) win32_ferror(f)
+#define errno (*win32_errno())
+#define environ (*win32_environ())
+#define strerror win32_strerror
+
+/*
+ * redirect to our own version
+ */
+#define fprintf win32_fprintf
+#define vfprintf win32_vfprintf
+#define printf win32_printf
+#define vprintf win32_vprintf
+#define fread(buf,size,count,f) win32_fread(buf,size,count,f)
+#define fwrite(buf,size,count,f) win32_fwrite(buf,size,count,f)
+#define fopen win32_fopen
+#define fdopen win32_fdopen
+#define freopen win32_freopen
+#define fclose(f) win32_fclose(f)
+#define fputs(s,f) win32_fputs(s,f)
+#define fputc(c,f) win32_fputc(c,f)
+#define ungetc(c,f) win32_ungetc(c,f)
+#define getc(f) win32_getc(f)
+#define fileno(f) win32_fileno(f)
+#define clearerr(f) win32_clearerr(f)
+#define fflush(f) win32_fflush(f)
+#define ftell(f) win32_ftell(f)
+#define fseek(f,o,w) win32_fseek(f,o,w)
+#define fgetpos(f,p) win32_fgetpos(f,p)
+#define fsetpos(f,p) win32_fsetpos(f,p)
+#define rewind(f) win32_rewind(f)
+#define tmpfile() win32_tmpfile()
+#define abort() win32_abort()
+#define fstat(fd,bufptr) win32_fstat(fd,bufptr)
+#define stat(pth,bufptr) win32_stat(pth,bufptr)
+#define setmode(fd,mode) win32_setmode(fd,mode)
+#define lseek(fd,offset,orig) win32_lseek(fd,offset,orig)
+#define tell(fd) win32_tell(fd)
+#define dup(fd) win32_dup(fd)
+#define dup2(fd1,fd2) win32_dup2(fd1,fd2)
+#define open win32_open
+#define close(fd) win32_close(fd)
+#define eof(fd) win32_eof(fd)
+#define read(fd,b,s) win32_read(fd,b,s)
+#define write(fd,b,s) win32_write(fd,b,s)
+#define _open_osfhandle stolen_open_osfhandle
+#define _get_osfhandle stolen_get_osfhandle
+#define spawnvp win32_spawnvp
+#define mkdir win32_mkdir
+#define rmdir win32_rmdir
+#define chdir win32_chdir
+#define flock(fd,o) win32_flock(fd,o)
+#define execvp win32_execvp
+#define perror win32_perror
+#define setbuf win32_setbuf
+#define setvbuf win32_setvbuf
+#define flushall win32_flushall
+#define fcloseall win32_fcloseall
+#define fgets win32_fgets
+#define gets win32_gets
+#define fgetc win32_fgetc
+#define putc win32_putc
+#define puts win32_puts
+#define getchar win32_getchar
+#define putchar win32_putchar
+#define fscanf (GetIOSubSystem()->pfnfscanf)
+#define scanf (GetIOSubSystem()->pfnscanf)
+#define malloc win32_malloc
+#define calloc win32_calloc
+#define realloc win32_realloc
+#define free win32_free
+#endif /* WIN32IO_IS_STDIO */
+
+#endif /* WIN32IOP_H */
diff --git a/gnu/usr.bin/perl/win32/win32sck.c b/gnu/usr.bin/perl/win32/win32sck.c
new file mode 100644
index 00000000000..3653fc8b884
--- /dev/null
+++ b/gnu/usr.bin/perl/win32/win32sck.c
@@ -0,0 +1,726 @@
+/* NTSock.C
+ *
+ * (c) 1995 Microsoft Corporation. All rights reserved.
+ * Developed by hip communications inc., http://info.hip.com/info/
+ * Portions (c) 1993 Intergraph Corporation. All rights reserved.
+ *
+ * You may distribute under the terms of either the GNU General Public
+ * License or the Artistic License, as specified in the README file.
+ */
+
+#include <windows.h>
+#define WIN32_LEAN_AND_MEAN
+#include "EXTERN.h"
+#include "perl.h"
+#include <sys/socket.h>
+#include <fcntl.h>
+#include <sys/stat.h>
+#include <assert.h>
+
+#define CROAK croak
+
+#ifdef USE_SOCKETS_AS_HANDLES
+/* thanks to Beverly Brown (beverly@datacube.com) */
+
+#define OPEN_SOCKET(x) _open_osfhandle(x,O_RDWR|O_BINARY)
+#define TO_SOCKET(x) _get_osfhandle(x)
+
+#else
+
+# define OPEN_SOCKET(x) (x)
+# define TO_SOCKET(x) (x)
+
+#endif /* USE_SOCKETS_AS_HANDLES */
+
+static struct servent* win32_savecopyservent(struct servent*d,
+ struct servent*s,
+ const char *proto);
+#define SOCKETAPI PASCAL
+
+typedef SOCKET (SOCKETAPI *LPSOCKACCEPT)(SOCKET, struct sockaddr *, int *);
+typedef int (SOCKETAPI *LPSOCKBIND)(SOCKET, const struct sockaddr *, int);
+typedef int (SOCKETAPI *LPSOCKCLOSESOCKET)(SOCKET);
+typedef int (SOCKETAPI *LPSOCKCONNECT)(SOCKET, const struct sockaddr *, int);
+typedef int (SOCKETAPI *LPSOCKIOCTLSOCKET)(SOCKET, long, u_long *);
+typedef int (SOCKETAPI *LPSOCKGETPEERNAME)(SOCKET, struct sockaddr *, int *);
+typedef int (SOCKETAPI *LPSOCKGETSOCKNAME)(SOCKET, struct sockaddr *, int *);
+typedef int (SOCKETAPI *LPSOCKGETSOCKOPT)(SOCKET, int, int, char *, int *);
+typedef u_long (SOCKETAPI *LPSOCKHTONL)(u_long);
+typedef u_short (SOCKETAPI *LPSOCKHTONS)(u_short);
+typedef int (SOCKETAPI *LPSOCKLISTEN)(SOCKET, int);
+typedef u_long (SOCKETAPI *LPSOCKNTOHL)(u_long);
+typedef u_short (SOCKETAPI *LPSOCKNTOHS)(u_short);
+typedef int (SOCKETAPI *LPSOCKRECV)(SOCKET, char *, int, int);
+typedef int (SOCKETAPI *LPSOCKRECVFROM)(SOCKET, char *, int, int, struct sockaddr *, int *);
+typedef int (SOCKETAPI *LPSOCKSELECT)(int, fd_set *, fd_set *, fd_set *, const struct timeval *);
+typedef int (SOCKETAPI *LPSOCKSEND)(SOCKET, const char *, int, int);
+typedef int (SOCKETAPI *LPSOCKSENDTO)(SOCKET, const char *, int, int, const struct sockaddr *, int);
+typedef int (SOCKETAPI *LPSOCKSETSOCKOPT)(SOCKET, int, int, const char *, int);
+typedef int (SOCKETAPI *LPSOCKSHUTDOWN)(SOCKET, int);
+typedef SOCKET (SOCKETAPI *LPSOCKSOCKET)(int, int, int);
+typedef char FAR *(SOCKETAPI *LPSOCKINETNTOA)(struct in_addr in);
+typedef unsigned long (SOCKETAPI *LPSOCKINETADDR)(const char FAR * cp);
+
+
+/* Database function prototypes */
+typedef struct hostent *(SOCKETAPI *LPSOCKGETHOSTBYADDR)(const char *, int, int);
+typedef struct hostent *(SOCKETAPI *LPSOCKGETHOSTBYNAME)(const char *);
+typedef int (SOCKETAPI *LPSOCKGETHOSTNAME)(char *, int);
+typedef struct servent *(SOCKETAPI *LPSOCKGETSERVBYPORT)(int, const char *);
+typedef struct servent *(SOCKETAPI *LPSOCKGETSERVBYNAME)(const char *, const char *);
+typedef struct protoent *(SOCKETAPI *LPSOCKGETPROTOBYNUMBER)(int);
+typedef struct protoent *(SOCKETAPI *LPSOCKGETPROTOBYNAME)(const char *);
+
+/* Microsoft Windows Extension function prototypes */
+typedef int (SOCKETAPI *LPSOCKWSASTARTUP)(unsigned short, LPWSADATA);
+typedef int (SOCKETAPI *LPSOCKWSACLEANUP)(void);
+typedef int (SOCKETAPI *LPSOCKWSAGETLASTERROR)(void);
+typedef int (SOCKETAPI *LPWSAFDIsSet)(SOCKET, fd_set *);
+
+static HINSTANCE hWinSockDll = 0;
+/* extern CRITICAL_SECTION csSock; */
+
+static LPSOCKACCEPT paccept = 0;
+static LPSOCKBIND pbind = 0;
+static LPSOCKCLOSESOCKET pclosesocket = 0;
+static LPSOCKCONNECT pconnect = 0;
+static LPSOCKIOCTLSOCKET pioctlsocket = 0;
+static LPSOCKGETPEERNAME pgetpeername = 0;
+static LPSOCKGETSOCKNAME pgetsockname = 0;
+static LPSOCKGETSOCKOPT pgetsockopt = 0;
+static LPSOCKHTONL phtonl = 0;
+static LPSOCKHTONS phtons = 0;
+static LPSOCKLISTEN plisten = 0;
+static LPSOCKNTOHL pntohl = 0;
+static LPSOCKNTOHS pntohs = 0;
+static LPSOCKRECV precv = 0;
+static LPSOCKRECVFROM precvfrom = 0;
+static LPSOCKSELECT pselect = 0;
+static LPSOCKSEND psend = 0;
+static LPSOCKSENDTO psendto = 0;
+static LPSOCKSETSOCKOPT psetsockopt = 0;
+static LPSOCKSHUTDOWN pshutdown = 0;
+static LPSOCKSOCKET psocket = 0;
+static LPSOCKGETHOSTBYADDR pgethostbyaddr = 0;
+static LPSOCKGETHOSTBYNAME pgethostbyname = 0;
+static LPSOCKGETHOSTNAME pgethostname = 0;
+static LPSOCKGETSERVBYPORT pgetservbyport = 0;
+static LPSOCKGETSERVBYNAME pgetservbyname = 0;
+static LPSOCKGETPROTOBYNUMBER pgetprotobynumber = 0;
+static LPSOCKGETPROTOBYNAME pgetprotobyname = 0;
+static LPSOCKWSASTARTUP pWSAStartup = 0;
+static LPSOCKWSACLEANUP pWSACleanup = 0;
+static LPSOCKWSAGETLASTERROR pWSAGetLastError = 0;
+static LPWSAFDIsSet pWSAFDIsSet = 0;
+static LPSOCKINETNTOA pinet_ntoa = 0;
+static LPSOCKINETADDR pinet_addr = 0;
+
+__declspec(thread) struct servent myservent;
+
+
+void *
+GetAddress(HINSTANCE hInstance, char *lpFunctionName)
+{
+ FARPROC proc = GetProcAddress(hInstance, lpFunctionName);
+ if(proc == 0)
+ CROAK("Unable to get address of %s in WSock32.dll", lpFunctionName);
+ return proc;
+}
+
+void
+LoadWinSock(void)
+{
+/* EnterCriticalSection(&csSock); */
+ if(hWinSockDll == NULL) {
+ HINSTANCE hLib = LoadLibrary("WSock32.DLL");
+ if(hLib == NULL)
+ CROAK("Could not load WSock32.dll\n");
+
+ paccept = (LPSOCKACCEPT)GetAddress(hLib, "accept");
+ pbind = (LPSOCKBIND)GetAddress(hLib, "bind");
+ pclosesocket = (LPSOCKCLOSESOCKET)GetAddress(hLib, "closesocket");
+ pconnect = (LPSOCKCONNECT)GetAddress(hLib, "connect");
+ pioctlsocket = (LPSOCKIOCTLSOCKET)GetAddress(hLib, "ioctlsocket");
+ pgetpeername = (LPSOCKGETPEERNAME)GetAddress(hLib, "getpeername");
+ pgetsockname = (LPSOCKGETSOCKNAME)GetAddress(hLib, "getsockname");
+ pgetsockopt = (LPSOCKGETSOCKOPT)GetAddress(hLib, "getsockopt");
+ phtonl = (LPSOCKHTONL)GetAddress(hLib, "htonl");
+ phtons = (LPSOCKHTONS)GetAddress(hLib, "htons");
+ plisten = (LPSOCKLISTEN)GetAddress(hLib, "listen");
+ pntohl = (LPSOCKNTOHL)GetAddress(hLib, "ntohl");
+ pntohs = (LPSOCKNTOHS)GetAddress(hLib, "ntohs");
+ precv = (LPSOCKRECV)GetAddress(hLib, "recv");
+ precvfrom = (LPSOCKRECVFROM)GetAddress(hLib, "recvfrom");
+ pselect = (LPSOCKSELECT)GetAddress(hLib, "select");
+ psend = (LPSOCKSEND)GetAddress(hLib, "send");
+ psendto = (LPSOCKSENDTO)GetAddress(hLib, "sendto");
+ psetsockopt = (LPSOCKSETSOCKOPT)GetAddress(hLib, "setsockopt");
+ pshutdown = (LPSOCKSHUTDOWN)GetAddress(hLib, "shutdown");
+ psocket = (LPSOCKSOCKET)GetAddress(hLib, "socket");
+ pgethostbyaddr = (LPSOCKGETHOSTBYADDR)GetAddress(hLib, "gethostbyaddr");
+ pgethostbyname = (LPSOCKGETHOSTBYNAME)GetAddress(hLib, "gethostbyname");
+ pgethostname = (LPSOCKGETHOSTNAME)GetAddress(hLib, "gethostname");
+ pgetservbyport = (LPSOCKGETSERVBYPORT)GetAddress(hLib, "getservbyport");
+ pgetservbyname = (LPSOCKGETSERVBYNAME)GetAddress(hLib, "getservbyname");
+ pgetprotobynumber = (LPSOCKGETPROTOBYNUMBER)GetAddress(hLib, "getprotobynumber");
+ pgetprotobyname = (LPSOCKGETPROTOBYNAME)GetAddress(hLib, "getprotobyname");
+ pWSAStartup = (LPSOCKWSASTARTUP)GetAddress(hLib, "WSAStartup");
+ pWSACleanup = (LPSOCKWSACLEANUP)GetAddress(hLib, "WSACleanup");
+ pWSAGetLastError = (LPSOCKWSAGETLASTERROR)GetAddress(hLib, "WSAGetLastError");
+ pWSAFDIsSet = (LPWSAFDIsSet)GetAddress(hLib, "__WSAFDIsSet");
+ pinet_addr = (LPSOCKINETADDR)GetAddress(hLib,"inet_addr");
+ pinet_ntoa = (LPSOCKINETNTOA)GetAddress(hLib,"inet_ntoa");
+
+ hWinSockDll = hLib;
+ }
+/* LeaveCriticalSection(&csSock); */
+}
+
+void
+EndSockets(void)
+{
+ if(hWinSockDll != NULL) {
+ pWSACleanup();
+ FreeLibrary(hWinSockDll);
+ }
+ hWinSockDll = NULL;
+}
+
+void
+StartSockets(void)
+{
+ unsigned short version;
+ WSADATA retdata;
+ int ret;
+ int iSockOpt = SO_SYNCHRONOUS_NONALERT;
+
+ LoadWinSock();
+ /*
+ * initalize the winsock interface and insure that it is
+ * cleaned up at exit.
+ */
+ version = 0x101;
+ if(ret = pWSAStartup(version, &retdata))
+ CROAK("Unable to locate winsock library!\n");
+ if(retdata.wVersion != version)
+ CROAK("Could not find version 1.1 of winsock dll\n");
+
+ /* atexit((void (*)(void)) EndSockets); */
+
+#ifdef USE_SOCKETS_AS_HANDLES
+ /*
+ * Enable the use of sockets as filehandles
+ */
+ psetsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE,
+ (char *)&iSockOpt, sizeof(iSockOpt));
+#endif /* USE_SOCKETS_AS_HANDLES */
+}
+
+
+#ifndef USE_SOCKETS_AS_HANDLES
+FILE *
+myfdopen(int fd, char *mode)
+{
+ FILE *fp;
+ char sockbuf[256];
+ int optlen = sizeof(sockbuf);
+ int retval;
+
+ if (hWinSockDll == 0)
+ return(fdopen(fd, mode));
+
+ retval = pgetsockopt((SOCKET)fd, SOL_SOCKET, SO_TYPE, sockbuf, &optlen);
+ if(retval == SOCKET_ERROR && pWSAGetLastError() == WSAENOTSOCK) {
+ return(fdopen(fd, mode));
+ }
+
+ /*
+ * If we get here, then fd is actually a socket.
+ */
+ Newz(1310, fp, 1, FILE);
+ if(fp == NULL) {
+ errno = ENOMEM;
+ return NULL;
+ }
+
+ fp->_file = fd;
+ if(*mode == 'r')
+ fp->_flag = _IOREAD;
+ else
+ fp->_flag = _IOWRT;
+
+ return fp;
+}
+#endif /* USE_SOCKETS_AS_HANDLES */
+
+
+u_long
+win32_htonl(u_long hostlong)
+{
+ if(hWinSockDll == 0)
+ StartSockets();
+
+ return phtonl(hostlong);
+}
+
+u_short
+win32_htons(u_short hostshort)
+{
+ if(hWinSockDll == 0)
+ StartSockets();
+
+ return phtons(hostshort);
+}
+
+u_long
+win32_ntohl(u_long netlong)
+{
+ if(hWinSockDll == 0)
+ StartSockets();
+
+ return pntohl(netlong);
+}
+
+u_short
+win32_ntohs(u_short netshort)
+{
+ if(hWinSockDll == 0)
+ StartSockets();
+
+ return pntohs(netshort);
+}
+
+
+#define SOCKET_TEST(x, y) if(hWinSockDll == 0) StartSockets();\
+ if((x) == (y)) errno = pWSAGetLastError()
+
+#define SOCKET_TEST_ERROR(x) SOCKET_TEST(x, SOCKET_ERROR)
+
+SOCKET
+win32_accept(SOCKET s, struct sockaddr *addr, int *addrlen)
+{
+ SOCKET r;
+
+ SOCKET_TEST((r = paccept(TO_SOCKET(s), addr, addrlen)), INVALID_SOCKET);
+ return OPEN_SOCKET(r);
+}
+
+int
+win32_bind(SOCKET s, const struct sockaddr *addr, int addrlen)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = pbind(TO_SOCKET(s), addr, addrlen));
+ return r;
+}
+
+int
+win32_connect(SOCKET s, const struct sockaddr *addr, int addrlen)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = pconnect(TO_SOCKET(s), addr, addrlen));
+ return r;
+}
+
+
+int
+win32_getpeername(SOCKET s, struct sockaddr *addr, int *addrlen)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = pgetpeername(TO_SOCKET(s), addr, addrlen));
+ return r;
+}
+
+int
+win32_getsockname(SOCKET s, struct sockaddr *addr, int *addrlen)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = pgetsockname(TO_SOCKET(s), addr, addrlen));
+ return r;
+}
+
+int
+win32_getsockopt(SOCKET s, int level, int optname, char *optval, int *optlen)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = pgetsockopt(TO_SOCKET(s), level, optname, optval, optlen));
+ return r;
+}
+
+int
+win32_ioctlsocket(SOCKET s, long cmd, u_long *argp)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = pioctlsocket(TO_SOCKET(s), cmd, argp));
+ return r;
+}
+
+int
+win32_listen(SOCKET s, int backlog)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = plisten(TO_SOCKET(s), backlog));
+ return r;
+}
+
+int
+win32_recv(SOCKET s, char *buf, int len, int flags)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = precv(TO_SOCKET(s), buf, len, flags));
+ return r;
+}
+
+int
+win32_recvfrom(SOCKET s, char *buf, int len, int flags, struct sockaddr *from, int *fromlen)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = precvfrom(TO_SOCKET(s), buf, len, flags, from, fromlen));
+ return r;
+}
+
+/* select contributed by Vincent R. Slyngstad (vrs@ibeam.intel.com) */
+int
+win32_select(int nfds, int* rd, int* wr, int* ex, const struct timeval* timeout)
+{
+ long r;
+ int dummy = 0;
+ int i, fd, bit, offset;
+ FD_SET nrd, nwr, nex,*prd,*pwr,*pex;
+
+ if (!rd)
+ rd = &dummy, prd = NULL;
+ else
+ prd = &nrd;
+ if (!wr)
+ wr = &dummy, pwr = NULL;
+ else
+ pwr = &nwr;
+ if (!ex)
+ ex = &dummy, pex = NULL;
+ else
+ pex = &nex;
+
+ FD_ZERO(&nrd);
+ FD_ZERO(&nwr);
+ FD_ZERO(&nex);
+ for (i = 0; i < nfds; i++) {
+ fd = TO_SOCKET(i);
+ bit = 1L<<(i % (sizeof(int)*8));
+ offset = i / (sizeof(int)*8);
+ if (rd[offset] & bit)
+ FD_SET(fd, &nrd);
+ if (wr[offset] & bit)
+ FD_SET(fd, &nwr);
+ if (ex[offset] & bit)
+ FD_SET(fd, &nex);
+ }
+
+ SOCKET_TEST_ERROR(r = pselect(nfds, prd, pwr, pex, timeout));
+
+ for (i = 0; i < nfds; i++) {
+ fd = TO_SOCKET(i);
+ bit = 1L<<(i % (sizeof(int)*8));
+ offset = i / (sizeof(int)*8);
+ if (rd[offset] & bit) {
+ if (!pWSAFDIsSet(fd, &nrd))
+ rd[offset] &= ~bit;
+ }
+ if (wr[offset] & bit) {
+ if (!pWSAFDIsSet(fd, &nwr))
+ wr[offset] &= ~bit;
+ }
+ if (ex[offset] & bit) {
+ if (!pWSAFDIsSet(fd, &nex))
+ ex[offset] &= ~bit;
+ }
+ }
+ return r;
+}
+
+int
+win32_send(SOCKET s, const char *buf, int len, int flags)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = psend(TO_SOCKET(s), buf, len, flags));
+ return r;
+}
+
+int
+win32_sendto(SOCKET s, const char *buf, int len, int flags,
+ const struct sockaddr *to, int tolen)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = psendto(TO_SOCKET(s), buf, len, flags, to, tolen));
+ return r;
+}
+
+int
+win32_setsockopt(SOCKET s, int level, int optname, const char *optval, int optlen)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = psetsockopt(TO_SOCKET(s), level, optname, optval, optlen));
+ return r;
+}
+
+int
+win32_shutdown(SOCKET s, int how)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = pshutdown(TO_SOCKET(s), how));
+ return r;
+}
+
+SOCKET
+win32_socket(int af, int type, int protocol)
+{
+ SOCKET s;
+
+#ifndef USE_SOCKETS_AS_HANDLES
+ SOCKET_TEST(s = psocket(af, type, protocol), INVALID_SOCKET);
+#else
+ if(hWinSockDll == 0)
+ StartSockets();
+
+ if((s = psocket(af, type, protocol)) == INVALID_SOCKET)
+ errno = pWSAGetLastError();
+ else
+ s = OPEN_SOCKET(s);
+#endif /* USE_SOCKETS_AS_HANDLES */
+
+ return s;
+}
+
+#undef fclose
+int
+my_fclose (FILE *pf)
+{
+ int osf, retval;
+ if (hWinSockDll == 0) /* No WinSockDLL? */
+ return(fclose(pf)); /* Then not a socket. */
+ osf = TO_SOCKET(fileno(pf)); /* Get it now before it's gone! */
+ retval = fclose(pf); /* Must fclose() before closesocket() */
+ if (osf != -1
+ && pclosesocket(osf) == SOCKET_ERROR
+ && WSAGetLastError() != WSAENOTSOCK)
+ retval = EOF;
+ return retval;
+}
+
+struct hostent *
+win32_gethostbyaddr(const char *addr, int len, int type)
+{
+ struct hostent *r;
+
+ SOCKET_TEST(r = pgethostbyaddr(addr, len, type), NULL);
+ return r;
+}
+
+struct hostent *
+win32_gethostbyname(const char *name)
+{
+ struct hostent *r;
+
+ SOCKET_TEST(r = pgethostbyname(name), NULL);
+ return r;
+}
+
+int
+win32_gethostname(char *name, int len)
+{
+ int r;
+
+ SOCKET_TEST_ERROR(r = pgethostname(name, len));
+ return r;
+}
+
+struct protoent *
+win32_getprotobyname(const char *name)
+{
+ struct protoent *r;
+
+ SOCKET_TEST(r = pgetprotobyname(name), NULL);
+ return r;
+}
+
+struct protoent *
+win32_getprotobynumber(int num)
+{
+ struct protoent *r;
+
+ SOCKET_TEST(r = pgetprotobynumber(num), NULL);
+ return r;
+}
+
+struct servent *
+win32_getservbyname(const char *name, const char *proto)
+{
+ struct servent *r;
+
+ SOCKET_TEST(r = pgetservbyname(name, proto), NULL);
+ if (r) {
+ r = win32_savecopyservent(&myservent, r, proto);
+ }
+ return r;
+}
+
+struct servent *
+win32_getservbyport(int port, const char *proto)
+{
+ struct servent *r;
+
+ SOCKET_TEST(r = pgetservbyport(port, proto), NULL);
+ if (r) {
+ r = win32_savecopyservent(&myservent, r, proto);
+ }
+ return r;
+}
+
+char FAR *
+win32_inet_ntoa(struct in_addr in)
+{
+ if(hWinSockDll == 0)
+ StartSockets();
+
+ return pinet_ntoa(in);
+}
+
+unsigned long
+win32_inet_addr(const char FAR *cp)
+{
+ if(hWinSockDll == 0)
+ StartSockets();
+
+ return pinet_addr(cp);
+
+}
+
+/*
+ * Networking stubs
+ */
+#undef CROAK
+#define CROAK croak
+
+void
+win32_endhostent()
+{
+ CROAK("endhostent not implemented!\n");
+}
+
+void
+win32_endnetent()
+{
+ CROAK("endnetent not implemented!\n");
+}
+
+void
+win32_endprotoent()
+{
+ CROAK("endprotoent not implemented!\n");
+}
+
+void
+win32_endservent()
+{
+ CROAK("endservent not implemented!\n");
+}
+
+
+struct netent *
+win32_getnetent(void)
+{
+ CROAK("getnetent not implemented!\n");
+ return (struct netent *) NULL;
+}
+
+struct netent *
+win32_getnetbyname(char *name)
+{
+ CROAK("getnetbyname not implemented!\n");
+ return (struct netent *)NULL;
+}
+
+struct netent *
+win32_getnetbyaddr(long net, int type)
+{
+ CROAK("getnetbyaddr not implemented!\n");
+ return (struct netent *)NULL;
+}
+
+struct protoent *
+win32_getprotoent(void)
+{
+ CROAK("getprotoent not implemented!\n");
+ return (struct protoent *) NULL;
+}
+
+struct servent *
+win32_getservent(void)
+{
+ CROAK("getservent not implemented!\n");
+ return (struct servent *) NULL;
+}
+
+void
+win32_sethostent(int stayopen)
+{
+ CROAK("sethostent not implemented!\n");
+}
+
+
+void
+win32_setnetent(int stayopen)
+{
+ CROAK("setnetent not implemented!\n");
+}
+
+
+void
+win32_setprotoent(int stayopen)
+{
+ CROAK("setprotoent not implemented!\n");
+}
+
+
+void
+win32_setservent(int stayopen)
+{
+ CROAK("setservent not implemented!\n");
+}
+
+#define WIN32IO_IS_STDIO
+#include <io.h>
+#include "win32iop.h"
+
+static struct servent*
+win32_savecopyservent(struct servent*d, struct servent*s, const char *proto)
+{
+ d->s_name = s->s_name;
+ d->s_aliases = s->s_aliases;
+ d->s_port = s->s_port;
+#ifndef __BORLANDC__ /* Buggy on Win95 and WinNT-with-Borland-WSOCK */
+ if (!IsWin95() && s->s_proto && strlen(s->s_proto))
+ d->s_proto = s->s_proto;
+ else
+#endif
+ if (proto && strlen(proto))
+ d->s_proto = (char *)proto;
+ else
+ d->s_proto = "tcp";
+
+ return d;
+}
+
+
diff --git a/gnu/usr.bin/perl/writemain.SH b/gnu/usr.bin/perl/writemain.SH
index 4884a387a17..c4283830854 100644
--- a/gnu/usr.bin/perl/writemain.SH
+++ b/gnu/usr.bin/perl/writemain.SH
@@ -21,6 +21,7 @@ echo "Extracting writemain (with variable substitutions)"
: 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!
@@ -69,11 +70,12 @@ cat << 'EOP'
static void
xs_init()
{
- dXSUB_SYS;
EOP
if test X"$args" != "X" ; then
echo " char *file = __FILE__;"
+ echo " dXSUB_SYS;"
+
ai=''
for ext in $args ; do
@@ -83,7 +85,6 @@ if test X"$args" != "X" ; then
mname=`echo $ext | sed 's!/!::!g'`
cname=`echo $mname | sed 's!:!_!g'`
- echo " {"
if test "$ext" = "DynaLoader"; then
: Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
: boot_DynaLoader is called directly in DynaLoader.pm
@@ -91,7 +92,6 @@ if test X"$args" != "X" ; then
else
echo " newXS(\"${mname}::bootstrap\", boot_${cname}, file);"
fi
- echo " }"
done
fi
diff --git a/gnu/usr.bin/perl/x2p/EXTERN.h b/gnu/usr.bin/perl/x2p/EXTERN.h
index e4abe5f87b5..cd1a4112ae2 100644
--- a/gnu/usr.bin/perl/x2p/EXTERN.h
+++ b/gnu/usr.bin/perl/x2p/EXTERN.h
@@ -1,6 +1,6 @@
/* $RCSfile: EXTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:05 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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/gnu/usr.bin/perl/x2p/INTERN.h b/gnu/usr.bin/perl/x2p/INTERN.h
index aa3af58c8dc..ac1d57ab05c 100644
--- a/gnu/usr.bin/perl/x2p/INTERN.h
+++ b/gnu/usr.bin/perl/x2p/INTERN.h
@@ -1,6 +1,6 @@
/* $RCSfile: INTERN.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:06 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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/gnu/usr.bin/perl/x2p/Makefile.SH b/gnu/usr.bin/perl/x2p/Makefile.SH
index c5453d03d12..65a3d75ec1d 100644
--- a/gnu/usr.bin/perl/x2p/Makefile.SH
+++ b/gnu/usr.bin/perl/x2p/Makefile.SH
@@ -14,18 +14,22 @@ 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\(.*\)/'` ;;
+*/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: 1.1 $$Date: 1996/08/19 10:13:33 $
-#
-# $Log: Makefile.SH,v $
-# Revision 1.1 1996/08/19 10:13:33 downsj
-# Initial revision
+# $RCSfile: Makefile.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:07 $
#
+# $Log: Makefile.SH,v $
CC = $cc
BYACC = $byacc
@@ -38,6 +42,10 @@ shellflags = $shellflags
libs = $libs
+$make_set_make
+# grrr
+SHELL = $sh
+
# These variables will be used in a future version to make
# the make file more portable to non-unix systems.
AR = $ar
@@ -72,7 +80,7 @@ plextract = find2perl s2p
addedbyconf = $(shextract) $(plextract)
-h = EXTERN.h INTERN.h ../config.h handy.h hash.h a2p.h str.h util.h
+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
@@ -80,11 +88,9 @@ obj = hash$(OBJ_EXT) $(mallocobj) str$(OBJ_EXT) util$(OBJ_EXT) walk$(OBJ_EXT)
lintflags = -phbvxac
-# grrr
-SHELL = /bin/sh
.c$(OBJ_EXT):
- $(CCCMD) $*.c
+ $(CCCMD) -DPERL_FOR_X2P $*.c
all: $(public) $(private) $(util)
touch all
@@ -106,7 +112,8 @@ run_byacc: FORCE
a2p.c: a2p.y
-@touch a2p.c
-a2p$(OBJ_EXT): a2p.c a2py.c a2p.h EXTERN.h util.h INTERN.h handy.h ../config.h str.h hash.h
+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:
@@ -125,7 +132,7 @@ lint:
lint $(lintflags) $(defs) $(c) > a2p.fuzz
depend: $(mallocsrc) ../makedepend
- sh ../makedepend
+ sh ../makedepend MAKE=$(MAKE)
clist:
echo $(c) | tr ' ' '\012' >.clist
@@ -144,6 +151,7 @@ $(plextract):
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/'
diff --git a/gnu/usr.bin/perl/x2p/a2p.c b/gnu/usr.bin/perl/x2p/a2p.c
index c6d21e3e4de..340e4bfad60 100644
--- a/gnu/usr.bin/perl/x2p/a2p.c
+++ b/gnu/usr.bin/perl/x2p/a2p.c
@@ -5,7 +5,7 @@ static char yysccsid[] = "@(#)yaccpar 1.8 (Berkeley) 01/20/91";
#line 2 "a2p.y"
/* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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.
@@ -74,7 +74,7 @@ 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, 16, 16, 16, 16, 16,
+ 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,
@@ -90,8 +90,8 @@ 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, 3, 1, 1, 1, 3, 3,
- 3, 3, 3, 3, 3, 5, 2, 2, 2, 2,
+ 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,
@@ -105,951 +105,981 @@ short yylen[] = { 2,
short yydefred[] = { 93,
0, 0, 95, 96, 97, 94, 0, 92, 0, 0,
31, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 37, 0, 0, 0, 38, 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, 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, 47, 48,
- 0, 0, 61, 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, 30, 0, 0, 0, 0,
- 45, 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, 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, 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,
+ 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, 73, 125, 37, 38, 39, 164, 52,
- 53, 41, 42, 43, 44, 45, 46, 55, 8, 126,
- 225, 187, 188, 189, 254, 248,
+ 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, -48, 0, 0, 0, 0, 6619, 0, -121, -110,
- 0, -4, 32, 4183, 38, 30, 51, 64, 68, -260,
- 70, 0, -61, 82, 83, 0, 4448, 4448, 4448, -183,
- -183, 0, 4448, 0, 4448, 0, -188, 0, 3, 22,
- 6884, 0, 0, 0, 34, -213, 0, 0, 2061, 4183,
- 4183, 0, -49, 5612, 85, 4448, 4448, 14, 4713, 6753,
- 4448, 87, 4183, 4183, 4448, 4448, -77, -77, 0, 0,
- 0, 18, -192, -36, 91, 92, 95, 0, -48, 0,
- 4448, 0, 0, 4448, 6980, 4448, 4448, 4448, 34, -154,
- 4448, 4448, 4448, 4448, 4448, 4448, -135, 4448, 0, 0,
- -192, -192, 0, 5658, 106, 5612, 11, 0, 0, 5704,
- 186, 4448, 113, 5751, 115, 5805, 5885, 4183, 114, 67,
- 5931, 5978, 0, 0, 4572, 0, 0, 0, 0, 0,
- -192, 6032, 1964, 1964, -49, 0, 3230, 186, 186, 186,
- 0, 97, 97, -77, -77, -77, -77, -183, -49, 4665,
- 4765, 0, 0, 0, 1964, 1964, -131, 186, 4448, 4448,
- 4448, 4448, 7026, 121, 0, 0, 0, 4448, 4448, 0,
- 4183, 4183, 124, 125, 132, 4448, 0, 0, 0, 4448,
- 0, -117, 0, 0, 0, 6884, 0, -44, 0, 4837,
- 4448, -114, 0, 0, 0, 0, 6884, 6884, 13, 3635,
- 5295, 5367, 5506, 137, 6078, 0, 5560, 6243, -192, -59,
- -59, 4448, 4448, 5241, 6884, 6884, 3701, 93, -192, -192,
- 0, 0, 0, 0, 0, 0, 6884, -48, 0, 7084,
- 0, 4448, 0, 4448, 0, 4448, 0, 4448, 0, 0,
- -119, 0, 4448, 0, 0, 0, 0, 4448, 4448, -34,
- -16, 6343, 0, 123, -89, 4183, 4930, -192, -192, -192,
- -192, -192, 144, 6389, 6435, 6508, 6554, 6700, 0, 6819,
- 6884, 6884, 0, 0, 0, 6930, 146, 94, 0, 0,
- 0, 0, 0, 0, 0, -192, 0, 3701, 3701, 3701,
- 5241, -53, 4448, 0, -192, 5030, -83, 0, 0, 148,
- 5241, -13, 0, 0, 0, 149, 0, 3701, 3701, 0,
- 0, 0, 3701, 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, 2015, 0, 0, 0, 0, 192, 0, 0, 0,
- 0, 56, 0, 3424, 0, 2619, 0, 0, 0, 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, 2147, 0, 2195, 1676,
- 3509, 0, 0, 0, 1782, 1340, 0, 0, 0, 152,
- 0, 0, 0, 3829, 111, 0, 0, 381, 0, 0,
- 0, 0, 152, 101, 0, 0, 564, 834, 0, 0,
- 0, 436, 5102, 0, -47, 39, 42, 0, 2245, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 1830, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 5102, 5102, 0, 72, 0, 17, 0, 0, 0, 72,
- 2718, 0, 74, 72, 74, 72, 72, 152, 0, 0,
- 72, 72, 0, 0, 0, 0, 0, 0, 0, 0,
- 5102, 72, 0, 0, 1882, 0, 3464, 3057, 3097, 3145,
- 0, 1468, 1734, 888, 942, 1016, 1286, 2564, 1395, 0,
- 0, 0, 0, 0, 0, 0, 0, 3185, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 538, 538, 0, 0, 0, 122, 0, 0, 0, 241,
- 0, 0, 0, 0, 0, -41, 0, 0, 0, 0,
- 0, 491, 0, 0, 0, 0, 3549, 3594, 0, 72,
- 72, 72, 72, 74, 72, 0, 72, 72, 3866, 296,
- 357, 0, 0, 136, -10, 169, 0, 0, 5102, 3970,
- 0, 0, 0, 0, 0, 0, 3784, 2294, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, -51, 0, 0, 0, 101, 0, 4038, 4135, 4235,
- 4307, 4400, 74, 72, 72, 72, 72, 72, 0, 72,
- 507, 553, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 5102, 0, 0, 0, 0,
- 155, 0, 0, 0, 4500, 0, 5195, 0, 0, 0,
- 155, 0, 0, 0, 0, 0, 0, 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,
- -18, 0, 0, 7251, -19, 0, 0, 0, 0, -31,
- 33, 2875, -14, -12, 16, 7373, 76, 147, 0, 0,
- 0, 231, -205, 0, -267, -9,
+ -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 7645
-short yytable[] = { 114,
- 82, 47, 246, 269, 127, 301, 273, 114, 253, 81,
- 6, 16, 48, 81, 224, 17, 96, 114, 105, 79,
- 75, 16, 76, 300, 274, 62, 81, 307, 81, 64,
- 122, 119, 120, 306, 97, 49, 75, 82, 76, 40,
- 82, 82, 82, 82, 82, 82, 81, 82, 122, 81,
- 77, 154, 16, 229, 109, 60, 230, 16, 82, 82,
- 82, 69, 82, 82, 247, 84, 77, 74, 123, 124,
- 95, 50, 78, 112, 98, 93, 91, 56, 92, 16,
- 94, 150, 151, 74, 81, 253, 165, 99, 100, 57,
- 59, 58, 60, 82, 82, 253, 60, 60, 60, 60,
- 60, 18, 60, 60, 19, 70, 71, 61, 23, 63,
- 87, 190, 82, 60, 60, 60, 135, 60, 60, 32,
- 33, 65, 66, 82, 82, 80, 118, 96, 109, 97,
- 149, 128, 129, 95, 16, 130, 31, 141, 93, 210,
- 211, 123, 124, 94, 148, 97, 153, 87, 60, 60,
- 87, 87, 87, 87, 166, 87, 159, 87, 161, 167,
- 199, 206, 121, 212, 213, 192, 193, 60, 87, 87,
- 87, 214, 87, 87, 218, 83, 228, 239, 60, 60,
- 121, 276, 277, 256, 280, 293, 294, 304, 305, 310,
- 96, 1, 88, 88, 113, 113, 0, 107, 0, 257,
- 0, 249, 0, 87, 87, 245, 0, 0, 97, 125,
- 0, 3, 4, 5, 0, 221, 222, 223, 114, 114,
- 114, 0, 87, 194, 278, 35, 0, 125, 27, 0,
- 28, 16, 0, 87, 87, 82, 83, 16, 16, 82,
- 83, 17, 17, 0, 250, 251, 0, 16, 16, 122,
- 122, 122, 82, 83, 82, 83, 0, 82, 82, 82,
- 82, 82, 82, 82, 82, 82, 296, 0, 82, 82,
- 0, 0, 82, 83, 82, 82, 83, 0, 16, 16,
- 82, 124, 82, 82, 82, 82, 82, 0, 82, 82,
- 82, 82, 82, 82, 82, 82, 82, 0, 82, 124,
- 82, 82, 82, 82, 82, 16, 16, 90, 292, 0,
- 82, 83, 60, 60, 60, 60, 60, 60, 60, 60,
- 60, 23, 0, 60, 60, 302, 0, 18, 18, 60,
- 19, 19, 32, 33, 0, 60, 116, 60, 60, 60,
+#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, 116, 60, 60, 60, 60, 60,
- 16, 16, 31, 31, 0, 0, 0, 87, 87, 87,
+ 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, 121, 121, 121, 87, 0, 0, 0, 0, 0,
- 87, 0, 87, 87, 87, 87, 87, 118, 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, 118, 0, 55, 0, 0,
- 55, 55, 55, 55, 55, 55, 0, 55, 125, 125,
- 125, 0, 0, 0, 0, 85, 0, 0, 55, 55,
- 0, 0, 55, 55, 11, 0, 0, 255, 12, 13,
- 0, 0, 0, 14, 15, 0, 0, 16, 16, 0,
- 0, 0, 0, 0, 0, 16, 0, 17, 18, 19,
- 0, 21, 85, 55, 55, 33, 85, 85, 85, 85,
- 85, 0, 85, 26, 0, 29, 30, 31, 32, 33,
- 23, 0, 55, 85, 85, 33, 0, 33, 33, 0,
- 124, 124, 124, 55, 55, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 297, 298,
- 299, 0, 0, 0, 0, 0, 0, 23, 85, 85,
- 23, 23, 23, 23, 23, 23, 0, 23, 311, 312,
- 0, 0, 0, 314, 0, 0, 0, 115, 23, 23,
- 23, 0, 23, 23, 0, 116, 116, 116, 85, 85,
- 0, 0, 0, 52, 0, 115, 0, 0, 0, 16,
- 0, 0, 0, 0, 0, 0, 0, 0, 88, 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, 117, 0, 0, 88, 0, 0, 88,
- 52, 0, 23, 33, 52, 52, 52, 52, 52, 0,
- 52, 117, 0, 23, 23, 16, 118, 118, 118, 0,
- 0, 52, 52, 33, 0, 33, 33, 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, 88, 55, 55, 55, 55, 55, 0, 55, 55,
+ 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, 33, 85, 85, 85, 33, 33,
- 85, 0, 0, 33, 33, 0, 0, 0, 0, 85,
- 0, 0, 0, 0, 0, 33, 0, 33, 33, 33,
- 85, 33, 0, 85, 33, 33, 33, 33, 33, 33,
- 33, 33, 0, 33, 0, 33, 33, 33, 33, 33,
+ 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, 115, 115, 115, 0,
+ 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, 16, 16, 88, 88, 88,
- 0, 0, 88, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 117, 117, 117, 0, 0, 0, 0, 0,
- 52, 52, 33, 52, 52, 52, 33, 33, 52, 0,
- 0, 33, 33, 51, 0, 0, 0, 52, 0, 0,
- 0, 16, 16, 33, 0, 33, 33, 33, 52, 33,
- 0, 52, 33, 33, 33, 33, 33, 33, 33, 33,
- 0, 33, 0, 33, 33, 33, 33, 33, 0, 0,
- 51, 0, 0, 33, 51, 51, 51, 51, 51, 0,
- 51, 0, 0, 0, 0, 0, 0, 41, 0, 0,
- 0, 51, 51, 33, 0, 33, 33, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 41, 0, 51, 33, 41, 41,
- 41, 41, 41, 0, 41, 0, 0, 0, 0, 0,
- 0, 42, 0, 0, 0, 41, 41, 33, 0, 33,
- 33, 0, 0, 0, 0, 0, 51, 51, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 42, 0,
- 41, 33, 42, 42, 42, 42, 42, 0, 42, 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,
- 42, 33, 0, 33, 33, 0, 0, 0, 0, 0,
- 41, 41, 0, 0, 0, 43, 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, 0, 43, 0, 0, 33, 43, 43, 43, 43,
- 43, 0, 43, 0, 42, 42, 0, 0, 0, 0,
- 0, 0, 0, 43, 43, 33, 0, 33, 33, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 51, 51, 33, 51, 51, 51, 33, 33, 51, 0,
- 0, 33, 33, 0, 0, 0, 0, 51, 43, 0,
- 0, 0, 0, 33, 0, 33, 33, 33, 51, 33,
- 0, 51, 33, 33, 33, 33, 33, 33, 33, 33,
- 0, 33, 0, 33, 33, 33, 33, 33, 43, 43,
- 0, 0, 0, 0, 41, 41, 33, 41, 41, 41,
- 33, 33, 41, 0, 0, 33, 33, 0, 0, 0,
- 0, 41, 0, 0, 0, 0, 0, 33, 0, 33,
- 33, 33, 41, 33, 0, 41, 33, 33, 33, 33,
- 33, 33, 33, 33, 0, 33, 0, 33, 33, 33,
- 33, 33, 0, 0, 0, 0, 0, 0, 42, 42,
- 33, 42, 42, 42, 33, 33, 42, 0, 0, 33,
- 33, 0, 0, 0, 0, 42, 0, 0, 0, 0,
- 0, 33, 0, 33, 33, 33, 42, 33, 0, 42,
- 33, 33, 33, 33, 33, 33, 33, 33, 0, 33,
- 0, 33, 33, 33, 33, 33, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 43, 43, 33, 43, 43, 43, 33, 33,
- 43, 0, 0, 33, 33, 44, 0, 0, 0, 43,
- 0, 0, 0, 0, 0, 33, 0, 33, 33, 33,
- 43, 33, 0, 43, 33, 33, 33, 33, 33, 33,
- 33, 33, 0, 33, 0, 33, 33, 33, 33, 33,
- 0, 0, 44, 0, 0, 33, 44, 44, 44, 44,
- 44, 0, 44, 0, 0, 0, 0, 0, 0, 36,
- 0, 0, 0, 44, 44, 33, 0, 33, 33, 0,
- 0, 0, 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, 0, 44, 36,
- 36, 36, 36, 36, 36, 0, 36, 0, 0, 0,
- 0, 0, 0, 0, 35, 0, 0, 36, 36, 36,
- 0, 36, 36, 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,
- 0, 35, 36, 36, 35, 35, 35, 35, 35, 35,
- 0, 35, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 36, 35, 35, 35, 0, 35, 0, 0, 0,
- 0, 0, 36, 36, 0, 0, 0, 39, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 35, 35, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 35, 33, 39, 0,
- 39, 39, 39, 0, 0, 0, 0, 35, 35, 0,
- 0, 0, 0, 0, 0, 39, 39, 33, 0, 33,
- 33, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 44, 44, 33, 44, 44, 44, 33, 33,
- 44, 0, 0, 33, 33, 0, 0, 0, 0, 44,
- 39, 0, 0, 0, 0, 33, 0, 33, 33, 33,
- 44, 33, 0, 44, 33, 33, 33, 33, 33, 33,
- 33, 33, 0, 33, 0, 33, 33, 33, 33, 33,
- 39, 39, 0, 0, 0, 0, 36, 36, 36, 36,
- 36, 36, 36, 36, 36, 0, 0, 36, 36, 0,
- 0, 0, 0, 36, 0, 0, 0, 0, 0, 36,
- 0, 36, 36, 36, 36, 36, 0, 0, 36, 36,
- 36, 36, 36, 36, 36, 36, 0, 36, 0, 36,
- 0, 0, 36, 36, 0, 0, 0, 0, 0, 0,
- 0, 35, 35, 35, 35, 35, 35, 35, 35, 35,
- 0, 0, 35, 35, 0, 0, 0, 0, 35, 0,
- 0, 0, 0, 0, 35, 14, 35, 35, 35, 35,
- 35, 0, 35, 0, 0, 35, 35, 35, 35, 35,
- 35, 0, 35, 0, 35, 35, 35, 35, 35, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 14, 0, 0, 14, 0,
- 14, 0, 0, 0, 39, 39, 33, 39, 39, 39,
- 33, 33, 39, 40, 14, 33, 33, 0, 0, 0,
- 0, 39, 0, 0, 0, 0, 0, 33, 0, 33,
- 33, 33, 39, 33, 0, 39, 33, 33, 33, 33,
- 33, 33, 33, 33, 0, 33, 0, 33, 33, 33,
- 33, 33, 0, 33, 40, 0, 40, 40, 40, 0,
- 0, 33, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 40, 40, 33, 0, 33, 33, 0, 14, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 33, 33, 0, 0, 33, 40, 0, 0, 34,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 33,
- 33, 33, 0, 33, 33, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 40, 40, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 33,
- 34, 0, 0, 34, 33, 0, 0, 0, 0, 0,
- 0, 15, 0, 0, 0, 0, 0, 34, 34, 33,
- 0, 33, 33, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 33, 33, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 15, 34, 0, 15, 0, 15, 0, 0, 0,
- 0, 0, 14, 14, 14, 14, 14, 14, 14, 14,
- 15, 0, 0, 14, 14, 0, 0, 0, 0, 0,
- 0, 0, 34, 34, 0, 14, 0, 14, 14, 14,
- 14, 14, 0, 0, 0, 0, 14, 14, 14, 14,
- 0, 0, 0, 14, 0, 14, 14, 14, 14, 14,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 40, 40, 33, 40, 40, 40, 33, 33, 40, 0,
- 0, 33, 33, 35, 15, 0, 27, 40, 28, 0,
- 0, 0, 0, 33, 6, 33, 33, 33, 40, 33,
- 0, 40, 33, 33, 33, 33, 33, 33, 33, 33,
- 0, 33, 0, 33, 33, 33, 33, 33, 33, 33,
- 33, 33, 33, 33, 33, 33, 33, 0, 0, 33,
- 33, 0, 0, 0, 6, 0, 0, 6, 0, 6,
- 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, 34, 34, 33, 34,
- 34, 34, 33, 33, 34, 0, 0, 33, 33, 0,
- 35, 103, 0, 27, 0, 28, 0, 0, 0, 33,
- 0, 33, 33, 33, 34, 33, 0, 34, 33, 33,
- 33, 33, 33, 33, 33, 33, 0, 33, 0, 33,
- 33, 33, 33, 33, 0, 0, 0, 6, 15, 15,
- 15, 15, 15, 15, 15, 15, 12, 0, 0, 15,
+ 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, 12, 0, 0, 12,
- 0, 12, 0, 0, 7, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 12, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 11, 0, 123, 124, 12, 13, 0, 0,
- 0, 14, 15, 0, 7, 0, 0, 7, 0, 7,
- 0, 0, 0, 16, 5, 17, 18, 19, 0, 21,
- 0, 0, 0, 7, 22, 23, 24, 25, 0, 0,
- 0, 26, 0, 29, 30, 31, 32, 33, 0, 12,
- 0, 6, 6, 6, 0, 0, 0, 6, 6, 0,
- 0, 0, 6, 6, 5, 0, 0, 5, 0, 5,
- 0, 0, 0, 2, 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, 11,
- 0, 0, 0, 12, 13, 0, 0, 0, 14, 15,
- 0, 0, 0, 2, 0, 0, 2, 0, 2, 0,
- 16, 0, 17, 18, 19, 0, 21, 0, 0, 0,
- 0, 22, 23, 24, 25, 0, 0, 0, 26, 0,
- 29, 30, 31, 32, 33, 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,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 12, 12, 12, 12, 0, 12, 12,
- 12, 0, 0, 0, 12, 12, 2, 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, 7, 7, 7, 7, 7, 7, 7, 7, 0,
- 0, 0, 7, 7, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 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, 0,
+ 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, 0, 0, 0, 0,
- 0, 0, 0, 0, 5, 0, 5, 5, 5, 5,
- 5, 0, 0, 0, 0, 5, 5, 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,
- 2, 2, 2, 0, 0, 0, 2, 2, 0, 0,
- 0, 2, 2, 58, 0, 0, 0, 0, 0, 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, 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, 0, 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, 0, 0, 0, 0, 0, 0, 0,
- 0, 54, 54, 0, 0, 0, 0, 56, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 54, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 54, 54, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 56, 0, 0, 0, 56, 56,
- 0, 56, 0, 0, 56, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 56, 56, 56, 0, 56,
- 16, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 56, 56, 0, 0, 0, 0, 0, 0, 0, 0,
- 58, 58, 58, 58, 58, 58, 58, 58, 58, 56,
- 0, 58, 58, 0, 0, 0, 0, 58, 0, 0,
- 56, 56, 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, 54, 0,
- 0, 0, 54, 0, 0, 0, 0, 0, 54, 0,
- 54, 54, 54, 54, 54, 0, 54, 54, 54, 54,
- 0, 54, 54, 54, 54, 0, 54, 0, 54, 54,
- 54, 0, 0, 104, 54, 106, 0, 0, 0, 0,
- 110, 111, 0, 114, 116, 117, 0, 54, 54, 121,
- 122, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 132, 0, 0, 0, 137,
- 138, 139, 140, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 56, 56, 0, 56, 56, 56,
- 0, 0, 56, 0, 0, 0, 158, 0, 0, 0,
- 0, 56, 54, 0, 0, 0, 0, 0, 0, 186,
- 0, 0, 56, 0, 0, 56, 16, 16, 56, 56,
- 56, 56, 56, 56, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 186, 186, 0, 0, 0, 197,
- 198, 0, 0, 200, 201, 202, 203, 205, 0, 0,
- 0, 0, 207, 208, 0, 54, 54, 0, 0, 0,
- 215, 0, 0, 0, 216, 0, 25, 0, 0, 0,
- 0, 0, 0, 0, 186, 227, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 252, 0,
- 0, 186, 0, 25, 0, 0, 27, 25, 25, 0,
- 25, 0, 0, 25, 264, 0, 265, 0, 266, 0,
- 267, 0, 268, 0, 25, 25, 25, 270, 25, 16,
- 0, 0, 271, 272, 0, 0, 0, 0, 0, 0,
- 54, 186, 0, 27, 0, 0, 0, 27, 27, 0,
- 27, 0, 0, 27, 26, 0, 0, 0, 0, 25,
- 25, 0, 0, 0, 27, 27, 27, 0, 27, 16,
- 0, 0, 186, 186, 186, 186, 0, 0, 25, 0,
- 186, 0, 0, 0, 0, 186, 0, 0, 0, 25,
- 25, 26, 186, 186, 57, 26, 26, 186, 26, 27,
- 27, 26, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 26, 26, 26, 0, 26, 16, 27, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 27,
- 27, 57, 0, 0, 0, 57, 57, 0, 57, 0,
- 0, 57, 0, 0, 0, 0, 0, 26, 26, 0,
- 0, 0, 57, 57, 57, 0, 57, 16, 0, 0,
- 0, 0, 0, 0, 0, 0, 26, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 26, 26, 35,
- 0, 0, 27, 0, 28, 0, 0, 57, 57, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 87,
- 0, 88, 0, 0, 0, 0, 57, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 57, 57, 0,
- 0, 0, 0, 25, 25, 0, 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, 16, 16, 25, 25, 25,
- 25, 25, 25, 27, 27, 0, 27, 27, 27, 0,
- 0, 27, 0, 0, 0, 0, 0, 0, 0, 0,
- 27, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 27, 0, 0, 27, 16, 16, 27, 27, 27,
- 27, 27, 27, 0, 0, 0, 0, 0, 0, 0,
- 0, 26, 26, 0, 26, 26, 26, 0, 0, 26,
- 0, 0, 0, 0, 0, 0, 0, 0, 26, 0,
- 0, 0, 0, 88, 0, 0, 0, 0, 0, 26,
- 0, 0, 26, 16, 16, 26, 26, 26, 26, 26,
- 26, 57, 57, 0, 57, 57, 57, 0, 0, 57,
- 0, 0, 0, 0, 0, 0, 0, 0, 57, 0,
- 88, 0, 0, 29, 88, 88, 0, 88, 0, 57,
- 88, 0, 57, 16, 16, 57, 57, 57, 57, 57,
- 57, 88, 88, 88, 0, 88, 88, 0, 11, 0,
+ 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,
- 29, 0, 0, 0, 29, 29, 0, 29, 16, 16,
- 29, 17, 18, 19, 0, 21, 88, 88, 0, 0,
- 0, 29, 29, 0, 0, 86, 16, 26, 0, 29,
- 30, 31, 32, 33, 0, 88, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 16, 88, 88, 89, 16,
- 16, 0, 16, 0, 0, 16, 29, 29, 0, 0,
- 0, 0, 0, 0, 0, 0, 16, 16, 0, 0,
- 0, 16, 0, 0, 0, 29, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 89, 29, 29, 0, 89,
- 89, 0, 89, 90, 0, 89, 0, 0, 0, 0,
- 0, 16, 16, 0, 0, 0, 89, 89, 0, 0,
- 0, 16, 0, 0, 0, 0, 0, 0, 0, 0,
- 16, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 90, 16, 16, 0, 90, 90, 0, 90, 0, 0,
- 90, 89, 89, 0, 0, 0, 0, 0, 0, 0,
- 0, 90, 90, 0, 0, 0, 16, 0, 0, 0,
- 89, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 89, 89, 0, 35, 231, 0, 27, 232, 28,
- 88, 88, 0, 88, 88, 88, 90, 90, 88, 0,
- 0, 0, 0, 0, 87, 0, 88, 88, 0, 0,
- 0, 0, 0, 0, 0, 90, 0, 0, 88, 0,
- 0, 88, 88, 88, 0, 0, 90, 90, 88, 88,
- 29, 29, 0, 29, 29, 29, 0, 0, 29, 0,
- 0, 0, 0, 0, 0, 0, 0, 29, 0, 0,
- 35, 0, 0, 27, 0, 28, 0, 0, 29, 0,
- 0, 29, 16, 16, 29, 29, 29, 29, 29, 185,
- 0, 0, 0, 0, 0, 16, 16, 0, 16, 16,
- 16, 0, 0, 16, 0, 0, 0, 0, 0, 0,
- 0, 0, 16, 20, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 16, 0, 0, 16, 16, 16, 0,
- 0, 0, 0, 0, 0, 89, 89, 0, 89, 89,
- 89, 0, 0, 89, 0, 0, 0, 0, 0, 0,
- 20, 0, 89, 183, 20, 20, 0, 20, 86, 0,
- 20, 0, 0, 89, 0, 0, 89, 16, 16, 0,
- 0, 20, 20, 0, 0, 0, 16, 0, 0, 0,
- 90, 90, 0, 90, 90, 90, 0, 0, 90, 0,
- 0, 0, 0, 0, 0, 86, 0, 90, 0, 86,
- 86, 0, 0, 0, 0, 86, 20, 20, 90, 0,
- 0, 90, 16, 16, 0, 0, 86, 86, 0, 0,
- 0, 16, 0, 11, 0, 20, 0, 12, 13, 0,
- 0, 0, 14, 15, 0, 110, 20, 20, 110, 0,
- 110, 0, 0, 0, 16, 0, 17, 18, 19, 0,
- 21, 86, 86, 0, 110, 22, 23, 24, 25, 85,
- 86, 0, 26, 0, 29, 30, 31, 32, 33, 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, 86, 0, 0, 0, 0, 0, 0, 11,
- 170, 123, 124, 12, 13, 0, 171, 172, 14, 15,
- 173, 0, 174, 175, 0, 176, 177, 178, 179, 180,
- 16, 181, 17, 18, 19, 0, 21, 182, 110, 0,
- 110, 22, 23, 24, 25, 0, 0, 0, 26, 0,
- 29, 30, 31, 32, 33, 0, 0, 0, 0, 109,
- 0, 0, 109, 0, 109, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 109, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 20, 20, 0, 20, 20, 20, 0, 0, 20, 0,
- 0, 0, 0, 0, 0, 0, 0, 20, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 20, 0,
- 0, 20, 16, 16, 0, 0, 0, 103, 0, 0,
- 103, 0, 103, 0, 0, 86, 86, 0, 86, 86,
- 86, 0, 109, 86, 109, 0, 103, 0, 0, 0,
- 0, 0, 86, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 86, 0, 0, 86, 16, 16, 0,
- 0, 0, 0, 0, 110, 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,
- 103, 0, 103, 110, 0, 110, 110, 110, 110, 110,
- 0, 0, 0, 0, 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, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 51, 0, 0, 27, 0, 28, 109, 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, 104, 0, 104,
- 109, 109, 109, 109, 0, 0, 0, 109, 0, 109,
- 109, 109, 109, 109, 105, 0, 0, 105, 0, 105,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 105, 0, 0, 103, 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, 103, 103, 103,
- 103, 103, 0, 0, 0, 0, 102, 0, 0, 102,
- 0, 102, 0, 0, 0, 0, 0, 105, 0, 105,
- 0, 0, 0, 0, 0, 102, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 104, 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, 0, 0, 0, 104, 104, 104, 104, 102,
- 0, 102, 104, 0, 104, 104, 104, 104, 104, 108,
- 0, 11, 108, 0, 108, 12, 13, 0, 0, 0,
- 14, 15, 0, 0, 0, 0, 0, 0, 108, 0,
- 0, 0, 16, 0, 17, 18, 19, 0, 21, 0,
- 0, 0, 0, 22, 23, 24, 25, 0, 0, 0,
- 26, 0, 29, 30, 31, 32, 33, 35, 0, 0,
- 27, 0, 28, 105, 105, 0, 0, 105, 105, 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, 108, 0, 108, 105, 105, 105, 105, 0,
- 0, 0, 105, 0, 105, 105, 105, 105, 105, 137,
- 0, 0, 137, 0, 137, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 137, 0,
- 0, 0, 0, 0, 0, 102, 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, 0, 102, 102, 0, 0, 0, 102, 102, 102,
- 102, 0, 0, 0, 102, 0, 102, 102, 102, 102,
- 102, 35, 0, 0, 27, 0, 28, 0, 0, 0,
- 0, 0, 137, 0, 137, 0, 0, 0, 0, 0,
- 185, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 108, 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, 183, 0, 184, 108, 0, 108,
- 108, 108, 108, 108, 35, 0, 11, 27, 0, 28,
- 12, 13, 0, 0, 0, 14, 15, 0, 0, 0,
- 0, 0, 0, 185, 0, 0, 0, 16, 0, 17,
- 18, 19, 0, 21, 0, 0, 0, 0, 22, 23,
- 24, 25, 0, 0, 0, 26, 0, 29, 30, 31,
- 32, 33, 35, 0, 0, 27, 0, 28, 137, 137,
- 0, 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, 183, 0, 195,
- 137, 137, 137, 137, 0, 0, 0, 137, 0, 137,
- 137, 137, 137, 137, 35, 0, 0, 27, 0, 28,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 185, 0, 0, 0, 0, 0, 0,
- 11, 170, 0, 0, 12, 13, 0, 171, 172, 14,
- 15, 173, 0, 174, 175, 0, 176, 177, 178, 179,
- 180, 16, 181, 17, 18, 19, 0, 21, 182, 0,
- 0, 0, 22, 23, 24, 25, 0, 0, 0, 26,
- 0, 29, 30, 31, 32, 33, 35, 0, 0, 27,
- 0, 28, 0, 0, 0, 0, 0, 183, 0, 196,
- 0, 0, 0, 0, 0, 185, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 11, 170, 0, 0, 12, 13, 0,
- 171, 172, 14, 15, 173, 0, 174, 175, 0, 176,
- 177, 178, 179, 180, 16, 181, 17, 18, 19, 0,
- 21, 182, 0, 0, 0, 22, 23, 24, 25, 183,
- 0, 226, 26, 0, 29, 30, 31, 32, 33, 35,
- 0, 113, 27, 0, 28, 12, 13, 0, 0, 0,
- 14, 15, 0, 0, 0, 0, 0, 0, 185, 0,
- 0, 0, 16, 0, 17, 18, 19, 0, 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, 11, 170, 0, 0, 12, 13, 0,
- 171, 172, 14, 15, 173, 0, 174, 175, 0, 176,
- 177, 178, 179, 180, 16, 181, 17, 18, 19, 0,
- 21, 182, 183, 0, 279, 22, 23, 24, 25, 0,
- 0, 0, 26, 0, 29, 30, 31, 32, 33, 35,
- 0, 0, 27, 0, 28, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 185, 0,
- 0, 0, 0, 0, 0, 11, 170, 0, 0, 12,
- 13, 0, 171, 172, 14, 15, 173, 0, 174, 175,
- 0, 176, 177, 178, 179, 180, 16, 181, 17, 18,
- 19, 0, 21, 182, 0, 0, 0, 22, 23, 24,
- 25, 0, 0, 0, 26, 0, 29, 30, 31, 32,
- 33, 107, 0, 0, 107, 0, 107, 0, 0, 0,
- 0, 0, 183, 0, 303, 0, 0, 0, 0, 0,
- 107, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 11, 170,
- 0, 0, 12, 13, 0, 171, 172, 14, 15, 173,
- 0, 174, 175, 0, 176, 177, 178, 179, 180, 16,
- 181, 17, 18, 19, 0, 21, 182, 0, 0, 0,
- 22, 23, 24, 25, 107, 0, 107, 26, 0, 29,
- 30, 31, 32, 33, 130, 0, 0, 130, 0, 130,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 130, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 35, 0, 0, 27, 0, 28, 0, 0, 11, 170,
- 0, 0, 12, 13, 0, 171, 172, 14, 15, 173,
- 0, 174, 175, 0, 176, 177, 178, 179, 180, 16,
- 181, 17, 18, 19, 0, 21, 182, 130, 0, 130,
- 22, 23, 24, 25, 0, 0, 0, 26, 0, 29,
- 30, 31, 32, 33, 35, 233, 0, 27, 234, 28,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 87, 0, 88, 0, 0, 0,
- 107, 107, 0, 0, 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, 107, 107, 107, 107, 107, 35, 235, 0, 27,
- 236, 28, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 87, 0, 88, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 130, 130, 0, 0, 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, 130, 130, 130, 130, 130, 11,
- 0, 0, 0, 12, 13, 0, 171, 172, 14, 15,
- 0, 0, 0, 0, 0, 176, 177, 178, 179, 180,
- 16, 0, 17, 18, 19, 0, 21, 182, 0, 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,
- 29, 30, 31, 32, 33, 35, 237, 0, 27, 238,
- 28, 0, 0, 11, 0, 0, 0, 12, 13, 0,
- 0, 0, 14, 15, 0, 87, 0, 88, 0, 0,
- 0, 0, 0, 0, 16, 0, 17, 18, 19, 0,
- 21, 0, 0, 0, 0, 22, 23, 24, 25, 85,
- 86, 0, 26, 0, 29, 30, 31, 32, 33, 35,
- 242, 0, 27, 243, 28, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 87,
- 0, 88, 0, 0, 0, 11, 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, 35, 21, 0, 27, 108, 28, 22, 23, 24,
- 25, 85, 86, 0, 26, 0, 29, 30, 31, 32,
- 33, 87, 0, 88, 0, 0, 0, 0, 0, 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,
- 0, 0, 0, 0, 0, 0, 0, 35, 152, 0,
- 27, 0, 28, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 87, 0, 88,
+ 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, 35, 0, 0, 27, 157, 28, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 87, 11, 88, 0, 0, 12, 13,
- 0, 0, 0, 14, 15, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 16, 0, 17, 18, 19,
- 35, 21, 0, 27, 160, 28, 22, 23, 24, 25,
- 85, 86, 0, 26, 0, 29, 30, 31, 32, 33,
- 87, 0, 88, 0, 0, 0, 0, 0, 11, 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, 35, 21, 0, 27, 162, 28,
- 22, 23, 24, 25, 85, 86, 0, 26, 0, 29,
- 30, 31, 32, 33, 87, 0, 88, 0, 0, 0,
- 11, 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, 85, 86, 0, 26,
- 0, 29, 30, 31, 32, 33, 11, 0, 0, 0,
- 12, 13, 0, 0, 35, 14, 15, 27, 163, 28,
- 0, 0, 0, 0, 0, 0, 0, 16, 0, 17,
- 18, 19, 0, 21, 87, 0, 88, 0, 22, 23,
- 24, 25, 85, 86, 0, 26, 0, 29, 30, 31,
- 32, 33, 11, 0, 0, 0, 12, 13, 0, 0,
- 35, 14, 15, 27, 168, 28, 0, 0, 0, 0,
- 0, 0, 0, 16, 0, 17, 18, 19, 0, 21,
- 87, 0, 88, 0, 22, 23, 24, 25, 85, 86,
- 0, 26, 0, 29, 30, 31, 32, 33, 0, 11,
- 0, 0, 0, 12, 13, 0, 0, 35, 14, 15,
- 27, 169, 28, 0, 0, 0, 0, 0, 0, 0,
- 16, 0, 17, 18, 19, 0, 21, 87, 0, 88,
- 0, 22, 23, 24, 25, 85, 86, 0, 26, 0,
- 29, 30, 31, 32, 33, 0, 0, 0, 0, 0,
- 0, 0, 0, 11, 0, 0, 0, 12, 13, 0,
- 0, 35, 14, 15, 27, 0, 28, 0, 0, 0,
- 0, 0, 0, 0, 16, 0, 17, 18, 19, 191,
- 21, 87, 0, 88, 0, 22, 23, 24, 25, 85,
- 86, 0, 26, 0, 29, 30, 31, 32, 33, 0,
- 0, 0, 0, 0, 0, 0, 0, 35, 240, 0,
- 27, 0, 28, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 87, 0, 88,
- 0, 0, 0, 11, 0, 0, 0, 12, 13, 0,
- 0, 0, 14, 15, 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, 85,
- 86, 0, 26, 0, 29, 30, 31, 32, 33, 11,
- 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, 85, 86, 0, 26, 0,
- 29, 30, 31, 32, 33, 0, 11, 0, 0, 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, 0, 21, 0, 0, 0, 0, 22, 23,
- 24, 25, 85, 86, 0, 26, 0, 29, 30, 31,
- 32, 33, 35, 244, 0, 27, 0, 28, 0, 0,
+ 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, 87, 0, 88, 0, 0, 0, 0, 0,
+ 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, 85, 86, 0, 26,
- 0, 29, 30, 31, 32, 33, 11, 0, 0, 0,
- 12, 13, 0, 0, 0, 14, 15, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 16, 0, 17,
+ 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, 85, 86, 0, 26, 0, 29, 30, 31,
- 32, 33, 35, 275, 0, 27, 0, 28, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 87, 0, 88, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 35, 281,
- 0, 27, 0, 28, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 87, 0,
- 88, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 35, 282, 0, 27, 0, 28,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 87, 0, 88, 0, 0, 0,
- 0, 11, 0, 0, 0, 12, 13, 0, 0, 0,
- 14, 15, 0, 0, 0, 0, 0, 0, 0, 0,
+ 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, 85, 86, 0,
- 26, 0, 29, 30, 31, 32, 33, 35, 283, 0,
- 27, 0, 28, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 87, 0, 88,
+ 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, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 35, 284, 0, 27, 0, 28, 0,
- 0, 11, 0, 0, 0, 12, 13, 0, 0, 0,
- 14, 15, 0, 87, 0, 88, 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, 85, 86, 0,
- 26, 0, 29, 30, 31, 32, 33, 11, 0, 0,
- 0, 12, 13, 0, 0, 0, 14, 15, 35, 0,
- 0, 27, 0, 28, 0, 0, 0, 0, 16, 0,
- 17, 18, 19, 0, 21, 0, 0, 0, 0, 22,
- 23, 24, 25, 85, 86, 0, 26, 0, 29, 30,
- 31, 32, 33, 11, 0, 0, 0, 12, 13, 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, 0,
- 21, 0, 0, 0, 0, 22, 23, 24, 25, 85,
- 86, 0, 26, 0, 29, 30, 31, 32, 33, 35,
- 285, 34, 27, 0, 28, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 87,
- 0, 88, 0, 0, 0, 0, 11, 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, 35, 21, 0, 27, 0, 28, 22, 23,
- 24, 25, 85, 86, 0, 26, 0, 29, 30, 31,
- 32, 33, 11, 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, 85, 86,
- 0, 26, 0, 29, 30, 31, 32, 33, 35, 287,
- 0, 27, 0, 28, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 9, 10, 11, 87, 0,
- 88, 12, 13, 0, 0, 0, 14, 15, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 16, 0,
- 17, 18, 19, 20, 21, 0, 0, 0, 0, 22,
- 23, 24, 25, 0, 0, 0, 26, 0, 29, 30,
- 31, 32, 33, 35, 0, 0, 27, 0, 28, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 87, 0, 88, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 11, 0,
- 0, 0, 12, 13, 0, 0, 0, 14, 15, 35,
- 0, 0, 27, 0, 28, 0, 0, 0, 0, 16,
- 0, 17, 18, 19, 0, 21, 0, 0, 291, 0,
- 22, 23, 24, 25, 85, 86, 0, 26, 0, 29,
- 30, 31, 32, 33, 0, 0, 0, 0, 0, 0,
- 0, 115, 0, 0, 0, 12, 13, 0, 0, 35,
- 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, 29, 30, 31, 32, 33, 0, 0, 0,
- 0, 0, 0, 0, 0, 35, 0, 0, 27, 0,
- 28, 0, 0, 0, 0, 0, 0, 11, 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, 85, 86, 0, 26, 0, 29, 30,
- 31, 32, 33, 35, 0, 0, 27, 0, 28, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 11, 0, 0, 0, 12, 13, 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, 85, 86,
- 0, 26, 0, 29, 30, 31, 32, 33, 11, 0,
- 0, 0, 12, 13, 0, 0, 0, 14, 15, 0,
+ 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, 0, 21, 0, 0, 0, 0,
- 22, 23, 24, 25, 0, 0, 0, 26, 0, 29,
- 30, 31, 32, 33, 0, 0, 0, 0, 136, 0,
+ 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, 29,
- 30, 31, 32, 33, 204, 0, 0, 0, 12, 13,
- 0, 0, 0, 14, 15, 0, 0, 101, 102, 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, 29, 30, 31, 32, 33,
- 131, 0, 133, 134, 0, 0, 0, 0, 0, 0,
- 0, 0, 263, 0, 0, 0, 12, 13, 0, 0,
- 0, 14, 15, 0, 0, 0, 0, 0, 155, 156,
- 0, 0, 0, 16, 0, 17, 18, 19, 0, 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, 67,
- 68, 0, 0, 0, 0, 72, 0, 0, 0, 0,
- 0, 0, 0, 89, 0, 0, 0, 0, 0, 0,
- 209, 0, 0, 0, 0, 0, 89, 0, 0, 0,
- 0, 217, 0, 219, 0, 220, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 241, 0, 0, 0,
- 0, 0, 0, 142, 143, 144, 145, 146, 147, 0,
- 0, 258, 259, 260, 261, 262, 89, 0, 89, 0,
- 0, 0, 89, 89, 0, 0, 89, 0, 89, 89,
- 0, 0, 0, 89, 89, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 89, 0, 0, 0, 0, 89,
- 89, 89, 89, 0, 0, 0, 0, 0, 0, 286,
- 0, 0, 0, 288, 289, 290, 0, 0, 0, 295,
- 89, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 308, 309, 0, 0, 89, 0,
- 313, 0, 0, 0, 0, 0, 0, 0, 0, 89,
- 89, 0, 89, 89, 89, 89, 0, 89, 0, 89,
- 89, 0, 0, 0, 0, 0, 0, 89, 89, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 89,
- 0, 0, 0, 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, 0, 0,
- 0, 0, 0, 0, 0, 0, 89, 89, 89, 89,
- 89, 0, 89, 89, 89,
+ 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, 123, 62, 123, 41, 59, 41, 59, 214, 63,
- 59, 63, 123, 63, 59, 63, 94, 59, 50, 38,
- 35, 63, 35, 291, 41, 286, 63, 41, 63, 91,
- 41, 63, 64, 301, 112, 40, 51, 37, 51, 7,
- 40, 41, 42, 43, 44, 45, 63, 47, 59, 63,
- 35, 41, 63, 41, 44, 0, 44, 41, 58, 59,
- 60, 29, 62, 63, 124, 44, 51, 35, 261, 262,
- 37, 40, 261, 60, 288, 42, 43, 40, 45, 63,
- 47, 101, 102, 51, 63, 291, 118, 301, 302, 60,
- 40, 16, 37, 93, 94, 301, 41, 42, 43, 44,
- 45, 63, 47, 40, 63, 30, 31, 40, 292, 40,
- 0, 131, 112, 58, 59, 60, 84, 62, 63, 303,
- 304, 40, 40, 123, 124, 123, 40, 94, 44, 112,
- 98, 41, 41, 37, 63, 41, 63, 292, 42, 171,
- 172, 261, 262, 47, 280, 112, 41, 37, 93, 94,
- 40, 41, 42, 43, 41, 45, 44, 47, 44, 93,
- 292, 41, 41, 40, 40, 133, 134, 112, 58, 59,
- 60, 40, 62, 63, 292, 290, 195, 41, 123, 124,
- 59, 59, 272, 91, 41, 40, 93, 271, 41, 41,
- 94, 0, 41, 93, 59, 41, -1, 51, -1, 219,
- -1, 211, -1, 93, 94, 265, -1, -1, 112, 41,
- -1, 260, 261, 262, -1, 260, 261, 262, 260, 261,
- 262, -1, 112, 148, 256, 40, -1, 59, 43, -1,
- 45, 63, -1, 123, 124, 289, 290, 289, 290, 289,
- 290, 289, 290, -1, 212, 213, -1, 289, 290, 260,
- 261, 262, 289, 290, 289, 290, -1, 257, 258, 259,
- 260, 261, 262, 263, 264, 265, 286, -1, 268, 269,
- -1, -1, 289, 290, 274, 289, 290, -1, 289, 290,
- 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, 289, 290, 274, 276, -1,
- 289, 290, 257, 258, 259, 260, 261, 262, 263, 264,
- 265, 292, -1, 268, 269, 293, -1, 289, 290, 274,
- 289, 290, 303, 304, -1, 280, 41, 282, 283, 284,
+ 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,
- 289, 290, 289, 290, -1, -1, -1, 257, 258, 259,
+ 260, 261, 262, 260, 261, 262, -1, 257, 258, 259,
260, 261, 262, 263, 264, 265, -1, -1, 268, 269,
- 0, 260, 261, 262, 274, -1, -1, -1, -1, -1,
+ 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, 260, 261,
- 262, -1, -1, -1, -1, 0, -1, -1, 58, 59,
- -1, -1, 62, 63, 259, -1, -1, 217, 263, 264,
- -1, -1, -1, 268, 269, -1, -1, 289, 290, -1,
- -1, -1, -1, -1, -1, 280, -1, 282, 283, 284,
- -1, 286, 37, 93, 94, 40, 41, 42, 43, 44,
- 45, -1, 47, 298, -1, 300, 301, 302, 303, 304,
+ 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, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 288, 289,
- 290, -1, -1, -1, -1, -1, -1, 37, 93, 94,
- 40, 41, 42, 43, 44, 45, -1, 47, 308, 309,
- -1, -1, -1, 313, -1, -1, -1, 41, 58, 59,
+ 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, 59, -1, -1, -1, 63,
- -1, -1, -1, -1, -1, -1, -1, -1, 41, -1,
+ -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, 41, -1, -1, 59, -1, -1, 62,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
37, -1, 112, 40, 41, 42, 43, 44, 45, -1,
- 47, 59, -1, 123, 124, 63, 260, 261, 262, -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, 124, 282, 283, 284, 285, 286, -1, 288, 289,
+ 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,
@@ -1059,695 +1089,725 @@ short yycheck[] = { 41,
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, 260, 261, 262, -1,
+ -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, 289, 290, 260, 261, 262,
- -1, -1, 265, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 260, 261, 262, -1, -1, -1, -1, -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, 289, 290, 280, -1, 282, 283, 284, 285, 286,
+ -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, 0, -1, -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, 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, 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,
- -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, -1, 0, -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, 93, -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, 123, 124, -1, -1, -1, -1,
+ 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, 301, 302, 303, 304, 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, 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, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -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, -1, 47, -1, -1, -1, -1, -1, -1, 0,
+ 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, -1, 0, -1, -1, 58, 59, 60,
+ -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,
- -1, 37, 93, 94, 40, 41, 42, 43, 44, 45,
- -1, 47, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 112, 58, 59, 60, -1, 62, -1, -1, -1,
- -1, -1, 123, 124, -1, -1, -1, 0, -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, 93, 94, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 112, 40, 41, -1,
- 43, 44, 45, -1, -1, -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,
+ -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,
- 123, 124, -1, -1, -1, -1, 257, 258, 259, 260,
+ -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, -1, 289, 290,
+ -1, 282, 283, 284, 285, 286, -1, 288, 289, 290,
291, 292, 293, 294, 295, 296, -1, 298, -1, 300,
- -1, -1, 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, 0, 282, 283, 284, 285,
- 286, -1, 288, -1, -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, 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, -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, 41, -1, 43, 44, 45, -1,
- -1, 0, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 58, 59, 60, -1, 62, 63, -1, 123, -1,
+ 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, 40, 41, -1, -1, 44, 93, -1, -1, 0,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 58,
- 59, 60, -1, 62, 63, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 123, 124, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 40,
- 41, -1, -1, 44, 93, -1, -1, -1, -1, -1,
- -1, 0, -1, -1, -1, -1, -1, 58, 59, 60,
+ -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, -1, -1, -1, 123, 124, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 40, 93, -1, 43, -1, 45, -1, -1, -1,
- -1, -1, 257, 258, 259, 260, 261, 262, 263, 264,
- 59, -1, -1, 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,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 257, 258, 259, 260, 261, 262, 263, 264, 265, -1,
- -1, 268, 269, 40, 123, -1, 43, 274, 45, -1,
- -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, 257, 258,
- 259, 260, 261, 262, 263, 264, 265, -1, -1, 268,
- 269, -1, -1, -1, 40, -1, -1, 43, -1, 45,
- -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, -1, -1, 268, 269, -1,
- 40, 41, -1, 43, -1, 45, -1, -1, -1, 280,
+ -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, -1, -1, -1, 123, 257, 258,
- 259, 260, 261, 262, 263, 264, 0, -1, -1, 268,
- 269, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 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, 40, -1, -1, 43,
- -1, 45, -1, -1, 0, -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, 259, -1, 261, 262, 263, 264, -1, -1,
- -1, 268, 269, -1, 40, -1, -1, 43, -1, 45,
- -1, -1, -1, 280, 0, 282, 283, 284, -1, 286,
- -1, -1, -1, 59, 291, 292, 293, 294, -1, -1,
- -1, 298, -1, 300, 301, 302, 303, 304, -1, 123,
- -1, 257, 258, 259, -1, -1, -1, 263, 264, -1,
- -1, -1, 268, 269, 40, -1, -1, 43, -1, 45,
- -1, -1, -1, 0, 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, 259,
- -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,
- 300, 301, 302, 303, 304, -1, -1, 123, -1, -1,
+ -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,
- -1, -1, -1, 257, 258, 259, 260, -1, 262, 263,
- 264, -1, -1, -1, 268, 269, 123, -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, 257, 258, 259, 260, 261, 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,
+ 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, -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, 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,
- 257, 258, 259, -1, -1, -1, 263, 264, -1, -1,
- -1, 268, 269, 0, -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,
- 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, -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, -1, -1, -1, -1, -1, -1, -1,
- -1, 93, 94, -1, -1, -1, -1, 0, -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,
- 112, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 123, 124, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 37, -1, -1, -1, 41, 42,
- -1, 44, -1, -1, 47, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 58, 59, 60, -1, 62,
+ -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,
- 257, 258, 259, 260, 261, 262, 263, 264, 265, 112,
- -1, 268, 269, -1, -1, -1, -1, 274, -1, -1,
- 123, 124, -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, 14, -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, 49, 50, 51, -1, -1, -1, -1,
- 56, 57, -1, 59, 60, 61, -1, 63, 64, 65,
- 66, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 81, -1, -1, -1, 85,
- 86, 87, 88, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 257, 258, -1, 260, 261, 262,
- -1, -1, 265, -1, -1, -1, 112, -1, -1, -1,
- -1, 274, 118, -1, -1, -1, -1, -1, -1, 125,
+ -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, -1, -1, -1,
- -1, -1, -1, -1, 150, 151, -1, -1, -1, 155,
- 156, -1, -1, 159, 160, 161, 162, 163, -1, -1,
- -1, -1, 168, 169, -1, 171, 172, -1, -1, -1,
- 176, -1, -1, -1, 180, -1, 0, -1, -1, -1,
- -1, -1, -1, -1, 190, 191, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 214, -1,
- -1, 217, -1, 37, -1, -1, 0, 41, 42, -1,
- 44, -1, -1, 47, 230, -1, 232, -1, 234, -1,
- 236, -1, 238, -1, 58, 59, 60, 243, 62, 63,
- -1, -1, 248, 249, -1, -1, -1, -1, -1, -1,
- 256, 257, -1, 37, -1, -1, -1, 41, 42, -1,
- 44, -1, -1, 47, 0, -1, -1, -1, -1, 93,
- 94, -1, -1, -1, 58, 59, 60, -1, 62, 63,
- -1, -1, 288, 289, 290, 291, -1, -1, 112, -1,
- 296, -1, -1, -1, -1, 301, -1, -1, -1, 123,
- 124, 37, 308, 309, 0, 41, 42, 313, 44, 93,
- 94, 47, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 58, 59, 60, -1, 62, 63, 112, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 123,
- 124, 37, -1, -1, -1, 41, 42, -1, 44, -1,
- -1, 47, -1, -1, -1, -1, -1, 93, 94, -1,
- -1, -1, 58, 59, 60, -1, 62, 63, -1, -1,
- -1, -1, -1, -1, -1, -1, 112, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 123, 124, 40,
- -1, -1, 43, -1, 45, -1, -1, 93, 94, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 60,
- -1, 62, -1, -1, -1, -1, 112, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 123, 124, -1,
- -1, -1, -1, 257, 258, -1, 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, 257, 258, -1, 260, 261, 262, -1,
- -1, 265, -1, -1, -1, -1, -1, -1, -1, -1,
- 274, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ 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, -1, -1, -1, -1,
- -1, 257, 258, -1, 260, 261, 262, -1, -1, 265,
- -1, -1, -1, -1, -1, -1, -1, -1, 274, -1,
- -1, -1, -1, 0, -1, -1, -1, -1, -1, 285,
+ 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, 257, 258, -1, 260, 261, 262, -1, -1, 265,
- -1, -1, -1, -1, -1, -1, -1, -1, 274, -1,
- 37, -1, -1, 0, 41, 42, -1, 44, -1, 285,
- 47, -1, 288, 289, 290, 291, 292, 293, 294, 295,
- 296, 58, 59, 60, -1, 62, 63, -1, 259, -1,
+ 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,
- 37, -1, -1, -1, 41, 42, -1, 44, 0, 280,
- 47, 282, 283, 284, -1, 286, 93, 94, -1, -1,
- -1, 58, 59, -1, -1, 296, 63, 298, -1, 300,
- 301, 302, 303, 304, -1, 112, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 37, 123, 124, 0, 41,
- 42, -1, 44, -1, -1, 47, 93, 94, -1, -1,
- -1, -1, -1, -1, -1, -1, 58, 59, -1, -1,
- -1, 63, -1, -1, -1, 112, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 37, 123, 124, -1, 41,
- 42, -1, 44, 0, -1, 47, -1, -1, -1, -1,
- -1, 93, 94, -1, -1, -1, 58, 59, -1, -1,
- -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
- 112, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 37, 123, 124, -1, 41, 42, -1, 44, -1, -1,
- 47, 93, 94, -1, -1, -1, -1, -1, -1, -1,
- -1, 58, 59, -1, -1, -1, 63, -1, -1, -1,
- 112, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 123, 124, -1, 40, 41, -1, 43, 44, 45,
- 257, 258, -1, 260, 261, 262, 93, 94, 265, -1,
- -1, -1, -1, -1, 60, -1, 62, 274, -1, -1,
- -1, -1, -1, -1, -1, 112, -1, -1, 285, -1,
- -1, 288, 289, 290, -1, -1, 123, 124, 295, 296,
- 257, 258, -1, 260, 261, 262, -1, -1, 265, -1,
- -1, -1, -1, -1, -1, -1, -1, 274, -1, -1,
- 40, -1, -1, 43, -1, 45, -1, -1, 285, -1,
- -1, 288, 289, 290, 291, 292, 293, 294, 295, 59,
- -1, -1, -1, -1, -1, 257, 258, -1, 260, 261,
- 262, -1, -1, 265, -1, -1, -1, -1, -1, -1,
- -1, -1, 274, 0, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 285, -1, -1, 288, 289, 290, -1,
- -1, -1, -1, -1, -1, 257, 258, -1, 260, 261,
- 262, -1, -1, 265, -1, -1, -1, -1, -1, -1,
- 37, -1, 274, 123, 41, 42, -1, 44, 0, -1,
- 47, -1, -1, 285, -1, -1, 288, 289, 290, -1,
- -1, 58, 59, -1, -1, -1, 63, -1, -1, -1,
- 257, 258, -1, 260, 261, 262, -1, -1, 265, -1,
- -1, -1, -1, -1, -1, 37, -1, 274, -1, 41,
- 42, -1, -1, -1, -1, 47, 93, 94, 285, -1,
- -1, 288, 289, 290, -1, -1, 58, 59, -1, -1,
- -1, 63, -1, 259, -1, 112, -1, 263, 264, -1,
- -1, -1, 268, 269, -1, 40, 123, 124, 43, -1,
- 45, -1, -1, -1, 280, -1, 282, 283, 284, -1,
- 286, 93, 94, -1, 59, 291, 292, 293, 294, 295,
- 296, -1, 298, -1, 300, 301, 302, 303, 304, -1,
- 112, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 123, 124, -1, -1, -1, -1, -1, -1, 259,
- 260, 261, 262, 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, 123, -1,
- 125, 291, 292, 293, 294, -1, -1, -1, 298, -1,
- 300, 301, 302, 303, 304, -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, 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,
- 257, 258, -1, 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, 40, -1, -1,
- 43, -1, 45, -1, -1, 257, 258, -1, 260, 261,
- 262, -1, 123, 265, 125, -1, 59, -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, -1, 259, 260, -1, -1, 263, 264,
+ -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,
- 123, -1, 125, 298, -1, 300, 301, 302, 303, 304,
- -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, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 40, -1, -1, 43, -1, 45, 259, 260,
+ -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, 123, -1, 125,
- 291, 292, 293, 294, -1, -1, -1, 298, -1, 300,
+ 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, 59, -1, -1, 259, 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, 300, 301, 302,
- 303, 304, -1, -1, -1, -1, 40, -1, -1, 43,
- -1, 45, -1, -1, -1, -1, -1, 123, -1, 125,
- -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, -1, -1, 259, 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, 123,
- -1, 125, 298, -1, 300, 301, 302, 303, 304, 40,
- -1, 259, 43, -1, 45, 263, 264, -1, -1, -1,
- 268, 269, -1, -1, -1, -1, -1, -1, 59, -1,
- -1, -1, 280, -1, 282, 283, 284, -1, 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, 259, 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, 300, 301, 302, 303, 304, 40,
+ -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, 259, 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, 300, 301, 302, 303,
- 304, 40, -1, -1, 43, -1, 45, -1, -1, -1,
- -1, -1, 123, -1, 125, -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, -1, -1, 259, 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, 123, -1, 125, 298, -1, 300,
- 301, 302, 303, 304, 40, -1, 259, 43, -1, 45,
- 263, 264, -1, -1, -1, 268, 269, -1, -1, -1,
- -1, -1, -1, 59, -1, -1, -1, 280, -1, 282,
- 283, 284, -1, 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, 259, 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, 300,
- 301, 302, 303, 304, 40, -1, -1, 43, -1, 45,
+ -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, -1, 59, -1, -1, -1, -1, -1, -1,
- 259, 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, 300, 301, 302, 303, 304, 40, -1, -1, 43,
- -1, 45, -1, -1, -1, -1, -1, 123, -1, 125,
- -1, -1, -1, -1, -1, 59, -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, 259, 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, 123,
- -1, 125, 298, -1, 300, 301, 302, 303, 304, 40,
- -1, 259, 43, -1, 45, 263, 264, -1, -1, -1,
- 268, 269, -1, -1, -1, -1, -1, -1, 59, -1,
- -1, -1, 280, -1, 282, 283, 284, -1, 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, 259, 260, -1, -1, 263, 264, -1,
- 266, 267, 268, 269, 270, -1, 272, 273, -1, 275,
+ -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, 300, 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, 259, 260, -1, -1, 263,
+ 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, 300, 301, 302, 303,
+ 294, -1, -1, -1, 298, -1, -1, 301, 302, 303,
304, 40, -1, -1, 43, -1, 45, -1, -1, -1,
- -1, -1, 123, -1, 125, -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, -1, -1, 259, 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, 123, -1, 125, 298, -1, 300,
- 301, 302, 303, 304, 40, -1, -1, 43, -1, 45,
+ 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,
- -1, -1, -1, 59, -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,
- 40, -1, -1, 43, -1, 45, -1, -1, 259, 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, 123, -1, 125,
- 291, 292, 293, 294, -1, -1, -1, 298, -1, 300,
- 301, 302, 303, 304, 40, 41, -1, 43, 44, 45,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 60, -1, 62, -1, -1, -1,
- 259, 260, -1, -1, 263, 264, -1, 266, 267, 268,
+ 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, 300, 301, 302, 303, 304, 40, 41, -1, 43,
- 44, 45, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 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, 259, 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, 300, 301, 302, 303, 304, 259,
- -1, -1, -1, 263, 264, -1, 266, 267, 268, 269,
- -1, -1, -1, -1, -1, 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,
- 300, 301, 302, 303, 304, 40, 41, -1, 43, 44,
- 45, -1, -1, 259, -1, -1, -1, 263, 264, -1,
- -1, -1, 268, 269, -1, 60, -1, 62, -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, 300, 301, 302, 303, 304, 40,
- 41, -1, 43, 44, 45, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 60,
- -1, 62, -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, 40, 286, -1, 43, 44, 45, 291, 292, 293,
- 294, 295, 296, -1, 298, -1, 300, 301, 302, 303,
- 304, 60, -1, 62, -1, -1, -1, -1, -1, -1,
+ -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, -1, -1, -1, -1, -1, 40, 41, -1,
- 43, -1, 45, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 60, -1, 62,
+ -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, 40, -1, -1, 43, 44, 45, -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, -1, 60, 259, 62, -1, -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, 44, 45, 291, 292, 293, 294,
- 295, 296, -1, 298, -1, 300, 301, 302, 303, 304,
- 60, -1, 62, -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, 40, 286, -1, 43, 44, 45,
- 291, 292, 293, 294, 295, 296, -1, 298, -1, 300,
- 301, 302, 303, 304, 60, -1, 62, -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, 295, 296, -1, 298,
- -1, 300, 301, 302, 303, 304, 259, -1, -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, 60, -1, 62, -1, 291, 292,
- 293, 294, 295, 296, -1, 298, -1, 300, 301, 302,
- 303, 304, 259, -1, -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,
- 60, -1, 62, -1, 291, 292, 293, 294, 295, 296,
- -1, 298, -1, 300, 301, 302, 303, 304, -1, 259,
- -1, -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, 60, -1, 62,
- -1, 291, 292, 293, 294, 295, 296, -1, 298, -1,
- 300, 301, 302, 303, 304, -1, -1, -1, -1, -1,
- -1, -1, -1, 259, -1, -1, -1, 263, 264, -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, 58,
- 286, 60, -1, 62, -1, 291, 292, 293, 294, 295,
- 296, -1, 298, -1, 300, 301, 302, 303, 304, -1,
- -1, -1, -1, -1, -1, -1, -1, 40, 41, -1,
- 43, -1, 45, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 60, -1, 62,
- -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, 295,
- 296, -1, 298, -1, 300, 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, 295, 296, -1, 298, -1,
- 300, 301, 302, 303, 304, -1, 259, -1, -1, -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, -1, 286, -1, -1, -1, -1, 291, 292,
- 293, 294, 295, 296, -1, 298, -1, 300, 301, 302,
- 303, 304, 40, 41, -1, 43, -1, 45, -1, -1,
+ 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, 60, -1, 62, -1, -1, -1, -1, -1,
+ 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, 295, 296, -1, 298,
- -1, 300, 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,
+ -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, 295, 296, -1, 298, -1, 300, 301, 302,
- 303, 304, 40, 41, -1, 43, -1, 45, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 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, 40, 41,
- -1, 43, -1, 45, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 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, 40, 41, -1, 43, -1, 45,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 60, -1, 62, -1, -1, -1,
- -1, 259, -1, -1, -1, 263, 264, -1, -1, -1,
- 268, 269, -1, -1, -1, -1, -1, -1, -1, -1,
+ 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, 295, 296, -1,
- 298, -1, 300, 301, 302, 303, 304, 40, 41, -1,
- 43, -1, 45, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 60, -1, 62,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -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, -1, 40, 41, -1, 43, -1, 45, -1,
- -1, 259, -1, -1, -1, 263, 264, -1, -1, -1,
- 268, 269, -1, 60, -1, 62, -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, 295, 296, -1,
- 298, -1, 300, 301, 302, 303, 304, 259, -1, -1,
- -1, 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, 295, 296, -1, 298, -1, 300, 301,
- 302, 303, 304, 259, -1, -1, -1, 263, 264, -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, -1,
- 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
- 296, -1, 298, -1, 300, 301, 302, 303, 304, 40,
- 41, 123, 43, -1, 45, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 60,
- -1, 62, -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, 40, 286, -1, 43, -1, 45, 291, 292,
- 293, 294, 295, 296, -1, 298, -1, 300, 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, 295, 296,
- -1, 298, -1, 300, 301, 302, 303, 304, 40, 41,
- -1, 43, -1, 45, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 257, 258, 259, 60, -1,
- 62, 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, 40, -1, -1, 43, -1, 45, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, 60, -1, 62, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 259, -1,
- -1, -1, 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, 59, -1,
- 291, 292, 293, 294, 295, 296, -1, 298, -1, 300,
- 301, 302, 303, 304, -1, -1, -1, -1, -1, -1,
- -1, 259, -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, -1, 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, 40, -1, -1, 43, -1,
- 45, -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, 295, 296, -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, 259, -1, -1, -1, 263, 264, -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, 295, 296,
- -1, 298, -1, 300, 301, 302, 303, 304, 259, -1,
- -1, -1, 263, 264, -1, -1, -1, 268, 269, -1,
+ -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, 300,
- 301, 302, 303, 304, -1, -1, -1, -1, 259, -1,
+ -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, 300,
- 301, 302, 303, 304, 259, -1, -1, -1, 263, 264,
- -1, -1, -1, 268, 269, -1, -1, 47, 48, -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, 300, 301, 302, 303, 304,
- 80, -1, 82, 83, -1, -1, -1, -1, -1, -1,
- -1, -1, 259, -1, -1, -1, 263, 264, -1, -1,
- -1, 268, 269, -1, -1, -1, -1, -1, 108, 109,
- -1, -1, -1, 280, -1, 282, 283, 284, -1, 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, 27,
- 28, -1, -1, -1, -1, 33, -1, -1, -1, -1,
- -1, -1, -1, 41, -1, -1, -1, -1, -1, -1,
- 170, -1, -1, -1, -1, -1, 54, -1, -1, -1,
- -1, 181, -1, 183, -1, 185, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 206, -1, -1, -1,
- -1, -1, -1, 91, 92, 93, 94, 95, 96, -1,
- -1, 221, 222, 223, 224, 225, 104, -1, 106, -1,
- -1, -1, 110, 111, -1, -1, 114, -1, 116, 117,
- -1, -1, -1, 121, 122, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 132, -1, -1, -1, -1, 137,
- 138, 139, 140, -1, -1, -1, -1, -1, -1, 269,
- -1, -1, -1, 273, 274, 275, -1, -1, -1, 279,
- 158, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 304, 305, -1, -1, 186, -1,
- 310, -1, -1, -1, -1, -1, -1, -1, -1, 197,
- 198, -1, 200, 201, 202, 203, -1, 205, -1, 207,
- 208, -1, -1, -1, -1, -1, -1, 215, 216, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 227,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 252, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 264, 265, 266, 267,
- 268, -1, 270, 271, 272,
+ 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
@@ -1806,6 +1866,7 @@ char *yyrule[] = {
"match : '(' match ')'",
"expr : term",
"expr : expr term",
+"expr : expr '?' expr ':' expr",
"expr : variable ASGNOP cond",
"term : variable",
"term : NUMBER",
@@ -1817,7 +1878,6 @@ char *yyrule[] = {
"term : term '%' term",
"term : term '^' term",
"term : term IN VAR",
-"term : cond '?' expr ':' expr",
"term : variable INCR",
"term : variable DECR",
"term : INCR variable",
@@ -1940,8 +2000,11 @@ short yyss[YYSTACKSIZE];
YYSTYPE yyvs[YYSTACKSIZE];
#define yystacksize YYSTACKSIZE
#line 396 "a2p.y"
+
+int yyparse _((void));
+
#include "a2py.c"
-#line 1945 "y.tab.c"
+#line 2008 "y.tab.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
@@ -2196,6 +2259,10 @@ case 34:
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;
@@ -2203,49 +2270,45 @@ case 35:
lval_field = TRUE;
}
break;
-case 36:
-#line 146 "a2p.y"
-{ yyval = yyvsp[0]; }
-break;
case 37:
#line 148 "a2p.y"
-{ yyval = oper1(ONUM,yyvsp[0]); }
+{ yyval = yyvsp[0]; }
break;
case 38:
#line 150 "a2p.y"
-{ yyval = oper1(OSTR,yyvsp[0]); }
+{ yyval = oper1(ONUM,yyvsp[0]); }
break;
case 39:
#line 152 "a2p.y"
-{ yyval = oper2(OADD,yyvsp[-2],yyvsp[0]); }
+{ yyval = oper1(OSTR,yyvsp[0]); }
break;
case 40:
#line 154 "a2p.y"
-{ yyval = oper2(OSUBTRACT,yyvsp[-2],yyvsp[0]); }
+{ yyval = oper2(OADD,yyvsp[-2],yyvsp[0]); }
break;
case 41:
#line 156 "a2p.y"
-{ yyval = oper2(OMULT,yyvsp[-2],yyvsp[0]); }
+{ yyval = oper2(OSUBTRACT,yyvsp[-2],yyvsp[0]); }
break;
case 42:
#line 158 "a2p.y"
-{ yyval = oper2(ODIV,yyvsp[-2],yyvsp[0]); }
+{ yyval = oper2(OMULT,yyvsp[-2],yyvsp[0]); }
break;
case 43:
#line 160 "a2p.y"
-{ yyval = oper2(OMOD,yyvsp[-2],yyvsp[0]); }
+{ yyval = oper2(ODIV,yyvsp[-2],yyvsp[0]); }
break;
case 44:
#line 162 "a2p.y"
-{ yyval = oper2(OPOW,yyvsp[-2],yyvsp[0]); }
+{ yyval = oper2(OMOD,yyvsp[-2],yyvsp[0]); }
break;
case 45:
#line 164 "a2p.y"
-{ yyval = oper2(ODEFINED,aryrefarg(yyvsp[0]),yyvsp[-2]); }
+{ yyval = oper2(OPOW,yyvsp[-2],yyvsp[0]); }
break;
case 46:
#line 166 "a2p.y"
-{ yyval = oper3(OCOND,yyvsp[-4],yyvsp[-2],yyvsp[0]); }
+{ yyval = oper2(ODEFINED,aryrefarg(yyvsp[0]),yyvsp[-2]); }
break;
case 47:
#line 168 "a2p.y"
@@ -2607,7 +2670,7 @@ case 137:
#line 392 "a2p.y"
{ yyval = oper3(OBLOCK,oper2(OJUNK,yyvsp[-3],yyvsp[-2]),Nullop,yyvsp[0]); }
break;
-#line 2611 "y.tab.c"
+#line 2674 "y.tab.c"
}
yyssp -= yym;
yystate = *yyssp;
diff --git a/gnu/usr.bin/perl/x2p/a2p.h b/gnu/usr.bin/perl/x2p/a2p.h
index 77d55ced7a2..b00b0723eab 100644
--- a/gnu/usr.bin/perl/x2p/a2p.h
+++ b/gnu/usr.bin/perl/x2p/a2p.h
@@ -1,6 +1,6 @@
/* $RCSfile: a2p.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:09 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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.
@@ -8,9 +8,12 @@
* $Log: a2p.h,v $
*/
-#include "../embed.h"
#define VOIDUSED 1
-#include "../config.h"
+#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
@@ -31,15 +34,29 @@
# include <sys/types.h>
#endif
+#ifdef USE_NEXT_CTYPE
-#ifdef USE_NEXT_CTYPE
+#if NX_CURRENT_COMPILER_RELEASE >= 400
+#include <objc/NXCType.h>
+#else /* NX_CURRENT_COMPILER_RELEASE < 400 */
#include <appkit/NXCType.h>
-#else
+#endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */
+
+#else /* !USE_NEXT_CTYPE */
#include <ctype.h>
-#endif
+#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
@@ -87,7 +104,8 @@
# endif
#else
# if defined(VMS)
-# include "../vmsish.h"
+# define NO_PERL_TYPEDEFS
+# include "vmsish.h"
# endif
#endif
@@ -99,7 +117,15 @@ char *strchr(), *strrchr();
char *strcpy(), *strcat();
#endif /* ! STANDARD_C */
-#include "handy.h"
+#ifdef VMS
+# include "handy.h"
+#else
+# include "../handy.h"
+#endif
+
+#undef Nullfp
+#define Nullfp Null(FILE*)
+
#define Nullop 0
#define OPROG 1
@@ -389,6 +415,7 @@ 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);
diff --git a/gnu/usr.bin/perl/x2p/a2p.man b/gnu/usr.bin/perl/x2p/a2p.man
deleted file mode 100644
index d885ff0157b..00000000000
--- a/gnu/usr.bin/perl/x2p/a2p.man
+++ /dev/null
@@ -1,187 +0,0 @@
-.rn '' }`
-''' $RCSfile: a2p.man,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:34 $
-'''
-''' $Log: a2p.man,v $
-''' Revision 1.1.1.1 1996/08/19 10:13:34 downsj
-''' Import of Perl 5.003 into the tree. Makefile.bsd-wrapper and
-''' config.sh.OpenBSD are the only local changes.
-'''
-.de Sh
-.br
-.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
-..
-'''
-''' 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-
-.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" ""
-.ds L' '
-.ds R' '
-'br\}
-.el\{\
-.ds -- \(em\|
-.tr \*(Tr
-.ds L" ``
-.ds R" ''
-.ds L' `
-.ds R' '
-'br\}
-.TH A2P 1 LOCAL
-.SH NAME
-a2p - Awk to Perl translator
-.SH SYNOPSIS
-.B a2p [options] filename
-.SH 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.
-.Sh "Options"
-Options include:
-.TP 5
-.B \-D<number>
-sets debugging flags.
-.TP 5
-.B \-F<character>
-tells a2p that this awk script is always invoked with this -F switch.
-.TP 5
-.B \-n<fieldlist>
-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:
-.sp
- a2p -7 -nlogin.password.uid.gid.gcos.shell.home
-.sp
-Any delimiter can be used to separate the field names.
-.TP 5
-.B \-<number>
-causes a2p to assume that input will always have that many fields.
-.Sh "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.
-.PP
-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.
-.PP
-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 \*(L"#???\*(R".
-You should go through and check them.
-You might want to run at least once with the \-w switch to perl, which
-will warn you if you use == where you should have used eq.
-.PP
-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.
-.PP
-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 \-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.
-.PP
-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.
-.PP
-Perl has two kinds of array, numerically-indexed and associative.
-Awk arrays are usually translated to associative arrays, but if you happen
-to know that the index is always going to be numeric you could change
-the {...} to [...].
-Iteration over an associative array is done using the keys() function, but
-iteration over a numeric array is NOT.
-You might need to modify any loop that is iterating over the array in question.
-.PP
-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.
-.PP
-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.
-.PP
-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.
-.PP
-Cute comments that say "# Here is a workaround because awk is dumb" are passed
-through unmodified.
-.PP
-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.
-.PP
-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.
-.PP
-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.
-.PP
-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.
-.PP
-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.
-.SH ENVIRONMENT
-A2p uses no environment variables.
-.SH AUTHOR
-Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
-.SH FILES
-.SH SEE ALSO
-perl The perl compiler/interpreter
-.br
-s2p sed to perl translator
-.SH DIAGNOSTICS
-.SH 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.
-.PP
-Storage for the awk syntax tree is currently static, and can run out.
-.rn }` ''
diff --git a/gnu/usr.bin/perl/x2p/a2p.pod b/gnu/usr.bin/perl/x2p/a2p.pod
new file mode 100644
index 00000000000..fa726fb101c
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/x2p/a2p.y b/gnu/usr.bin/perl/x2p/a2p.y
index 961e2f280f0..2d3f23923e5 100644
--- a/gnu/usr.bin/perl/x2p/a2p.y
+++ b/gnu/usr.bin/perl/x2p/a2p.y
@@ -1,7 +1,7 @@
%{
/* $RCSfile: a2p.y,v $$Revision: 4.1 $$Date: 92/08/07 18:29:12 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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.
@@ -133,6 +133,8 @@ 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)
@@ -162,8 +164,6 @@ term : variable
{ $$ = oper2(OPOW,$1,$3); }
| term IN VAR
{ $$ = oper2(ODEFINED,aryrefarg($3),$1); }
- | cond '?' expr ':' expr
- { $$ = oper3(OCOND,$1,$3,$5); }
| variable INCR
{ $$ = oper1(OPOSTINCR,$1); }
| variable DECR
@@ -393,4 +393,7 @@ compound
;
%%
+
+int yyparse _((void));
+
#include "a2py.c"
diff --git a/gnu/usr.bin/perl/x2p/a2py.c b/gnu/usr.bin/perl/x2p/a2py.c
index 454e2dc8601..3a3cb5275d1 100644
--- a/gnu/usr.bin/perl/x2p/a2py.c
+++ b/gnu/usr.bin/perl/x2p/a2py.c
@@ -1,6 +1,6 @@
/* $RCSfile: a2py.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:14 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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.
@@ -27,6 +27,7 @@ int oper5();
STR *walk();
#ifdef OS2
+static void
usage()
{
printf("\nThis is the AWK to PERL translator, version 5.0, patchlevel %d\n", PATCHLEVEL);
@@ -41,6 +42,8 @@ usage()
exit(1);
}
#endif
+
+int
main(argc,argv,env)
register int argc;
register char **argv;
@@ -77,6 +80,9 @@ register char **env;
case 'n':
namelist = savestr(argv[0]+2);
break;
+ case 'o':
+ old_awk = TRUE;
+ break;
case '-':
argc--,argv++;
goto switch_end;
@@ -154,7 +160,9 @@ register char **env;
tmpstr = walk(0,0,root,&i,P_MIN);
str = str_make(STARTPERL);
- str_cat(str, "\neval 'exec perl -S $0 \"$@\"'\n\
+ 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");
@@ -1289,10 +1297,10 @@ int prevargs;
numargs = fixrargs(name,ops[arg+3].ival,numargs);
}
else {
- char tmpbuf[128];
-
+ char *tmpbuf = 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;
diff --git a/gnu/usr.bin/perl/x2p/cflags.SH b/gnu/usr.bin/perl/x2p/cflags.SH
index 531ef658053..62bd11c9d98 100644
--- a/gnu/usr.bin/perl/x2p/cflags.SH
+++ b/gnu/usr.bin/perl/x2p/cflags.SH
@@ -14,13 +14,21 @@ 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\(.*\)/'` ;;
+*/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!
@@ -74,7 +82,7 @@ for file do
*) ;;
esac
- ccflags="`echo $ccflags | sed -e 's/-DEMBED//'`"
+ ccflags="`echo $ccflags | sed -e 's/-DMULTIPLICITY//'`"
echo "$cc -c $ccflags $optimize $large $split"
eval "$also "'"$cc -c $ccflags $optimize $large $split"'
diff --git a/gnu/usr.bin/perl/x2p/find2perl.PL b/gnu/usr.bin/perl/x2p/find2perl.PL
index 32f78fe23f3..c23fc923a8f 100644
--- a/gnu/usr.bin/perl/x2p/find2perl.PL
+++ b/gnu/usr.bin/perl/x2p/find2perl.PL
@@ -12,10 +12,9 @@ use File::Basename qw(&basename &dirname);
# 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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
@@ -25,10 +24,11 @@ print "Extracting $file (with variable substitutions)\n";
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
- eval 'exec perl -S \$0 "\$@"'
- if 0;
+$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.
@@ -241,8 +241,7 @@ while (@ARGV) {
print <<"END";
$startperl
-
-eval 'exec perl -S \$0 \${1+"\$@"}'
+ eval 'exec $perlpath -S \$0 \${1+"\$@"}'
if \$running_under_some_shell;
END
diff --git a/gnu/usr.bin/perl/x2p/handy.h b/gnu/usr.bin/perl/x2p/handy.h
deleted file mode 100644
index 0049a1108b4..00000000000
--- a/gnu/usr.bin/perl/x2p/handy.h
+++ /dev/null
@@ -1,172 +0,0 @@
-/* handy.h
- *
- * Copyright (c) 1991-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.
- *
- */
-
-#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(FILE*)
-#define Nullsv Null(SV*)
-
-#ifdef UTS
-#define bool int
-#else
-#define bool char
-#endif
-
-#ifdef TRUE
-#undef TRUE
-#endif
-#ifdef FALSE
-#undef FALSE
-#endif
-#define TRUE (1)
-#define FALSE (0)
-
-typedef char I8;
-typedef unsigned char U8;
-
-typedef short I16;
-typedef unsigned short U16;
-
-#if BYTEORDER > 0x4321
- typedef int I32;
- typedef unsigned int U32;
-#else
- typedef long I32;
- typedef unsigned long U32;
-#endif
-
-#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_SETLOCALE /* XXX Is there a better test for this? */
-# ifndef CTYPE256
-# define CTYPE256
-# endif
-#endif
-
-#ifdef USE_NEXT_CTYPE
-#define isALNUM(c) (NXIsAlpha((unsigned int)c) || NXIsDigit((unsigned int)c) || c == '_')
-#define isIDFIRST(c) (NXIsAlpha((unsigned int)c) || c == '_')
-#define isALPHA(c) NXIsAlpha((unsigned int)c)
-#define isSPACE(c) NXIsSpace((unsigned int)c)
-#define isDIGIT(c) NXIsDigit((unsigned int)c)
-#define isUPPER(c) NXIsUpper((unsigned int)c)
-#define isLOWER(c) NXIsLower((unsigned int)c)
-#define toUPPER(c) NXToUpper((unsigned int)c)
-#define toLOWER(c) NXToLower((unsigned int)c)
-#else /* USE_NEXT_CTYPE */
-#if defined(CTYPE256) || (!defined(isascii) && !defined(HAS_ISASCII))
-#define isALNUM(c) (isalpha((unsigned char)(c)) || isdigit((unsigned char)(c)) || c == '_')
-#define isIDFIRST(c) (isalpha((unsigned char)(c)) || (c) == '_')
-#define isALPHA(c) isalpha((unsigned char)(c))
-#define isSPACE(c) isspace((unsigned char)(c))
-#define isDIGIT(c) isdigit((unsigned char)(c))
-#define isUPPER(c) isupper((unsigned char)(c))
-#define isLOWER(c) islower((unsigned char)(c))
-#define toUPPER(c) toupper((unsigned char)(c))
-#define toLOWER(c) tolower((unsigned char)(c))
-#else
-#define isALNUM(c) (isascii(c) && (isalpha(c) || isdigit(c) || c == '_'))
-#define isIDFIRST(c) (isascii(c) && (isalpha(c) || (c) == '_'))
-#define isALPHA(c) (isascii(c) && isalpha(c))
-#define isSPACE(c) (isascii(c) && isspace(c))
-#define isDIGIT(c) (isascii(c) && isdigit(c))
-#define isUPPER(c) (isascii(c) && isupper(c))
-#define isLOWER(c) (isascii(c) && islower(c))
-#define toUPPER(c) toupper(c)
-#define toLOWER(c) tolower(c)
-#endif
-#endif /* USE_NEXT_CTYPE */
-
-/* Line numbers are unsigned, 16 bits. */
-typedef U16 line_t;
-#ifdef lint
-#define NOLINE ((line_t)0)
-#else
-#define NOLINE ((line_t) 65535)
-#endif
-
-#ifndef lint
-#ifndef LEAKTEST
-#ifndef safemalloc
-Malloc_t safemalloc _((MEM_SIZE));
-Malloc_t saferealloc _((char *, MEM_SIZE));
-void safefree _((char *));
-#endif
-#ifndef MSDOS
-#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((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
-#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
-#else
-#define New(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t))))
-#define Newc(x,v,n,t,c) (v = (c*)safemalloc(((unsigned long)(n) * sizeof(t))))
-#define Newz(x,v,n,t) (v = (t*)safemalloc(((unsigned long)(n) * sizeof(t)))), \
- memzero((char*)(v), (n) * sizeof(t))
-#define Renew(v,n,t) (v = (t*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t))))
-#define Renewc(v,n,t,c) (v = (c*)saferealloc((char*)(v),((unsigned long)(n)*sizeof(t))))
-#endif /* MSDOS */
-#define Safefree(d) safefree((char*)d)
-#define NEWSV(x,len) newSV(len)
-#else /* LEAKTEST */
-char *safexmalloc();
-char *safexrealloc();
-void safexfree();
-#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((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
-#define Renewc(v,n,t,c) (v = (c*)safexrealloc((char*)(v),(MEM_SIZE)((n)*sizeof(t))))
-#define Safefree(d) safexfree((char*)d)
-#define NEWSV(x,len) newSV(x,len)
-#define MAXXCOUNT 1200
-long xcount[MAXXCOUNT];
-long lastxcount[MAXXCOUNT];
-#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/gnu/usr.bin/perl/x2p/hash.c b/gnu/usr.bin/perl/x2p/hash.c
index 58236f49e42..5859eab470f 100644
--- a/gnu/usr.bin/perl/x2p/hash.c
+++ b/gnu/usr.bin/perl/x2p/hash.c
@@ -1,6 +1,6 @@
/* $RCSfile: hash.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:20 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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/gnu/usr.bin/perl/x2p/hash.h b/gnu/usr.bin/perl/x2p/hash.h
index f61a29f4e62..9dc64a1dcd5 100644
--- a/gnu/usr.bin/perl/x2p/hash.h
+++ b/gnu/usr.bin/perl/x2p/hash.h
@@ -1,6 +1,6 @@
/* $RCSfile: hash.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:21 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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/gnu/usr.bin/perl/x2p/proto.h b/gnu/usr.bin/perl/x2p/proto.h
new file mode 100644
index 00000000000..85d749616ae
--- /dev/null
+++ b/gnu/usr.bin/perl/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/gnu/usr.bin/perl/x2p/s2p.PL b/gnu/usr.bin/perl/x2p/s2p.PL
index 29864b418a6..73f67872de1 100644
--- a/gnu/usr.bin/perl/x2p/s2p.PL
+++ b/gnu/usr.bin/perl/x2p/s2p.PL
@@ -12,10 +12,9 @@ use File::Basename qw(&basename &dirname);
# 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.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
open OUT,">$file" or die "Can't create $file: $!";
@@ -25,10 +24,11 @@ print "Extracting $file (with variable substitutions)\n";
# You can use $Config{...} to use Configure variables.
print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
- eval 'exec perl -S \$0 "\$@"'
- if 0;
+$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.
@@ -39,6 +39,78 @@ print OUT <<'!NO!SUBS!';
#
# $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 = '}';
@@ -294,7 +366,7 @@ unless ($debug) {
print &q(<<"EOT");
: $startperl
-: eval 'exec perl -S \$0 \${1+"\$@"}'
+: eval 'exec $perlpath -S \$0 \${1+"\$@"}'
: if \$running_under_some_shell;
:
EOT
diff --git a/gnu/usr.bin/perl/x2p/s2p.man b/gnu/usr.bin/perl/x2p/s2p.man
deleted file mode 100644
index afe5ac8ba3a..00000000000
--- a/gnu/usr.bin/perl/x2p/s2p.man
+++ /dev/null
@@ -1,96 +0,0 @@
-.rn '' }`
-''' $RCSfile: s2p.man,v $$Revision: 1.1.1.1 $$Date: 1996/08/19 10:13:36 $
-'''
-''' $Log: s2p.man,v $
-''' Revision 1.1.1.1 1996/08/19 10:13:36 downsj
-''' Import of Perl 5.003 into the tree. Makefile.bsd-wrapper and
-''' config.sh.OpenBSD are the only local changes.
-'''
-.de Sh
-.br
-.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
-..
-'''
-''' 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-
-.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" ""
-.ds L' '
-.ds R' '
-'br\}
-.el\{\
-.ds -- \(em\|
-.tr \*(Tr
-.ds L" ``
-.ds R" ''
-.ds L' `
-.ds R' '
-'br\}
-.TH S2P 1 NEW
-.SH NAME
-s2p - Sed to Perl translator
-.SH SYNOPSIS
-.B s2p [options] filename
-.SH 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.
-.Sh "Options"
-Options include:
-.TP 5
-.B \-D<number>
-sets debugging flags.
-.TP 5
-.B \-n
-specifies that this sed script was always invoked with a sed -n.
-Otherwise a switch parser is prepended to the front of the script.
-.TP 5
-.B \-p
-specifies that this sed script was never invoked with a sed -n.
-Otherwise a switch parser is prepended to the front of the script.
-.Sh "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.
-.PP
-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 $\e and chop.
-.SH ENVIRONMENT
-S2p uses no environment variables.
-.SH AUTHOR
-Larry Wall <lwall@jpl-devvax.Jpl.Nasa.Gov>
-.SH FILES
-.SH SEE ALSO
-perl The perl compiler/interpreter
-.br
-a2p awk to perl translator
-.SH DIAGNOSTICS
-.SH BUGS
-.rn }` ''
diff --git a/gnu/usr.bin/perl/x2p/str.c b/gnu/usr.bin/perl/x2p/str.c
index e9dd34400f0..88b3c604054 100644
--- a/gnu/usr.bin/perl/x2p/str.c
+++ b/gnu/usr.bin/perl/x2p/str.c
@@ -1,6 +1,6 @@
/* $RCSfile: str.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:26 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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.
@@ -41,7 +41,7 @@ register STR *str;
str->str_pok = 1;
#ifdef DEBUGGING
if (debug & 32)
- fprintf(stderr,"0x%lx ptr(%s)\n",str,str->str_ptr);
+ fprintf(stderr,"0x%lx ptr(%s)\n",(unsigned long)str,str->str_ptr);
#endif
return str->str_ptr;
}
@@ -59,7 +59,7 @@ register STR *str;
str->str_nok = 1;
#ifdef DEBUGGING
if (debug & 32)
- fprintf(stderr,"0x%lx num(%g)\n",str,str->str_nval);
+ fprintf(stderr,"0x%lx num(%g)\n",(unsigned long)str,str->str_nval);
#endif
return str->str_nval;
}
@@ -297,6 +297,16 @@ register FILE *fp;
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 */
@@ -317,7 +327,7 @@ register FILE *fp;
FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */
FILE_ptr(fp) = ptr;
- i = _filbuf(fp); /* get more characters */
+ i = getc(fp); /* get more characters */
cnt = FILE_cnt(fp);
ptr = FILE_ptr(fp); /* reregisterize cnt and ptr */
diff --git a/gnu/usr.bin/perl/x2p/str.h b/gnu/usr.bin/perl/x2p/str.h
index 9d495ab0bad..3deaaec76f0 100644
--- a/gnu/usr.bin/perl/x2p/str.h
+++ b/gnu/usr.bin/perl/x2p/str.h
@@ -1,6 +1,6 @@
/* $RCSfile: str.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:27 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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/gnu/usr.bin/perl/x2p/util.c b/gnu/usr.bin/perl/x2p/util.c
index 5c3554b7e3e..469beb0c149 100644
--- a/gnu/usr.bin/perl/x2p/util.c
+++ b/gnu/usr.bin/perl/x2p/util.c
@@ -1,6 +1,6 @@
/* $RCSfile: util.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:29 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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.
@@ -13,6 +13,9 @@
#include "INTERN.h"
#include "util.h"
+#ifdef I_STDARG
+# include <stdarg.h>
+#endif
#define FLUSH
static char nomem[] = "Out of memory!\n";
@@ -24,13 +27,14 @@ Malloc_t
safemalloc(size)
MEM_SIZE size;
{
- char *ptr;
- Malloc_t malloc();
+ Malloc_t ptr;
- ptr = (char *) malloc(size?size:1); /* malloc(0) is NASTY on our system */
+ /* malloc(0) is NASTY on some systems */
+ ptr = malloc(size ? size : 1);
#ifdef DEBUGGING
if (debug & 128)
- fprintf(stderr,"0x%x: (%05d) malloc %d bytes\n",ptr,an++,size);
+ fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",(unsigned long)ptr,
+ an++,(long)size);
#endif
if (ptr != Nullch)
return ptr;
@@ -45,18 +49,17 @@ MEM_SIZE size;
Malloc_t
saferealloc(where,size)
-char *where;
+Malloc_t where;
MEM_SIZE size;
{
- char *ptr;
- Malloc_t realloc();
+ Malloc_t ptr;
- ptr = (char *)
- realloc(where,size?size:1); /* realloc(0) is NASTY on our system */
+ /* realloc(0) is NASTY on some systems */
+ ptr = realloc(where, size ? size : 1);
#ifdef DEBUGGING
if (debug & 128) {
- fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++);
- fprintf(stderr,"0x%x: (%05d) realloc %d bytes\n",ptr,an++,size);
+ 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)
@@ -70,13 +73,13 @@ MEM_SIZE size;
/* safe version of free */
-void
+Free_t
safefree(where)
-char *where;
+Malloc_t where;
{
#ifdef DEBUGGING
if (debug & 128)
- fprintf(stderr,"0x%x: (%05d) free\n",where,an++);
+ fprintf(stderr,"0x%lx: (%05d) free\n",(unsigned long)where,an++);
#endif
free(where);
}
@@ -189,32 +192,65 @@ int newlen;
}
}
-/*VARARGS1*/
void
+#if defined(I_STDARG) && defined(HAS_VPRINTF)
+croak(char *pat,...)
+#else /* I_STDARG */
+/*VARARGS1*/
croak(pat,a1,a2,a3,a4)
-char *pat;
-int a1,a2,a3,a4;
+ char *pat;
+ int a1,a2,a3,a4;
+#endif /* I_STDARG */
{
+#if defined(I_STDARG) && 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);
}
-/*VARARGS1*/
void
+#if defined(I_STDARG) && defined(HAS_VPRINTF)
+fatal(char *pat,...)
+#else /* I_STDARG */
+/*VARARGS1*/
fatal(pat,a1,a2,a3,a4)
-char *pat;
-int a1,a2,a3,a4;
+ char *pat;
+ int a1,a2,a3,a4;
+#endif /* I_STDARG */
{
+#if defined(I_STDARG) && 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);
}
-/*VARARGS1*/
void
+#if defined(I_STDARG) && defined(HAS_VPRINTF)
+warn(char *pat,...)
+#else /* I_STDARG */
+/*VARARGS1*/
warn(pat,a1,a2,a3,a4)
-char *pat;
-int a1,a2,a3,a4;
+ char *pat;
+ int a1,a2,a3,a4;
+#endif /* I_STDARG */
{
+#if defined(I_STDARG) && 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/gnu/usr.bin/perl/x2p/util.h b/gnu/usr.bin/perl/x2p/util.h
index 35f796121c1..ff93e8ac7a0 100644
--- a/gnu/usr.bin/perl/x2p/util.h
+++ b/gnu/usr.bin/perl/x2p/util.h
@@ -1,6 +1,6 @@
/* $RCSfile: util.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:30 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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.
@@ -24,10 +24,22 @@ int makedir();
char * cpy2 _(( char *to, char *from, int delim ));
char * cpytill _(( char *to, char *from, int delim ));
-void croak _(( char *pat, int a1, int a2, int a3, int a4 ));
void growstr _(( char **strptr, int *curlen, int newlen ));
char * instr _(( char *big, char *little ));
-void Myfatal ();
char * safecpy _(( char *to, char *from, int len ));
char * savestr _(( char *str ));
+#if defined(I_STDARG) && defined(HAS_VPRINTF)
+void croak _(( char *pat, ... ));
+void fatal _(( char *pat, ... ));
+void warn _(( char *pat, ... ));
+#else /* defined(I_STDARG) && defined(HAS_VPRINTF) */
+void croak _(( char *pat, int a1, int a2, int a3, int a4 ));
+void Myfatal ();
void warn ();
+#endif /* defined(I_STDARG) && defined(HAS_VPRINTF) */
+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/gnu/usr.bin/perl/x2p/walk.c b/gnu/usr.bin/perl/x2p/walk.c
index 403d686e391..cb40073b22a 100644
--- a/gnu/usr.bin/perl/x2p/walk.c
+++ b/gnu/usr.bin/perl/x2p/walk.c
@@ -1,6 +1,6 @@
/* $RCSfile: walk.c,v $$Revision: 4.1 $$Date: 92/08/07 18:29:31 $
*
- * Copyright (c) 1991, Larry Wall
+ * 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.
@@ -145,7 +145,7 @@ int minprec; /* minimum precedence without parens */
if (saw_FNR)
str_cat(str,"continue {\n $FNRbase = $. if eof;\n}\n");
}
- else
+ else if (old_awk)
str_cat(str,"while (<>) { } # (no line actions)\n");
if (ops[node+4].ival) {
realexit = TRUE;