summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Artistic2
-rw-r--r--Changes8720
-rw-r--r--Changes5.000185
-rw-r--r--Changes5.0011299
-rw-r--r--Changes5.002 (renamed from Changes.Conf)1533
-rw-r--r--Changes5.003100
-rwxr-xr-xConfigure3711
-rw-r--r--EXTERN.h6
-rw-r--r--INSTALL535
-rw-r--r--INTERN.h6
-rw-r--r--MANIFEST161
-rwxr-xr-xMakefile.SH240
-rw-r--r--Porting/Glossary1361
-rw-r--r--README2
-rw-r--r--README.os21873
-rw-r--r--README.qnx22
-rw-r--r--README.vms28
-rw-r--r--av.c27
-rw-r--r--av.h2
-rwxr-xr-xcflags.SH4
-rw-r--r--compat3.sym46
-rw-r--r--config_H456
-rwxr-xr-xconfig_h.SH361
-rwxr-xr-xconfigpm2
-rwxr-xr-x[-rw-r--r--]configure12
-rw-r--r--cop.h9
-rw-r--r--deb.c28
-rw-r--r--doio.c224
-rw-r--r--doop.c63
-rw-r--r--dosish.h30
-rw-r--r--dump.c90
-rw-r--r--eg/README2
-rw-r--r--eg/nih5
-rw-r--r--eg/sysvipc/ipcmsg2
-rw-r--r--eg/sysvipc/ipcsem2
-rw-r--r--eg/sysvipc/ipcshm2
-rw-r--r--emacs/cperl-mode.el1798
-rw-r--r--embed.h2969
-rwxr-xr-xembed.pl132
-rw-r--r--ext/DB_File/DB_File.pm1009
-rw-r--r--ext/DB_File/DB_File.xs221
-rw-r--r--ext/DynaLoader/DynaLoader.pm4
-rw-r--r--ext/DynaLoader/Makefile.PL2
-rw-r--r--ext/DynaLoader/dl_aix.xs10
-rw-r--r--ext/DynaLoader/dl_dld.xs18
-rw-r--r--ext/DynaLoader/dl_dlopen.xs10
-rw-r--r--ext/DynaLoader/dl_hpux.xs18
-rw-r--r--ext/DynaLoader/dl_next.xs10
-rw-r--r--ext/DynaLoader/dl_os2.xs10
-rw-r--r--ext/DynaLoader/dl_vms.xs36
-rw-r--r--ext/DynaLoader/dlutils.c6
-rw-r--r--ext/Fcntl/Fcntl.pm5
-rw-r--r--ext/FileHandle/FileHandle.pm479
-rw-r--r--ext/FileHandle/FileHandle.xs176
-rw-r--r--ext/FileHandle/Makefile.PL7
-rw-r--r--ext/IO/IO.pm24
-rw-r--r--ext/IO/IO.xs96
-rw-r--r--ext/IO/lib/IO/File.pm77
-rw-r--r--ext/IO/lib/IO/Handle.pm168
-rw-r--r--ext/IO/lib/IO/Pipe.pm39
-rw-r--r--ext/IO/lib/IO/Seekable.pm16
-rw-r--r--ext/IO/lib/IO/Select.pm90
-rw-r--r--ext/IO/lib/IO/Socket.pm243
-rw-r--r--ext/NDBM_File/hints/dynixptx.pl3
-rw-r--r--ext/ODBM_File/ODBM_File.xs15
-rw-r--r--ext/ODBM_File/hints/hpux.pl4
-rw-r--r--ext/ODBM_File/hints/ultrix.pl4
-rw-r--r--ext/Opcode/Opcode.pm7
-rw-r--r--ext/Opcode/Opcode.xs4
-rw-r--r--ext/Opcode/Safe.pm15
-rw-r--r--ext/POSIX/POSIX.pm14
-rw-r--r--ext/POSIX/POSIX.pod80
-rw-r--r--ext/POSIX/POSIX.xs145
-rw-r--r--ext/POSIX/hints/next_3.pl5
-rw-r--r--ext/SDBM_File/sdbm/pair.c2
-rw-r--r--ext/SDBM_File/sdbm/pair.h10
-rw-r--r--ext/SDBM_File/sdbm/sdbm.3128
-rw-r--r--ext/SDBM_File/sdbm/sdbm.c2
-rw-r--r--ext/SDBM_File/sdbm/sdbm.h86
-rw-r--r--ext/Socket/Socket.pm19
-rw-r--r--ext/util/make_ext5
-rw-r--r--global.sym118
-rw-r--r--gv.c54
-rw-r--r--handy.h243
-rw-r--r--hints/README.NeXT56
-rw-r--r--hints/README.hints90
-rw-r--r--hints/aix.sh6
-rw-r--r--hints/amigaos.sh43
-rw-r--r--hints/convexos.sh9
-rw-r--r--hints/dgux.sh84
-rw-r--r--hints/dnix.sh1
-rw-r--r--hints/dynixptx.sh24
-rw-r--r--hints/epix.sh2
-rw-r--r--hints/freebsd.sh40
-rw-r--r--hints/hpux.sh32
-rw-r--r--hints/irix_6_2.sh43
-rw-r--r--hints/linux.sh16
-rw-r--r--hints/lynxos.sh12
-rw-r--r--hints/machten.sh16
-rw-r--r--hints/machten_2.sh13
-rw-r--r--hints/mips.sh2
-rw-r--r--hints/mpeix.sh2
-rw-r--r--hints/next_3.sh65
-rw-r--r--hints/next_3_2.sh64
-rw-r--r--hints/next_3_3.sh69
-rw-r--r--hints/next_4.sh66
-rw-r--r--hints/os2.sh105
-rw-r--r--hints/qnx.sh176
-rw-r--r--hints/sco.sh67
-rw-r--r--hints/solaris_2.sh34
-rw-r--r--hints/sunos_4_0.sh1
-rw-r--r--hints/sunos_4_1.sh34
-rw-r--r--hints/svr4.sh9
-rw-r--r--hints/titanos.sh9
-rw-r--r--hints/ultrix_4.sh4
-rw-r--r--hints/umips.sh39
-rw-r--r--hv.c372
-rw-r--r--hv.h60
-rwxr-xr-xinstallman47
-rwxr-xr-xinstallperl124
-rw-r--r--interp.sym3
-rwxr-xr-xkeywords.pl1
-rw-r--r--lib/AnyDBM_File.pm13
-rw-r--r--lib/AutoLoader.pm78
-rw-r--r--lib/AutoSplit.pm3
-rw-r--r--lib/Benchmark.pm8
-rw-r--r--lib/CPAN.pm2350
-rw-r--r--lib/CPAN/FirstTime.pm284
-rw-r--r--lib/CPAN/Nox.pm33
-rw-r--r--lib/Carp.pm23
-rw-r--r--lib/Class/Template.pm241
-rw-r--r--lib/Cwd.pm31
-rw-r--r--lib/Devel/SelfStubber.pm2
-rw-r--r--lib/Env.pm2
-rw-r--r--lib/Exporter.pm4
-rw-r--r--lib/ExtUtils/Embed.pm34
-rw-r--r--lib/ExtUtils/Install.pm25
-rw-r--r--lib/ExtUtils/Liblist.pm191
-rw-r--r--lib/ExtUtils/MM_Unix.pm110
-rw-r--r--lib/ExtUtils/MM_VMS.pm243
-rw-r--r--lib/ExtUtils/MakeMaker.pm33
-rw-r--r--lib/ExtUtils/Manifest.pm27
-rw-r--r--lib/ExtUtils/Mkbootstrap.pm4
-rw-r--r--lib/ExtUtils/Mksymlists.pm5
-rw-r--r--lib/ExtUtils/typemap7
-rwxr-xr-x[-rw-r--r--]lib/ExtUtils/xsubpp105
-rw-r--r--lib/Fatal.pm2
-rw-r--r--lib/File/Basename.pm32
-rw-r--r--lib/File/Compare.pm136
-rw-r--r--lib/File/Copy.pm122
-rw-r--r--lib/File/Find.pm8
-rw-r--r--lib/File/Path.pm14
-rw-r--r--lib/File/stat.pm111
-rw-r--r--lib/FileHandle.pm245
-rw-r--r--lib/FindBin.pm18
-rw-r--r--lib/Getopt/Long.pm600
-rw-r--r--lib/Getopt/Std.pm54
-rw-r--r--lib/I18N/Collate.pm62
-rw-r--r--lib/IPC/Open2.pm2
-rw-r--r--lib/IPC/Open3.pm4
-rw-r--r--lib/Math/BigInt.pm28
-rw-r--r--lib/Math/Complex.pm1180
-rw-r--r--lib/Net/FTP.pm943
-rw-r--r--lib/Net/Netrc.pm123
-rw-r--r--lib/Net/Socket.pm332
-rw-r--r--lib/Net/hostent.pm147
-rw-r--r--lib/Net/netent.pm165
-rw-r--r--lib/Net/protoent.pm92
-rw-r--r--lib/Net/servent.pm109
-rw-r--r--lib/Pod/Text.pm20
-rw-r--r--lib/Search/Dict.pm6
-rw-r--r--lib/SelfLoader.pm4
-rw-r--r--lib/Symbol.pm21
-rw-r--r--lib/Sys/Hostname.pm2
-rw-r--r--lib/Sys/Syslog.pm7
-rw-r--r--lib/Term/Cap.pm1
-rw-r--r--lib/Term/Complete.pm8
-rw-r--r--lib/Term/ReadLine.pm4
-rw-r--r--lib/Test/Harness.pm76
-rw-r--r--lib/Text/Abbrev.pm47
-rw-r--r--lib/Text/ParseWords.pm2
-rw-r--r--lib/Text/Soundex.pm2
-rw-r--r--lib/Text/Tabs.pm6
-rw-r--r--lib/Text/Wrap.pm38
-rw-r--r--lib/Tie/RefHash.pm123
-rw-r--r--lib/Time/Local.pm27
-rw-r--r--lib/Time/gmtime.pm87
-rw-r--r--lib/Time/localtime.pm83
-rw-r--r--lib/Time/tm.pm27
-rw-r--r--lib/UNIVERSAL.pm81
-rw-r--r--lib/User/grent.pm91
-rw-r--r--lib/User/pwent.pm101
-rw-r--r--lib/abbrev.pl2
-rw-r--r--lib/bigint.pl28
-rw-r--r--lib/blib.pm70
-rw-r--r--lib/complete.pl2
-rwxr-xr-x[-rw-r--r--]lib/diagnostics.pm62
-rw-r--r--lib/getcwd.pl6
-rw-r--r--lib/getopts.pl9
-rw-r--r--lib/lib.pm6
-rw-r--r--lib/locale.pm33
-rw-r--r--lib/look.pl6
-rw-r--r--lib/newgetopt.pl8
-rw-r--r--lib/open3.pl4
-rw-r--r--lib/overload.pm6
-rw-r--r--lib/perl5db.pl676
-rw-r--r--lib/sigtrap.pm40
-rw-r--r--lib/splain507
-rw-r--r--lib/strict.pm30
-rw-r--r--lib/subs.pm7
-rw-r--r--lib/syslog.pl6
-rw-r--r--lib/termcap.pl3
-rw-r--r--lib/timelocal.pl109
-rw-r--r--lib/vars.pm5
-rwxr-xr-xmakeaperl.SH4
-rwxr-xr-xmakedepend.SH31
-rw-r--r--malloc.c288
-rw-r--r--mg.c355
-rw-r--r--mg.h4
-rwxr-xr-x[-rw-r--r--]minimod.pl0
-rw-r--r--miniperlmain.c1
-rwxr-xr-xmyconfig2
-rw-r--r--nostdio.h26
-rw-r--r--op.c464
-rw-r--r--op.h16
-rw-r--r--opcode.h66
-rwxr-xr-xopcode.pl50
-rw-r--r--os2/Changes124
-rw-r--r--os2/Makefile.SHs92
-rw-r--r--os2/OS2/ExtAttr/Changes5
-rw-r--r--os2/OS2/ExtAttr/ExtAttr.pm186
-rw-r--r--os2/OS2/ExtAttr/ExtAttr.xs193
-rw-r--r--os2/OS2/ExtAttr/MANIFEST8
-rw-r--r--os2/OS2/ExtAttr/Makefile.PL11
-rw-r--r--os2/OS2/ExtAttr/myea.h2
-rw-r--r--os2/OS2/ExtAttr/t/os2_ea.t79
-rw-r--r--os2/OS2/ExtAttr/typemap2
-rw-r--r--os2/OS2/PrfDB/Changes5
-rw-r--r--os2/OS2/PrfDB/MANIFEST7
-rw-r--r--os2/OS2/PrfDB/Makefile.PL11
-rw-r--r--os2/OS2/PrfDB/PrfDB.pm314
-rw-r--r--os2/OS2/PrfDB/PrfDB.xs131
-rw-r--r--os2/OS2/PrfDB/t/os2_prfdb.t185
-rw-r--r--os2/OS2/PrfDB/typemap14
-rw-r--r--os2/OS2/Process/MANIFEST4
-rw-r--r--os2/OS2/Process/Makefile.PL11
-rw-r--r--os2/OS2/Process/Process.pm112
-rw-r--r--os2/OS2/Process/Process.xs154
-rw-r--r--os2/OS2/REXX/Changes4
-rw-r--r--os2/OS2/REXX/MANIFEST14
-rw-r--r--os2/OS2/REXX/Makefile.PL8
-rw-r--r--os2/OS2/REXX/REXX.pm387
-rw-r--r--os2/OS2/REXX/REXX.xs484
-rw-r--r--os2/OS2/REXX/t/rx_cmprt.t40
-rw-r--r--os2/OS2/REXX/t/rx_dllld.t36
-rw-r--r--os2/OS2/REXX/t/rx_objcall.t33
-rw-r--r--os2/OS2/REXX/t/rx_sql.test97
-rw-r--r--os2/OS2/REXX/t/rx_tiesql.test86
-rw-r--r--os2/OS2/REXX/t/rx_tievar.t88
-rw-r--r--os2/OS2/REXX/t/rx_tieydb.t31
-rw-r--r--os2/OS2/REXX/t/rx_varset.t39
-rw-r--r--os2/OS2/REXX/t/rx_vrexx.t59
-rw-r--r--os2/diff.configure829
-rw-r--r--os2/dlfcn.h3
-rw-r--r--os2/notes27
-rw-r--r--os2/os2.c799
-rw-r--r--os2/os2ish.h52
-rw-r--r--os2/perl2cmd.pl3
-rw-r--r--patchlevel.h2
-rw-r--r--perl.c273
-rw-r--r--perl.h632
-rwxr-xr-xperl_exp.SH39
-rw-r--r--perlio.c643
-rw-r--r--perlio.h199
-rw-r--r--perlsdio.h297
-rw-r--r--perlsfio.h58
-rw-r--r--perly.c2783
-rw-r--r--perly.c.diff266
-rw-r--r--perly.h60
-rw-r--r--perly.y149
-rw-r--r--plan9/buildinfo2
-rw-r--r--plan9/config.plan9123
-rw-r--r--plan9/exclude15
-rw-r--r--plan9/fndvers9
-rw-r--r--plan9/genconfig.pl19
-rw-r--r--plan9/mkfile24
-rw-r--r--plan9/perlplan9.doc16
-rw-r--r--plan9/perlplan9.pod6
-rw-r--r--plan9/setup.rc9
-rw-r--r--plan9/versnum8
-rw-r--r--pod/Makefile19
-rw-r--r--pod/buildtoc16
-rw-r--r--pod/checkpods.PL74
-rw-r--r--pod/perl.pod66
-rw-r--r--pod/perlapio.pod274
-rw-r--r--pod/perlbook.pod25
-rw-r--r--pod/perlbot.pod4
-rw-r--r--pod/perlcall.pod90
-rw-r--r--pod/perldata.pod106
-rw-r--r--pod/perldebug.pod396
-rw-r--r--pod/perldiag.pod455
-rw-r--r--pod/perldsc.pod64
-rw-r--r--pod/perlembed.pod24
-rw-r--r--pod/perlform.pod18
-rw-r--r--pod/perlfunc.pod485
-rw-r--r--pod/perlguts.pod856
-rw-r--r--pod/perlipc.pod76
-rw-r--r--pod/perllocale.pod614
-rw-r--r--pod/perllol.pod40
-rw-r--r--pod/perlmod.pod488
-rw-r--r--pod/perlnews.pod642
-rw-r--r--pod/perlobj.pod99
-rw-r--r--pod/perlop.pod153
-rw-r--r--pod/perlpod.pod52
-rw-r--r--pod/perlre.pod145
-rw-r--r--pod/perlref.pod85
-rw-r--r--pod/perlrun.pod57
-rw-r--r--pod/perlsec.pod19
-rw-r--r--pod/perlstyle.pod24
-rw-r--r--pod/perlsub.pod167
-rw-r--r--pod/perlsyn.pod57
-rw-r--r--pod/perltie.pod119
-rw-r--r--pod/perltoc.pod78
-rw-r--r--pod/perltoot.pod1779
-rw-r--r--pod/perltrap.pod172
-rw-r--r--pod/perlvar.pod113
-rw-r--r--pod/perlxs.pod27
-rw-r--r--pod/perlxstut.pod41
-rw-r--r--pod/pod2html.PL7
-rw-r--r--pod/pod2latex.PL6
-rw-r--r--pod/pod2man.PL28
-rw-r--r--pod/pod2text.PL6
-rw-r--r--pp.c692
-rw-r--r--pp.h25
-rw-r--r--pp_ctl.c220
-rw-r--r--pp_hot.c245
-rw-r--r--pp_sys.c474
-rw-r--r--proto.h118
-rwxr-xr-xqnx/ar33
-rwxr-xr-xqnx/cpp24
-rw-r--r--regcomp.c288
-rw-r--r--regcomp.h121
-rw-r--r--regexec.c398
-rw-r--r--regexp.h2
-rw-r--r--run.c16
-rw-r--r--scope.c123
-rw-r--r--scope.h38
-rw-r--r--sv.c1314
-rw-r--r--sv.h55
-rw-r--r--t/README2
-rwxr-xr-x[-rw-r--r--]t/TEST24
-rwxr-xr-xt/base/term.t13
-rwxr-xr-xt/comp/package.t6
-rwxr-xr-xt/comp/redef.t79
-rwxr-xr-xt/io/fs.t26
-rwxr-xr-xt/io/read.t26
-rwxr-xr-xt/lib/abbrev.t51
-rwxr-xr-xt/lib/anydbm.t4
-rwxr-xr-xt/lib/autoloader.t100
-rwxr-xr-xt/lib/basename.t107
-rwxr-xr-xt/lib/bigintpm.t7
-rwxr-xr-xt/lib/checktree.t19
-rwxr-xr-xt/lib/complex.t254
-rwxr-xr-xt/lib/db-btree.t274
-rwxr-xr-xt/lib/db-hash.t165
-rwxr-xr-xt/lib/db-recno.t160
-rwxr-xr-xt/lib/env.t18
-rwxr-xr-xt/lib/fatal.t23
-rwxr-xr-xt/lib/filecache.t25
-rwxr-xr-xt/lib/filecopy.t43
-rwxr-xr-xt/lib/filefind.t13
-rwxr-xr-xt/lib/filehand.t57
-rwxr-xr-xt/lib/filepath.t20
-rwxr-xr-xt/lib/findbin.t13
-rwxr-xr-xt/lib/gdbm.t4
-rwxr-xr-xt/lib/getopt.t73
-rwxr-xr-xt/lib/hostname.t19
-rwxr-xr-xt/lib/io_pipe.t2
-rwxr-xr-xt/lib/io_sock.t6
-rwxr-xr-xt/lib/io_taint.t48
-rwxr-xr-xt/lib/io_udp.t7
-rwxr-xr-xt/lib/ndbm.t4
-rwxr-xr-xt/lib/odbm.t4
-rwxr-xr-xt/lib/opcode.t2
-rwxr-xr-xt/lib/parsewords.t28
-rwxr-xr-xt/lib/posix.t23
-rwxr-xr-xt/lib/safe2.t3
-rwxr-xr-xt/lib/sdbm.t4
-rwxr-xr-xt/lib/searchdict.t65
-rwxr-xr-xt/lib/selectsaver.t28
-rwxr-xr-xt/lib/socket.t8
-rwxr-xr-xt/lib/symbol.t52
-rwxr-xr-xt/lib/texttabs.t28
-rwxr-xr-xt/lib/textwrap.t40
-rwxr-xr-xt/lib/timelocal.t87
-rwxr-xr-xt/op/bop.t55
-rwxr-xr-xt/op/delete.t22
-rwxr-xr-xt/op/each.t23
-rwxr-xr-xt/op/glob.t9
-rwxr-xr-xt/op/gv.t59
-rwxr-xr-xt/op/inc.t52
-rwxr-xr-xt/op/magic.t2
-rwxr-xr-xt/op/misc.t33
-rwxr-xr-xt/op/overload.t7
-rwxr-xr-xt/op/pack.t37
-rw-r--r--t/op/re_tests36
-rwxr-xr-xt/op/readdir.t2
-rwxr-xr-xt/op/recurse.t90
-rwxr-xr-xt/op/ref.t26
-rwxr-xr-xt/op/sort.t28
-rwxr-xr-xt/op/split.t9
-rwxr-xr-xt/op/stat.t5
-rwxr-xr-xt/op/substr.t23
-rwxr-xr-xt/op/sysio.t173
-rwxr-xr-xt/op/tie.t37
-rwxr-xr-xt/op/write.t34
-rw-r--r--t/re_tests3
-rw-r--r--taint.c80
-rw-r--r--toke.c746
-rw-r--r--universal.c86
-rw-r--r--unixish.h14
-rw-r--r--util.c1367
-rw-r--r--utils/Makefile8
-rw-r--r--utils/c2ph.PL92
-rw-r--r--utils/h2ph.PL126
-rw-r--r--utils/h2xs.PL251
-rw-r--r--utils/perlbug.PL8
-rw-r--r--utils/perldoc.PL41
-rw-r--r--utils/pl2pm.PL8
-rw-r--r--utils/splain.PL47
-rw-r--r--vms/Makefile218
-rw-r--r--vms/config.vms327
-rw-r--r--vms/descrip.mms93
-rw-r--r--vms/ext/DCLsym/0README.txt21
-rw-r--r--vms/ext/DCLsym/DCLsym.pm268
-rw-r--r--vms/ext/DCLsym/DCLsym.xs151
-rw-r--r--vms/ext/DCLsym/Makefile.PL3
-rw-r--r--vms/ext/DCLsym/test.pl41
-rw-r--r--vms/ext/Stdio/Stdio.pm45
-rw-r--r--vms/ext/Stdio/Stdio.xs10
-rw-r--r--[-rwxr-xr-x]vms/ext/Stdio/test.pl23
-rw-r--r--[-rwxr-xr-x]vms/ext/filespec.t7
-rw-r--r--[-rwxr-xr-x]vms/fndvers.com0
-rw-r--r--vms/gen_shrfls.pl19
-rw-r--r--vms/genconfig.pl23
-rw-r--r--vms/genopt.com15
-rw-r--r--vms/perlvms.pod56
-rw-r--r--vms/perly_c.vms2783
-rw-r--r--vms/perly_h.vms59
-rw-r--r--vms/test.com2
-rw-r--r--vms/vms.c408
-rw-r--r--vms/vmsish.h27
-rwxr-xr-xwritemain.SH2
-rwxr-xr-x[-rw-r--r--]x2p/Makefile.SH36
-rw-r--r--x2p/a2p.c2994
-rw-r--r--x2p/a2p.h22
-rw-r--r--x2p/a2p.man183
-rw-r--r--x2p/a2p.pod156
-rw-r--r--x2p/a2p.y4
-rw-r--r--x2p/a2py.c4
-rwxr-xr-x[-rw-r--r--]x2p/cflags.SH11
-rw-r--r--x2p/find2perl.PL10
-rw-r--r--x2p/handy.h172
-rw-r--r--x2p/proto.h8
-rw-r--r--x2p/s2p.PL81
-rw-r--r--x2p/s2p.man92
-rw-r--r--x2p/str.c6
-rw-r--r--x2p/util.c73
-rw-r--r--x2p/util.h16
469 files changed, 58190 insertions, 22443 deletions
diff --git a/Artistic b/Artistic
index 11f4d82d97..5f221241e8 100644
--- a/Artistic
+++ b/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/Changes b/Changes
index 7a8b96b856..dff8dff101 100644
--- a/Changes
+++ b/Changes
@@ -1,12 +1,5745 @@
Please note: This file provides a summary of significant changes
-between versions and sub-versions of Perl, not a complete list
-of each modification. If you'd like more detailed information,
+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.)
+----------------
+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 <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ Files: dump.c op.c op.h pp.c pp_hot.c
+
+ Title: "Allow any word, including keyword, as label"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: toke.c
+
+ OTHER CORE CHANGES
+
+ Title: "Allow assignment to empty array values during foreach()"
+ From: Chip Salzenberg <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ Files: op.c opcode.pl pp.c pp_ctl.c pp_hot.c
+
+ Title: "Fix core dump on auto-vivification"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp_hot.c
+
+ Title: "Fix core dump on C<open $undef_var, "X">"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp_sys.c
+
+ Title: "Fix -T/-B on globs and globrefs"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp_sys.c
+
+ Title: "Fix memory management of $`, $&, and $'"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp_hot.c regexec.c
+
+ Title: "Fix paren matching during backtracking"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: regexec.c
+
+ Title: "Fix memory leak and std{in,out,err} death in perl_{con,de}str
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: miniperlmain.c perl.c perl.h sv.c
+
+ Title: "Discard garbage bytes at end of prototype()"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp.c
+
+ Title: "Fix local($pack::{foo})"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: global.sym pp.c pp_hot.c proto.h scope.c
+
+ Title: "Fix for AmigaOS - inplace operation"
+ From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de>
+ 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 <chip@atlantic.net>
+ Files: perl.c
+
+ Title: "Re: Bug in formline "
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ 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 <chip@atlantic.net>
+ Files: pp_hot.c
+
+ Title: "Fix %ENV assignment when environment starts out empty"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: hv.c
+
+ Title: "Properly support and document newRV{,_inc,_noinc}"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: global.sym pod/perlguts.pod sv.c sv.h
+
+ Title: "Support SvREADONLY on arrays"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: av.c
+
+ Title: "Allow lvalue pos inside recursive function"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: op.c pp.c pp_ctl.c pp_hot.c
+
+ PORTABILITY
+
+ Title: "Eliminate PerlIO warnings when setting cnt to -1"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: perlio.c
+
+ Title: "Make $privlib contents compatible with 5.003"
+ From: Chip Salzenberg <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ Files: Configure
+
+ Title: "Homogenize use of "eval exec" hack"
+ From: Chip Salzenberg <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ 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 <roderick@gate.net>
+ 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 <ilya@math.ohio-state.edu>
+ Files: README.os2 os2/Changes os2/Makefile.SHs os2/os2.c os2/os2ish.h
+
+ Title: "VMS patches to 5.003_11"
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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 <jhi@cc.hut.fi>
+ 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 <chip@atlantic.net>
+ 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 <nik@tiuk.ti.com>
+ 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 <gsar@engin.umich.edu>
+ 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 <chip@atlantic.net>
+ Files: Makefile.SH installperl utils/Makefile utils/splain.PL
+
+ Title: "Some h2ph fixes"
+ From: Jeff Okamoto <okamoto@hpcc123.corp.hp.com>
+ 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@ni-s.u-net.com (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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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: pmarquess@bfsec.bt.co.uk (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 <ilya@math.ohio-state.edu>
+ 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 <tchrist@mox.perl.com>
+ 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 <okamoto@hpcc123.corp.hp.com>
+ 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 <tchrist@mox.perl.com>
+ 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 <chip@atlantic.net>
+ Files: perly.c perly.c.diff perly.h perly.y
+
+ Title: "Don't reset $. on open()"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp_sys.c
+
+ Title: "Support *glob{IO} (eventually deprecate *glob{FILEHANDLE})"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pod/perlref.pod pp_hot.c sv.c
+
+ Title: "Don't let expression context force return context"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: op.c
+
+ Title: "Properly convert "1E2" et al to IV/UV"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: doio.c sv.c
+
+ Title: "Fix modulo operator in UV realm"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp.c
+
+ Title: "Fix stat(_) after stat(HANDLE)"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp_sys.c
+
+ Title: "Fix: s/// and "$x =~ $y" under 'use locale'"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: op.c toke.c
+
+ OTHER CORE CHANGES
+
+ Title: "Eliminate spurious warning when splicing undefs"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp.c sv.h
+
+ Title: "Eliminate spurious warning from "x=" operator"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: op.c
+
+ Title: "Fix line numbers near control structures"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: op.c perly.c perly.c.diff perly.y proto.h
+
+ Title: "Don't let scalar unpack() underflow stack"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp.c
+
+ Title: "Fix core dump from precedence bug in "@foo" warning"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: toke.c
+
+ Title: "Move die() to utils.c; add varargs hack to croak()"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp_ctl.c util.c
+
+ Title: "Avoid memcmp() for magnitude test if it thinks char is signed"
+ From: Chip Salzenberg <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ Files: mg.c
+
+ Title: "Re: 5.003_09: PADTMP fix"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ 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 <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ Files: pp.c
+
+ Title: "hints/dgux.sh update"
+ From: Roderick Schertler <roderick@gate.net>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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 <ilya@math.ohio-state.edu>
+ 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 <tchrist@mox.perl.com>
+ 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 <nik@tiuk.ti.com>
+ 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 <chip@atlantic.net>
+ Files: ext/IO/lib/IO/File.pm
+
+ Title: "10+ debugger patch"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ 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 <chip@atlantic.net>
+ Files: ext/IO/lib/IO/Handle.pm
+
+ Title: "Re: Namespace cleanup: Does SDBM need binary compatibility?"
+ From: Hallvard B Furuseth <h.b.furuseth@usit.uio.no>
+ 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: pmarquess@bfsec.bt.co.uk (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: pmarquess@bfsec.bt.co.uk (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 <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ Files: toke.c
+
+ OTHER CORE CHANGES
+
+ Title: "Fix regex matching of chars with high bit set"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: regexec.c
+
+ Title: "Hash key memory corruption fix and naming cleanup"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: hv.c hv.h perl.h
+
+ Title: "Undo broken perf. patch (PADTMP stealing)"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: sv.c
+
+ Title: "Make SV unstudied in sv_gets()"
+ From: Chip Salzenberg <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ Files: t/lib/posix.t util.c
+
+ Title: "Always taint result of sprintf() on float"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: doop.c
+
+ Title: "Fix spurious warning from bitwise string ops"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: doop.c
+
+ Title: "Eliminate warning on {,sys}read(,$newvar,)"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: doop.c pp_sys.c
+
+ Title: "Don't call fcntl(fileno(rsfp)) if !rsfp"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: perl.c
+
+ Title: "Save message when calling __DIE__ hook"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp_ctl.c
+
+ Title: "Namespace cleanup"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: global.sym old_global.sym perl.h
+
+ Title: "Modify perl_exp.SH; create old_perl_exp.SH; document old_*"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: Configure INSTALL MANIFEST old_perl_exp.SH perl_exp.SH
+
+ PORTABILITY
+
+ Title: "Reliable signal patch"
+ From: Kenneth Albanowski <kjahds@kjahds.com>
+ 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 <chip@atlantic.net>
+ Files: pp_sys.c
+
+ Title: "3_09: minor patches for OS/2"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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 <ilya@math.ohio-state.edu>
+ 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@ni-s.u-net.com (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 <chip@atlantic.net>
+ Files: lib/diagnostics.pm pod/perldiag.pod
+
+ DOCUMENTATION
+
+ Title: "Improve documentation for sysread() and syswrite()"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pod/perlfunc.pod
+
+ Title: "Document how to use $SIG{ALRM} and alarm()"
+ From: Roderick Schertler <roderick@ibcinc.com>
+ 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 <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ Files: many... but mostly perly.y and toke.c
+
+ Title: "Re: memory corruption / security bug in sysread,syswrite + pa
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ 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 <chip@atlantic.net>
+ Files: Configure
+
+ Title: "Properly prototype safe{malloc,calloc,realloc,free}."
+ From: Chip Salzenberg <chip@atlantic.net>
+ 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@tiuk.ti.com
+ Msg-ID: <199611211547.PAA15878@pluto>
+ Date: Thu, 21 Nov 1996 15:47:46 GMT
+ Files: universal.c
+
+ Title: "die -> croak"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ 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 <chip@atlantic.net>
+ Files: embed.pl
+
+ Title: "Add new symbols to old_global.sym, too."
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: global.sym old_global.sym
+
+ Title: "Cleanup of {,un}pack('w')."
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp.c
+
+ Title: "Cleanups from Ilya."
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: gv.c malloc.c pod/perlguts.pod pp_ctl.c
+
+ Title: "Fix for unpack('w') on 64-bit systems."
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp.c
+
+ Title: "Re: LC_NUMERIC support is ready + performance"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ 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 <chip@atlantic.net>
+ Files: hv.c hv.h proto.h
+
+ Title: "Mortal stack pre-allocation from Ilya."
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: pp.c pp.h pp_ctl.c pp_hot.c pp_sys.c
+
+ PORTABILITY
+
+ Title: "VMS patches post-5.003_08"
+ From: bailey@hmivax.humgen.upenn.edu (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 <ilya@math.ohio-state.edu>
+ 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 <okamoto@hpcc123.corp.hp.com>
+ 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 <okamoto@hpcc123.corp.hp.com>
+ 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 <chip@atlantic.net>
+ Files: t/lib/db-hash.t
+
+ Title: "Update documentation and warning in I18N::Collate."
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: lib/I18N/Collate.pm
+
+ Title: "Fix bitwise op test; clean up a couple of others"
+ From: Chip Salzenberg <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ Files: t/lib/io_sock.t
+
+ Title: "Re: blib"
+ From: nick@ni-s.u-net.com (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: pmarquess@bfsec.bt.co.uk (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 <gsar@engin.umich.edu>
+ 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: pmarquess@bfsec.bt.co.uk (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 <chip@atlantic.net>
+ Files: pod/perli18n.pod
+
+ BUNDLED UTILITIES
+
+ Title: "Fix type mismatches in x2p's safe{alloc,realloc,free}."
+ From: Chip Salzenberg <chip@atlantic.net>
+ 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 <Tim.Bunce@ig.co.uk>
+ 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 <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ Files: pp.c pp_hot.c sv.c
+
+ Title: "Make code match Camel II re: functions that use $_"
+ From: pmarquess@bfsec.bt.co.uk (Paul Marquess)
+ Files: opcode.pl
+
+ Title: "Provide scalar context on left side of "->""
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: perly.c perly.y
+
+ Title: "Quote bearword package/handle FOO in "funcname FOO => 'bar'""
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: toke.c
+
+
+ OTHER CORE CHANGES
+
+ Title: "Warn on overflow of octal and hex integers"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: proto.h toke.c util.c
+
+ Title: "If -w active, warn for commas and hashes ('#') in qw()"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: toke.c
+
+ Title: "Fixes for pack('w')"
+ From: Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
+ Files: pp.c t/op/pack.t
+
+ Title: "More complete output from sv_dump()"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Files: sv.c
+
+ Title: "Major '..' and debugger patches"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Files: lib/perl5db.pl op.c pp_ctl.c scope.c scope.h
+
+ Title: "Fix for formline()"
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ 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 <gsar@engin.umich.edu>
+ 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 <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ Files: MANIFEST Makefile.SH old_embed.pl old_global.sym
+
+
+ PORTABILITY
+
+ Title: "Miscellaneous VMS fixes"
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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" <pueschel@imsdd.meb.uni-bonn.de>
+ 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 (pmarquess@bfsec.bt.co.uk)
+ 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 <chip@atlantic.net>
+ 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 <chip@atlantic.net>
+ 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 <ilya@math.ohio-state.edu>
+
+ os2/Changes added.
+
+Index: Makefile.SH
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ Better error message for overload.
+
+Index: hints/os2.sh
+
+ Date: Wed, 9 Oct 1996 22:29:44 -0400 (EDT)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ `bool' entry added.
+
+Index: lib/ExtUtils/xsubpp
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+ 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 <aas@bergen.sn.no>
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <chip@atlantic.net>
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ added.
+
+Index: os2/Makefile.SHs
+
+ Date: Wed, 9 Oct 1996 22:29:44 -0400 (EDT)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ /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 <ilya@math.ohio-state.edu>
+
+ 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 <Tim.Bunce@ig.co.uk>
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <pfeifer@charly.informatik.uni-dortmund.de>
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ $^E under OS/2.
+
+Index: pp.c
+
+ Date: 20 Sep 1996 13:17:14 +0200
+ From: Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
+ 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 <gsar@engin.umich.edu>
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+
+ 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 <spider@orb.nashua.nh.us>
+ 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 <pfeifer@charly.informatik.uni-dortmund.de>
+ 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 <gsar@engin.umich.edu>
+ Subject: more t/op/sort.t tests
+
+Index: util.c
+
+ Date: Wed, 9 Oct 1996 22:32:22 -0400 (EDT)
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+
+ 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 <doughera@lafcol.lafayette.edu>
+
+# 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.)
+
+Patch and enjoy,
+
+ Andy Dougherty doughera@lafcol.lafayette.edu
+ Dept. of Physics
+ Lafayette College, Easton PA 18042
+
+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 <jhi@alpha.hut.fi>
+ 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 <aas@aas.no>
+ 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 <k@anna.in-berlin.de>
+ 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 <jhi@alpha.hut.fi>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Subject: VMS patches to 5.003_05
+
+Index: doop.c
+
+ Date: Mon, 30 Sep 1996 01:13:28 -0400
+ From: Spider Boardman <spider@Orb.Nashua.NH.US>
+ 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 <aas@bergen.sn.no>
+ 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 <jhi@alpha.hut.fi>
+ 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 <jhi@alpha.hut.fi>
+ 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 <k@anna.in-berlin.de>
+ 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 <spider@Orb.Nashua.NH.US>
+ 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 <jhi@alpha.hut.fi>
+ 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 <kjahds@kjahds.com>
+ 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 <k@anna.in-berlin.de>
+ 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 <gsar@engin.umich.edu>
+ 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 <spider@Orb.Nashua.NH.US>
+ 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 <gsar@engin.umich.edu>
+ 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 <aas@bergen.sn.no>
+ 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 <spider@Orb.Nashua.NH.US>
+
+ 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 <aas@bergen.sn.no>
+ 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 <jhi@cc.hut.fi>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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 <aas@bergen.sn.no>
+ 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 <aas@bergen.sn.no>
+ Subject: File::Basename documentation patch
+
+ Date: Mon, 30 Sep 1996 00:54:37 -0400
+ From: Spider Boardman <spider@Orb.Nashua.NH.US>
+
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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 <jhi@alpha.hut.fi>
+ 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 <jhi@alpha.hut.fi>
+ 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 <aas@aas.no>
+ 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 <aas@bergen.sn.no>
+ 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 <pfeifer@charly.informatik.uni-dortmund.de>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Subject: VMS patches to 5.003_05
+
+Index: lib/Text/Abbrev.pm
+
+ Date: 23 Sep 1996 11:33:01 +0200
+ From: Ulrich Pfeifer <pfeifer@charly.informatik.uni-dortmund.de>
+ 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 <jhi@alpha.hut.fi>
+ 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 <ilya@math.ohio-state.edu>
+ 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 <salzench@nielsenmedia.com>
+ 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 <spider@Orb.Nashua.NH.US>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Subject: VMS patches to 5.003_05
+
+ Date: Fri, 4 Oct 1996 12:38:31 -0400 (EDT)
+ From: Chip Salzenberg <salzench@nielsenmedia.com>
+ 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 <spider@Orb.Nashua.NH.US>
+ 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 <roderick@gate.net>
+ 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 <gsar@engin.umich.edu>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Subject: VMS patches to 5.003_05
+
+Index: perl.h
+
+ Date: Sat, 21 Sep 1996 21:33:15 -0400 (EDT)
+ From: Kenneth Albanowski <kjahds@kjahds.com>
+ 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 <spider@Orb.Nashua.NH.US>
+ 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 <jhi@alpha.hut.fi>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Subject: VMS patches to 5.003_05
+
+Index: pod/Makefile
+
+ Date: Mon, 7 Oct 1996 22:03:00 +0300
+ From: Jarkko Hietaniemi <jhi@alpha.hut.fi>
+ 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 <jhi@alpha.hut.fi>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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 <okamoto@hpcc123.corp.hp.com>
+ 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 <jhi@alpha.hut.fi>
+ 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 <roderick@gate.net>
+ 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 <kjahds@kjahds.com>
+ 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 <kjahds@kjahds.com>
+ 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 <gsar@engin.umich.edu>
+ 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 <roderick@gate.net>
+ 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 <jhi@alpha.hut.fi>
+ 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 <spider@Orb.Nashua.NH.US>
+
+ 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 <spider@Orb.Nashua.NH.US>
+ 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 <jhi@alpha.hut.fi>
+ 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 <spider@Orb.Nashua.NH.US>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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 <jhi@alpha.hut.fi>
+ 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 <gsar@engin.umich.edu>
+ 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 <jhi@alpha.hut.fi>
+ 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 <jhi@alpha.hut.fi>
+ 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 <aas@aas.no>
+ 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 <pfeifer@charly.informatik.uni-dortmund.de>
+ 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 <jhi@alpha.hut.fi>
+ 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 <aas@aas.no>
+ 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 <spider@Orb.Nashua.NH.US>
+
+ 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 <aas@aas.no>
+ 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 <spider@Orb.Nashua.NH.US>
+
+ Fix the number of tests.
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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 <aas@aas.no>
+ 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 <jhi@alpha.hut.fi>
+ 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 <jhi@alpha.hut.fi>
+ 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 <aas@aas.no>
+ 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 <aas@aas.no>
+ 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 <aas@aas.no>
+ 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 <aas@aas.no>
+ 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 <aas@aas.no>
+ 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 <aas@aas.no>
+ 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 <aas@aas.no>
+ 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 <jhi@alpha.hut.fi>
+ 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 <aas@aas.no>
+ 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 <aas@aas.no>
+ 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 <jhi@alpha.hut.fi>
+ 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 <jhi@alpha.hut.fi>
+ 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 <aas@aas.no>
+ 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 <jhi@alpha.hut.fi>
+ 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 <aas@aas.no>
+ 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 <aas@aas.no>
+ 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 <aas@aas.no>
+ 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 <spider@Orb.Nashua.NH.US>
+
+ 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 <aas@aas.no>
+ 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 <aas@aas.no>
+ 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 <aas@aas.no>
+ 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 <spider@Orb.Nashua.NH.US>
+ 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 <jhi@alpha.hut.fi>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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 <jhi@alpha.hut.fi>
+ 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 <jhi@alpha.hut.fi>
+ 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 <jhi@alpha.hut.fi>
+ 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 <gsar@engin.umich.edu>
+ 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 <gsar@engin.umich.edu>
+ 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 <jhi@alpha.hut.fi>
+ 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 <roehrich@cray.com>
+ 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 <kjahds@kjahds.com>
+ 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 <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Subject: VMS patches to 5.003_05
+
+Index: vms/descrip.mms
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Subject: VMS patches to 5.003_05
+
+Index: vms/genconfig.pl
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Subject: VMS patches to 5.003_05
+
+Index: vms/perlvms.pod
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ Subject: VMS patches to 5.003_05
+
+Index: vms/vms.c
+
+ Date: Thu, 03 Oct 1996 16:31:46 -0400 (EDT)
+ From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
+ 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 <doughera@lafcol.lafayette.edu>
+
+# 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}'
+
+Patch and enjoy,
+
+ Andy Dougherty doughera@lafcol.lafayette.edu
+ Dept. of Physics
+ Lafayette College, Easton PA 18042
+
+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 <gsar@engin.umich.edu>
+
+ 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 <ilya@math.ohio-state.edu>
+ 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 <salzench@nielsenmedia.com>
+ Subject: No AutoLoader for Fcntl
+
+ Just like Socket, Fcntl doesn't need splitting and AutoLoading.
+
+Index: ext/FileHandle/FileHandle.pm
+
+ From: Roderick Schertler <roderick@gate.net>
+ 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 <k@anna.in-berlin.de>
+ 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 <gsar@engin.umich.edu>
+ 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 <gsar@engin.umich.edu>
+
+ 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 <roderick@gate.net>
+ 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 <salzench@nielsenmedia.com>
+ 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 <gsar@engin.umich.edu>
+ 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 <gsar@engin.umich.edu>
+ 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 <salzench@nielsenmedia.com>
+ 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 <kjahds@kjahds.com>
+ 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 <gsar@engin.umich.edu>
+ 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 <salzench@nielsenmedia.com>
+ 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 <kjahds@kjahds.com>
+ Subject: Pack Patch (was Re: 5.002 - pack/unpack does not do "I" right)
+
+Index: t/op/ref.t
+
+ From: Gurusamy Sarathy <gsar@engin.umich.edu>
+ Subject: Re: \ ( @array ) busted for lexical @array (once more)
+
+Index: universal.c
+
+ Date: Thu, 29 Aug 96 07:05:10 BST
+ From: Graham Barr <bodg@tiuk.ti.com>
+ 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 <ilya@math.ohio-state.edu>
+ 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 <doughera@lafcol.lafayette.edu>
+
+# 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}'
+
+Patch and enjoy,
+
+ Andy Dougherty doughera@lafcol.lafayette.edu
+ Dept. of Physics
+ Lafayette College, Easton PA 18042
+
+
+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
+ <h.b.furuseth@usit.uio.no> 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 <salzench@nielsenmedia.com>
+ 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 <doughera@lafcol.lafayette.edu>
+
+# 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}'
+
+Patch and enjoy,
+
+ Andy Dougherty doughera@lafcol.lafayette.edu
+ Dept. of Physics
+ Lafayette College, Easton PA 18042
+
+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
@@ -174,2986 +5907,3 @@ o Changes in OS-specific and Build-time Support
- 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).
-
--------------
-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.
-
--------------
-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).
-
-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
-
--------------
-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)
-
--------------
-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/Changes5.000 b/Changes5.000
new file mode 100644
index 0000000000..78cab26f14
--- /dev/null
+++ b/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/Changes5.001 b/Changes5.001
new file mode 100644
index 0000000000..c26134a79a
--- /dev/null
+++ b/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/Changes.Conf b/Changes5.002
index a956fd77da..6382d52917 100644
--- a/Changes.Conf
+++ b/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/Changes5.003 b/Changes5.003
new file mode 100644
index 0000000000..daba248a9e
--- /dev/null
+++ b/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/Configure b/Configure
index 982bfdda99..c8ee9f6e5f 100755
--- a/Configure
+++ b/Configure
@@ -20,7 +20,7 @@
# $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 Tue Dec 17 14:33:33 EST 1996 [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]'`
@@ -107,7 +107,8 @@ else
(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
fi
@@ -119,8 +120,8 @@ dynamic_ext=''
extensions=''
known_extensions=''
static_ext=''
+useopcode=''
useposix=''
-usesafe=''
d_bsd=''
d_eunice=''
d_xenix=''
@@ -149,6 +150,7 @@ find=''
flex=''
gcc=''
grep=''
+gzip=''
inews=''
ksh=''
less=''
@@ -160,7 +162,6 @@ lpr=''
ls=''
mail=''
mailx=''
-make=''
mkdir=''
more=''
mv=''
@@ -173,7 +174,6 @@ rm=''
rmail=''
sed=''
sendmail=''
-sh=''
shar=''
sleep=''
smail=''
@@ -191,6 +191,7 @@ uniq=''
uuname=''
vi=''
zcat=''
+zip=''
full_sed=''
libswanted=''
hint=''
@@ -226,12 +227,13 @@ baserev=''
bin=''
binexp=''
installbin=''
+bincompat3=''
+d_bincompat3=''
byteorder=''
cc=''
gccversion=''
ccflags=''
cppflags=''
-mab=''
ldflags=''
lkflags=''
locincpth=''
@@ -284,6 +286,8 @@ d_flexfnam=''
d_flock=''
d_fork=''
d_fsetpos=''
+d_ftime=''
+d_gettimeod=''
d_Gconvert=''
d_getgrps=''
d_gethent=''
@@ -292,10 +296,13 @@ 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_isascii=''
d_killpg=''
@@ -335,6 +342,7 @@ d_rename=''
d_rmdir=''
d_safebcpy=''
d_safemcpy=''
+d_sanemcmp=''
d_select=''
d_sem=''
d_semctl=''
@@ -347,6 +355,7 @@ d_setlocale=''
d_setpgid=''
d_setpgrp2=''
d_bsdpgrp=''
+d_bsdsetpgrp=''
d_setpgrp=''
d_setprior=''
d_setregid=''
@@ -356,6 +365,8 @@ d_setreuid=''
d_setrgid=''
d_setruid=''
d_setsid=''
+d_sfio=''
+usesfio=''
d_shm=''
d_shmat=''
d_shmatprototype=''
@@ -363,11 +374,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=''
@@ -381,6 +389,7 @@ d_stdstdio=''
stdio_base=''
stdio_bufsiz=''
stdio_cnt=''
+stdio_filbuf=''
stdio_ptr=''
d_index=''
d_strchr=''
@@ -390,6 +399,9 @@ d_strerrm=''
d_strerror=''
d_sysernlst=''
d_syserrlst=''
+d_strtod=''
+d_strtol=''
+d_strtoul=''
d_strxfrm=''
d_symlink=''
d_syscall=''
@@ -418,11 +430,9 @@ d_wctomb=''
dlext=''
cccdlflags=''
ccdlflags=''
-d_shrplib=''
dlsrc=''
ld=''
lddlflags=''
-shrpdir=''
usedl=''
fpostype=''
gidtype=''
@@ -459,6 +469,7 @@ d_pwcomment=''
d_pwexpire=''
d_pwquota=''
i_pwd=''
+i_sfio=''
i_stddef=''
i_stdlib=''
i_string=''
@@ -472,11 +483,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 +499,16 @@ i_time=''
timeincl=''
i_unistd=''
i_utime=''
+i_values=''
i_stdarg=''
i_varargs=''
i_varhdr=''
i_vfork=''
intsize=''
libc=''
+libperl=''
+shrpenv=''
+useshrplib=''
glibpth=''
libpth=''
loclibpth=''
@@ -500,6 +517,8 @@ xlibpth=''
libs=''
lns=''
lseektype=''
+make=''
+make_set_make=''
d_mymalloc=''
freetype=''
mallocobj=''
@@ -542,6 +561,7 @@ package=''
spackage=''
pager=''
patchlevel=''
+subversion=''
perladmin=''
perlpath=''
prefix=''
@@ -555,6 +575,7 @@ installscript=''
scriptdir=''
scriptdirexp=''
selecttype=''
+sh=''
sig_name=''
sig_num=''
installsitearch=''
@@ -572,13 +593,13 @@ ssizetype=''
startperl=''
startsh=''
stdchar=''
-subversion=''
sysman=''
uidtype=''
nm_opt=''
nm_so_opt=''
runnm=''
usenm=''
+useperlio=''
incpath=''
mips=''
mips_type=''
@@ -672,8 +693,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 +715,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 /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 +729,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 +739,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@atlantic.net 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
@@ -887,7 +1018,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 +1145,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@atlantic.net).
EOM
echo $n "Continue? [n] $c" >&4
@@ -1155,7 +1286,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 " "
@@ -1211,7 +1345,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@atlantic.net) know how I blew it.
This installation script affects things in two ways:
@@ -1232,74 +1366,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 +1415,6 @@ echo
expr
find
grep
-ln
ls
mkdir
rm
@@ -1366,8 +1431,10 @@ cpp
csh
date
egrep
+gzip
less
line
+ln
more
nroff
perl
@@ -1375,6 +1442,7 @@ pg
sendmail
test
uname
+zip
"
pth=`echo $PATH | sed -e "s/$p_/ /g"`
pth="$pth /lib /usr/lib"
@@ -1422,6 +1490,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 +1612,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,14 +1635,14 @@ 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@atlantic.net
: The metaconfig authors would also appreciate a copy...
- $test -f /lynx.os && osname=lynxos
$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 /bin/mips && /bin/mips && osname=mips
$test -d /NextApps && set X `hostinfo | grep 'NeXT Mach.*:' | \
$sed -e 's/://' -e 's/\./_/'` && osname=next && osvers=$4
@@ -1629,6 +1709,9 @@ EOM
dgux) osname=dgux
osvers="$3"
;;
+ dynixptx*) osname=dynixptx
+ osvers="$3"
+ ;;
freebsd) osname=freebsd
osvers="$3" ;;
genix) osname=genix ;;
@@ -1697,10 +1780,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}*)
@@ -1899,13 +1985,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_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 " "
@@ -1913,7 +2025,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
@@ -1939,12 +2052,20 @@ myarchname="$tarch"
: is AFS running?
echo " "
-if test -d /afs; then
+case "$afs" in
+$define|true) afs=true ;;
+$undef|false) afs=false ;;
+*) if test -d /afs; then
+ afs=true
+ else
+ afs=false
+ fi
+ ;;
+esac
+if $afs; then
echo "AFS may be running... I'll be extra cautious then..." >&4
- afs=true
else
echo "AFS does not seem to be running..." >&4
- afs=false
fi
: decide how portable to be. Allow command line overrides.
@@ -2303,19 +2424,26 @@ else
fi
: set the base revision
-baserev=5.0
+baserev=5
: get the patchlevel
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
@@ -2329,14 +2457,17 @@ eval $prefixit
case "$archlib" in
'')
case "$privlib" in
- '')
- dflt=`./loc . "." $prefixexp/lib /usr/local/lib /usr/lib /lib`
+ '') dflt=`./loc . "." $prefixexp/lib /usr/local/lib /usr/lib /lib`
set dflt
eval $prefixup
;;
- *) version=`LC_ALL=C;export LC_ALL;\
- echo $baserev $patchlevel $subversion | \
- $awk '{print $1 + $2/1000.0 + $3/100000.0}'`
+ *) if test 0 -eq "$subversion"; then
+ version=`echo $baserev $patchlevel | \
+ $awk '{ printf "%d.%03d\n",$1,$2 }'`
+ else
+ version=`echo $baserev $patchlevel $subversion | \
+ $awk '{ printf "%d.%03d%02d\n",$1,$2,$3 }'`
+ fi
dflt="$privlib/$archname/$version"
;;
esac
@@ -2403,6 +2534,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"
@@ -2413,6 +2571,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
@@ -2457,6 +2616,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
@@ -2479,8 +2649,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
@@ -2552,6 +2722,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
@@ -2694,12 +2865,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.
@@ -2771,264 +2943,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
'')
@@ -3297,377 +3211,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 " "
@@ -3807,52 +3520,6 @@ 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';;
@@ -3861,7 +3528,7 @@ case "$optimize" in
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
@@ -3931,7 +3598,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
@@ -4123,121 +3789,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
@@ -4254,6 +3842,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?'
@@ -4301,7 +3890,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
@@ -4319,13 +3908,13 @@ 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 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=''
@@ -4356,7 +3945,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
@@ -4375,25 +3964,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."
@@ -4456,7 +4045,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
@@ -4547,6 +4136,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
@@ -4610,34 +4293,1161 @@ 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' ;;
+ solaris|svr4*|esix*) dflt='-Kpic' ;;
+ irix*) 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|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='yes'
+ also='Building a shared libperl is required for dynamic loading to work on your system.'
+ ;;
+ next*)
+ case "$osvers" in
+ 4*) dflt='yes'
+ also='Building a shared libperl is needed for MAB support.'
+ ;;
+ *) dflt='no'
+ ;;
+ esac
+ ;;
+ sunos)
+ dflt='no'
+ also='Building a shared libperl will definitely not work on SunOS 4.'
+ ;;
+ *) dflt='no'
+ ;;
+ esac
+ ;;
+ $define|true|[Yy]*)
+ dflt='yes'
+ ;;
+ *) dflt='no'
+ ;;
+ 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@atlantic.net)
+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
+ solaris|netbsd)
+ xxx="-R $shrpdir"
+ ;;
+ linux|irix*)
+ xxx="-Wl,-rpath,$shrpdir"
+ ;;
+ *)
+ tmp_shrpenv="env LD_RUN_PATH=$shrpdir"
+ ;;
+ esac
+ case "$xxx" in
+ '') ;;
+ *) 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
+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/^search[ ]*\(.*\)/\1/p' $tans \
+ | ./tr '[A-Z]' '[a-z]' 2>/dev/null`
+ case "$dflt" in
+ .) dflt=.`$sed -n -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";;
+ 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];
- /* This test must come first. <AlanBurlison@unn.unisys.com> */
+ buf[63] = '\0';
+
+ /* This must be 1st test on (which?) platform */
+ /* Alan Burlison <AlanBurlsin@unn.unisys.com> */
Gconvert(0.1, 8, 0, buf);
- if (buf[0] != '.' || buf[1] != '1' || buf[2] != '\0')
- exit(1);
+ 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
@@ -4655,11 +5465,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
@@ -4678,66 +5487,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
@@ -4815,51 +5564,134 @@ 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
@@ -5135,19 +5967,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
@@ -5174,36 +6006,6 @@ full_csh=$csh
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
@@ -5318,262 +6120,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' ;;
- irix*) 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|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
-
-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
@@ -5636,27 +6182,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 &&
- mv dyna.o tmp-dyna.o > /dev/null 2>&1 &&
- $ld $lddlflags -o dyna.$dlext tmp-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
@@ -5950,8 +6500,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
@@ -5966,6 +6516,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
@@ -6369,13 +6938,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];
@@ -6384,6 +6999,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--) {
@@ -6407,9 +7024,15 @@ EOCP
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
@@ -6423,7 +7046,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];
@@ -6432,6 +7077,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--) {
@@ -6455,9 +7102,15 @@ EOCP
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
@@ -6465,6 +7118,60 @@ $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 $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
@@ -6550,6 +7257,54 @@ 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"
+ ;;
+ 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
@@ -6612,34 +7367,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;
@@ -6652,25 +7417,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
@@ -6699,10 +7465,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"
@@ -6715,7 +7481,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
@@ -6797,7 +7563,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 (
@@ -6839,6 +7605,48 @@ esac
set d_stdio_cnt_lval
eval $setvar
+: How to access the stdio _filbuf or __filbuf function.
+: If this fails, check how the getc macro in stdio.h works.
+case "${d_stdio_ptr_lval}${d_stdio_cnt_lval}" in
+${define}${define})
+ : Try $hint value, if any, then _filbuf, __filbuf, _fill, then punt.
+ : _fill is for os/2.
+ xxx='notok'
+ for filbuf in $stdio_filbuf '_filbuf(fp)' '__filbuf(fp) ' '_fill(fp)' ; do
+ $cat >try.c <<EOP
+#include <stdio.h>
+#define FILE_ptr(fp) $stdio_ptr
+#define FILE_cnt(fp) $stdio_cnt
+#define FILE_filbuf(fp) $filbuf
+main() {
+ FILE *fp = fopen("try.c", "r");
+ int c;
+ c = getc(fp);
+ c = FILE_filbuf(fp); /* Just looking for linker errors.*/
+ exit(0);
+}
+EOP
+ if $cc $ccflags $ldflags -o try try.c $libs >/dev/null 2>&1 && ./try; then
+ echo "Your stdio appears to use $filbuf"
+ stdio_filbuf="$filbuf"
+ xxx='ok'
+ break
+ else
+ echo "Hmm. $filbuf doesn't seem to work."
+ fi
+ $rm -f try.c try
+ done
+ case "$xxx" in
+ notok) echo "I can't figure out how to access _filbuf"
+ echo "I'll just have to work around it."
+ d_stdio_ptr_lval="$undef"
+ d_stdio_cnt_lval="$undef"
+ ;;
+ esac
+ ;;
+esac
+
+
: see if _base is also standard
val="$undef"
case "$d_stdstdio" in
@@ -6847,7 +7655,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 (
@@ -6860,7 +7668,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."
@@ -6939,6 +7747,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
@@ -7253,25 +8073,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
'')
@@ -7463,9 +8264,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 */
@@ -7483,8 +8284,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
@@ -7493,16 +8295,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
@@ -7512,11 +8314,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
@@ -7606,6 +8408,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
@@ -7663,8 +8501,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;
@@ -7707,14 +8555,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
@@ -7841,11 +8689,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;
@@ -7936,11 +8783,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;
@@ -8005,13 +8851,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 '
{
@@ -8139,14 +9031,16 @@ main()
printf("int\n");
else
printf("long\n");
+ exit(0);
}
EOM
echo " "
-if $cc $ccflags $ldflags -o ssize ssize.c $libs > /dev/null 2>&1 ; then
+if $cc $ccflags $ldflags -o ssize ssize.c $libs > /dev/null 2>&1 &&
+ ./ssize > /dev/null 2>&1 ; then
ssizetype=`./ssize`
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!)"
+ echo "(I can't compile and run the test program--please enlighten me!)"
$cat <<EOM
I need a type that is the same size as $sizetype, but is guaranteed to
@@ -8303,30 +9197,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
@@ -8665,6 +9535,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
@@ -8677,14 +9551,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")
@@ -8727,19 +9605,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
@@ -8770,7 +9651,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
;;
@@ -8952,6 +9833,7 @@ awk='$awk'
baserev='$baserev'
bash='$bash'
bin='$bin'
+bincompat3='$bincompat3'
binexp='$binexp'
bison='$bison'
byacc='$byacc'
@@ -8991,8 +9873,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'
@@ -9027,14 +9912,18 @@ 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_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_isascii='$d_isascii'
@@ -9082,6 +9971,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'
@@ -9103,18 +9993,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'
@@ -9127,6 +10014,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'
@@ -9185,6 +10075,7 @@ glibpth='$glibpth'
grep='$grep'
groupcat='$groupcat'
groupstype='$groupstype'
+gzip='$gzip'
h_fcntl='$h_fcntl'
h_sysfile='$h_sysfile'
hint='$hint'
@@ -9210,6 +10101,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'
@@ -9222,6 +10114,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'
@@ -9230,11 +10123,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'
@@ -9258,6 +10153,7 @@ ldflags='$ldflags'
less='$less'
lib_ext='$lib_ext'
libc='$libc'
+libperl='$libperl'
libpth='$libpth'
libs='$libs'
libswanted='$libswanted'
@@ -9272,10 +10168,10 @@ lp='$lp'
lpr='$lpr'
ls='$ls'
lseektype='$lseektype'
-mab='$mab'
mail='$mail'
mailx='$mailx'
make='$make'
+make_set_make='$make_set_make'
mallocobj='$mallocobj'
mallocsrc='$mallocsrc'
malloctype='$malloctype'
@@ -9342,7 +10238,7 @@ sh='$sh'
shar='$shar'
sharpbang='$sharpbang'
shmattype='$shmattype'
-shrpdir='$shrpdir'
+shrpenv='$shrpenv'
shsharp='$shsharp'
sig_name='$sig_name'
sig_num='$sig_num'
@@ -9370,6 +10266,7 @@ stdchar='$stdchar'
stdio_base='$stdio_base'
stdio_bufsiz='$stdio_bufsiz'
stdio_cnt='$stdio_cnt'
+stdio_filbuf='$stdio_filbuf'
stdio_ptr='$stdio_ptr'
strings='$strings'
submit='$submit'
@@ -9390,8 +10287,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'
@@ -9399,6 +10299,7 @@ vi='$vi'
voidflags='$voidflags'
xlibpth='$xlibpth'
zcat='$zcat'
+zip='$zip'
EOT
: add special variables
diff --git a/EXTERN.h b/EXTERN.h
index dedd37958c..5741fbfaa4 100644
--- a/EXTERN.h
+++ b/EXTERN.h
@@ -15,12 +15,18 @@
*/
#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
+# define EXTCONST extern const
+# define dEXTCONST const
#endif
#undef INIT
diff --git a/INSTALL b/INSTALL
index dfdcfa2d54..b6296826b0 100644
--- a/INSTALL
+++ b/INSTALL
@@ -4,28 +4,45 @@ 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
make
make test
make install
+ # possibly add these:
+ (cd /usr/include && h2ph *.h sys/*.h)
+ cd pod; make html && mv *.html <www home dir> && cd ..
+ cd pod; make tex && <process the latex files> && cd ..
+
Each of these is explained in further detail below.
+For information on non-Unix systems, see the section on
+L<"Porting Information">, below.
+
+=head1 DESCRIPTION
+
You should probably at least skim through this entire document before
proceeding. Special notes specific to this release are identified
by B<NOTE>.
+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.
+
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.
-=head1 DESCRIPTION
+=head1 Space Requirements.
-The following is the procedures you need to follow in order to successfully
-build perl.
+The complete perl5 source tree takes up about 7 MB of disk space.
+The complete tree after completing C<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.
@@ -33,7 +50,7 @@ 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
@@ -42,7 +59,22 @@ 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
+call themselves i486, while others use 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.
@@ -85,35 +117,39 @@ then Configure will suggest /opt/perl/lib instead of
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.
=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.
+
+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
@@ -319,7 +355,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:
@@ -346,6 +381,137 @@ installed on multiple systems. Here's one way to do that:
cd /usr/local # Or wherever you specified as $prefix
tar xvf perl5-archive.tar
+=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
+meachanism 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 perl5.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 environtment 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 perl5.004 with a shared library. Then, suppose you
+try to build perl5.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.
+
+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 with by changing all the *archlib*
+variables in config.sh, namely archlib, archlib_exp, and
+installarchlib, to point to your new architecture-dependent library.
+
+=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 "disipline" 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.
+
+=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 What if it doesn't work?
=over 4
@@ -358,7 +524,7 @@ 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 C<&-d> at the next Configure prompt and Configure
+flags) you can type C<&-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
@@ -406,7 +572,7 @@ Now, Configure will find your gdbm library and will issue a message:
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
+should answer 'n'. (You'll also have to manually add GDBM_File to
the list of dynamic extensions to build.)
=item Changing Compilers
@@ -419,10 +585,14 @@ 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.
-=item Propagating your changes
+=item Propagating your changes to config.sh
-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>.
+If you 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
@@ -430,7 +600,7 @@ 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
@@ -462,8 +632,36 @@ 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, and VMS ports are in the
+corresponing 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
+L<"http:/www.perl.com/CPAN/ports"> for current information on ports to
+various other operating systems.
+
=back
+=head1 Binary Compatibility With 5.003
+
+Perl 5.003 turned on the EMBED feature by default, which tries to
+avoid possible symbol name conflict by prefixing all global symbols
+with "Perl_". However, its list of global symbols was incomplete.
+This error has been rectified in Perl 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 after
+B<Configure> you should run these two commands:
+
+ perl old_embed.pl
+ sh old_perl_exp.SH
+
+These commands will make your new Perl as binary-compatible with
+version 5.003 as possible.
+
=head1 make depend
This will look for all the includes.
@@ -471,7 +669,9 @@ 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.
+F<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.
@@ -481,6 +681,16 @@ 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.
+Please include the I<output> of the B<./myconfig> shell script
+that comes with the distribution.
+
+[The B<perlbug> program that comes with the perl distribution is
+useful for sending in such reports, but you need to have
+perl compiled and installed before you can use it.]
=over 4
@@ -491,25 +701,6 @@ for further tips and information.
=item *
-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
during the building of extensions, you should run
@@ -517,50 +708,187 @@ during the building of extensions, you should run
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 *
-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, say -DHIDEMYMALLOC.
-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 *
-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
$ccflags, $ldflags, and $lddlflags so that the system's versions of as
-and ld are used.
+and ld are used. 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<-B> option and
+the GCC_EXEC_PREFIX variable.
+
+=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 *
If you run into dynamic loading problems, check your setting of
the LD_LIBRARY_PATH environment variable. Perl 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 *
+
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 I<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 *
+
+If you can't compile successfully, try turning off your compiler's
+optimizier. 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 *
+
+If you still 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.
+
+=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 *
+
+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 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 Warning (will try anyway): No library found for -lposix
+
+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 libries 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 message 'will try anyway' is intended to
+reassure you that the process is continuing.
+
+On the other hand, if you are building GDBM_File and you get the
+message
+
+ Warning (will try anyway): 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 *
+
+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 B<-DCRIPPLED_CC>, B<-K> or B<-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
+
+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.
+
=back
=head1 make test
@@ -568,28 +896,33 @@ with
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.,
+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.,
./perl op/groups.t
+You can also read the individual tests to see if there are any helpful
+comments that apply to your system.
+
B<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.
+C<make test> exercises them. For example, this may happen if you have
+one or more of these environment variables set: C<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.
+C<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 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
@@ -602,10 +935,9 @@ page, 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.)
+You may 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 release.)
If you want to see exactly what will happen without installing
anything, you can run
@@ -648,16 +980,10 @@ $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.
+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.
Most of the documentation in the pod/ directory is also available
in HTML and LaTeX format. Type
@@ -682,17 +1008,17 @@ F</usr/local/lib/perl5/ARCH/VERSION>, where B<ARCH> is your architecture
building (for example, C<5.003>).
B<NOTE:> Due to differences in the C and perl languages, the conversion of
-the header files in not perfect. You may have to hand edit some of the
+the header files in not perfect. You may have to hand edit some of the
converted files to get them to parse correctly. For example, it breaks
spectacularly on type casting and certain structures.
-
+
=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.002 and later ONLY. Instead of
+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.001 (or whatever version you want to run.)
-If you want to retain a version of perl5 prior to perl5.002, you'll
+#!/usr/local/bin/perl5.003 (or whatever version you want to run.)
+If you want to retain a version of perl5 prior to perl5.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.
@@ -706,7 +1032,7 @@ 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 since perl5.002.
+should be usable by all versions of perl5.
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
@@ -729,14 +1055,15 @@ 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
+collisons. This breaks compatability with
+version 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.
+-DNO_EMBED to your ccflags variable in config.sh.
+
+In the future, we certainly hope that most extensions won't need to be
+recompiled for use with a newer version of perl.
=head1 Coexistence with perl4
@@ -768,4 +1095,4 @@ from the original README by Larry Wall.
=head1 LAST MODIFIED
-07 July 1996
+9 October 1996
diff --git a/INTERN.h b/INTERN.h
index d89d2e68a4..76fff3bcac 100644
--- a/INTERN.h
+++ b/INTERN.h
@@ -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/MANIFEST b/MANIFEST
index d78dff0f02..ce57721c36 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,23 +1,29 @@
Artistic The "Artistic License"
Changes Differences from previous versions.
-Changes.Conf Recent changes in the Configure & build process
-configure Crude emulation of GNU configure
+Changes5.000 Differences from perl4.
+Changes5.001 Differences from 5.000.
+Changes5.002 Differences from 5.001.
+Changes5.003 Differences from 5.002.
Configure Portability tool
+configure Crude emulation of GNU configure
Copying The GNU General Public License
EXTERN.h Included before foreign .h files
INSTALL Detailed installation instructions.
INTERN.h Included before domestic .h files
MANIFEST This list of files
Makefile.SH A script that generates Makefile
+Porting/Glossary Glossary of config.sh variables.
README The Instructions
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
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
@@ -89,15 +95,12 @@ 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 (non-a.out) 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
@@ -114,6 +117,7 @@ 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/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
@@ -121,19 +125,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/Opcode/Makefile.PL Opcode extension makefile writer
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
@@ -190,9 +197,11 @@ 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.NeXT Notes about NeXT 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/bsdos.sh Hints for named architecture
@@ -200,7 +209,6 @@ hints/convexos.sh Hints for named architecture
hints/cxux.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
@@ -218,6 +226,7 @@ hints/irix_6_2.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
@@ -227,12 +236,11 @@ hints/ncr_tower.sh Hints for named architecture
hints/netbsd.sh Hints for named architecture
hints/next_3.sh Hints for named architecture
hints/next_3_0.sh Hints for named architecture
-hints/next_3_2.sh Hints for named architecture
-hints/next_3_3.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/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
@@ -247,6 +255,7 @@ 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/unisysdynix.sh Hints for named architecture
hints/utekv.sh Hints for named architecture
@@ -262,7 +271,11 @@ 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/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/Template.pm Structure/member template builder; makes nested types
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
@@ -279,16 +292,19 @@ 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/Fatal.pm Make do-or-die equivalents of functions
lib/File/Basename.pm A module to 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/Find.pm Routines to do a find
lib/File/Path.pm A module to do things like `mkdir -p' and `rm -r'
+lib/File/stat.pm Object-oriented wrapper around CORE::stat
lib/FileCache.pm Keep more files open than the system permits
+lib/FileHandle.pm Backward-compatible front end to IO extension
lib/FindBin.pm Find name of currently executing program
lib/Getopt/Long.pm A module to fetch command options (GetOptions)
lib/Getopt/Std.pm A module to fetch command options (getopt, getopts)
@@ -298,7 +314,14 @@ 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/FTP.pm File Transfer Protocol client
+lib/Net/Netrc.pm Parser for ".netrc" file a la Berkeley UNIX
lib/Net/Ping.pm Ping methods
+lib/Net/Socket.pm Support class for Net::FTP
+lib/Net/hostent.pm Object-oriented wrapper around CORE::gethost*
+lib/Net/netent.pm Object-oriented wrapper around CORE::getnet*
+lib/Net/protoent.pm Object-oriented wrapper around CORE::getproto*
+lib/Net/servent.pm Object-oriented wrapper around CORE::getserv*
lib/Pod/Functions.pm used by pod/splitpod
lib/Pod/Text.pm Convert POD data to formatted ASCII text
lib/Search/Dict.pm A module to do binary search on dictionaries
@@ -318,14 +341,22 @@ 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 Object-oriented wrapper around CORE::gmtime
+lib/Time/localtime.pm Object-oriented wrapper around CORE::localtime
+lib/Time/tm.pm Perl implementation of "struct tm" for {gm,local}time
+lib/UNIVERSAL.pm Base class for ALL classes.
+lib/User/grent.pm Object-oriented wrapper around CORE::getgr*
+lib/User/pwent.pm Object-oriented wrapper around CORE::getpw*
lib/abbrev.pl An abbreviation table builder
lib/assert.pl assertion and panic with stack trace
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
@@ -348,6 +379,7 @@ 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
@@ -357,7 +389,6 @@ 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
@@ -377,17 +408,50 @@ 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/Changes Changelog for OS/2 port
+os2/Makefile.SHs Shared library generation for OS/2
+os2/OS2/ExtAttr/Changes EA access module
+os2/OS2/ExtAttr/ExtAttr.pm EA access module
+os2/OS2/ExtAttr/ExtAttr.xs EA access module
+os2/OS2/ExtAttr/MANIFEST EA access module
+os2/OS2/ExtAttr/Makefile.PL EA access module
+os2/OS2/ExtAttr/myea.h EA access module
+os2/OS2/ExtAttr/t/os2_ea.t EA access module
+os2/OS2/ExtAttr/typemap EA access module
+os2/OS2/PrfDB/Changes System database access module
+os2/OS2/PrfDB/MANIFEST System database access module
+os2/OS2/PrfDB/Makefile.PL System database access module
+os2/OS2/PrfDB/PrfDB.pm System database access module
+os2/OS2/PrfDB/PrfDB.xs System database access module
+os2/OS2/PrfDB/t/os2_prfdb.t System database access module
+os2/OS2/PrfDB/typemap System database access module
+os2/OS2/Process/MANIFEST system() constants in a module
+os2/OS2/Process/Makefile.PL system() constants in a module
+os2/OS2/Process/Process.pm system() constants in a module
+os2/OS2/Process/Process.xs system() constants in a module
+os2/OS2/REXX/Changes DLL access module
+os2/OS2/REXX/MANIFEST DLL access module
+os2/OS2/REXX/Makefile.PL DLL access module
+os2/OS2/REXX/REXX.pm DLL access module
+os2/OS2/REXX/REXX.xs DLL access module
+os2/OS2/REXX/t/rx_cmprt.t DLL access module
+os2/OS2/REXX/t/rx_dllld.t DLL access module
+os2/OS2/REXX/t/rx_objcall.t DLL access module
+os2/OS2/REXX/t/rx_sql.test DLL access module
+os2/OS2/REXX/t/rx_tiesql.test DLL access module
+os2/OS2/REXX/t/rx_tievar.t DLL access module
+os2/OS2/REXX/t/rx_tieydb.t DLL access module
+os2/OS2/REXX/t/rx_varset.t DLL access module
+os2/OS2/REXX/t/rx_vrexx.t DLL access module
+os2/POSIX.mkfifo POSIX.xs patch.
os2/diff.configure Patches to Configure
os2/dl_os2.c Addon for dl_open
os2/dlfcn.h Addon for dl_open
-os2/Makefile.SHs Shared library generation for OS/2
-os2/POSIX.mkfifo POSIX.xs patch.
-os2/README.old previous OS/2 port info, partially relevant.
-os2/notes Notes for perl maintainer
os2/os2.c Additional code for OS/2
os2/os2ish.h Header for OS/2
os2/perl2cmd.pl Corrects installed binaries under OS/2
@@ -395,6 +459,10 @@ patchlevel.h The current patch level of perl
perl.c main()
perl.h Global declarations
perl_exp.SH Creates list of exported symbols for AIX.
+perlio.c C code for PerlIO abstraction.
+perlio.h Interface to 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
@@ -406,7 +474,7 @@ 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/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
@@ -415,9 +483,12 @@ 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
@@ -430,8 +501,10 @@ 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/perllocale.pod Locale support info
+pod/perllol.pod How to use lists of lists
pod/perlmod.pod Module info
+pod/perlnews.pod News of changes since last version
pod/perlobj.pod Object info
pod/perlop.pod Operator info
pod/perlovl.pod Overloading info
@@ -445,6 +518,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
@@ -462,6 +536,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
@@ -490,6 +566,7 @@ 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/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/harness Finer diagnostics from test suite
@@ -499,36 +576,60 @@ 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/english.t See if English works
+t/lib/env.t See if Env works
+t/lib/fatal.t See if Fatal 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_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/gdbm.t See if GDBM_File works
t/lib/ndbm.t See if NDBM_File works
t/lib/odbm.t See if ODBM_File works
t/lib/opcode.t See if Opcode works
t/lib/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/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/op/append.t See if . works
t/op/array.t See if array operations work
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/cond.t See if conditional expressions work
t/op/delete.t See if delete works
@@ -542,6 +643,8 @@ 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
@@ -560,9 +663,10 @@ 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
@@ -574,19 +678,19 @@ 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/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/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
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
+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
@@ -594,9 +698,15 @@ 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
+utils/splain.PL Stand-alone version of diagnostics.pm
vms/Makefile VMS port
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
@@ -604,7 +714,7 @@ vms/ext/Stdio/Stdio.pm VMS options to stdio routines
vms/ext/Stdio/Stdio.xs VMS options to stdio routines
vms/ext/Stdio/test.pl regression tests for VMS::Stdio
vms/ext/filespec.t See if VMS::Filespec funtions work
-vms/fndvers.com parse Perl version from patchlevel.h
+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
@@ -627,16 +737,15 @@ 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.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/Makefile.SH b/Makefile.SH
index 29723737c7..db3b776c01 100755
--- a/Makefile.SH
+++ b/Makefile.SH
@@ -1,3 +1,4 @@
+#! /bin/sh
case $CONFIG in
'')
if test -f config.sh; then TOP=.;
@@ -22,30 +23,20 @@ case "$d_dosuid" in
*) suidperl='';;
esac
-shrpenv=""
-case "$d_shrplib" in
-*define*)
+case "$useshrplib" in
+true)
pldlflags="$cccdlflags"
- patchlevel=`egrep '^#define[ ]+PATCHLEVEL' patchlevel.h \
- | awk '{print $3}'`
- if test -z "$isnext_4"
- then
- case "$patchlevel" in
- *[0-9]) plibsuf=.$so.$patchlevel;;
- *) plibsuf=.$so;;
+ # NeXT-4 specific stuff. Can't we do this in the hint file?
+ case "${osname}${osvers}" in
+ next4*)
+ ld='libtool -dynamic -undefined warning -framework System \
+ -compatibility_version 1 -current_version $(PATCHLEVEL) \
+ -prebind -seg1addr 0x27000000 -install_name $(SHRPDIR)/$@'
+ ;;
esac
- case "$shrpdir" in
- /usr/lib) ;;
- "") ;;
- *) shrpenv="env LD_RUN_PATH=$shrpdir";;
- esac
- else
- # NeXT uses $patchlevel to set the current version of the dynamic
- # library produced later. And the Major release number in the name
- plibsuf=.5.$so
- fi;;
-*) plibsuf=$lib_ext
- pldlflags="";;
+ ;;
+*) pldlflags=''
+ ;;
esac
: Prepare dependency lists for Makefile.
@@ -62,10 +53,7 @@ for f in $static_ext; do
static_list="$static_list lib/auto/$f/$base\$(LIB_EXT)"
done
-: ${bin_sh=/bin/sh}
-
echo "Extracting Makefile (with variable substitutions)"
-rm -f Makefile
$spitshell >Makefile <<!GROK!THIS!
# Makefile.SH
# This file is derived from Makefile.SH. Any changes made here will
@@ -84,7 +72,6 @@ CLDFLAGS = $ldflags
SMALL = $small
LARGE = $large $split
-MAB = $mab
mallocsrc = $mallocsrc
mallocobj = $mallocobj
LNS = $lns
@@ -97,7 +84,7 @@ ranlib = $ranlib
# installman commandline.
bin = $installbin
scriptdir = $scriptdir
-shrpdir = $shrpdir
+shrpdir = $archlibexp/CORE
privlib = $installprivlib
man1dir = $man1dir
man1ext = $man1ext
@@ -110,7 +97,7 @@ LDDLFLAGS = $lddlflags
CCDLFLAGS = $ccdlflags
DLSUFFIX = .$dlext
PLDLFLAGS = $pldlflags
-PLIBSUF = $plibsuf
+LIBPERL = $libperl
SHRPENV = $shrpenv
dynamic_ext = $dynamic_list
@@ -124,8 +111,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,14 +130,15 @@ ARCHOBJS = $archobjs
.SUFFIXES: .c \$(OBJ_EXT)
-SHELL = $bin_sh
+# 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
@@ -173,36 +162,35 @@ 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 universal.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) universal$(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
.c$(OBJ_EXT):
- $(CCCMD) $(MAB) $(PLDLFLAGS) $*.c
+ $(CCCMD) $(PLDLFLAGS) $*.c
all: $(FIRSTMAKEFILE) miniperl $(private) $(plextract) $(public) $(dynamic_ext)
@echo " "; echo " Everything is up to date."
@@ -222,27 +210,15 @@ 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) $(MAB) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(perllib) $(libs)
- @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest
-
miniperlmain$(OBJ_EXT): miniperlmain.c
- $(CCCMD) $(MAB) $(PLDLFLAGS) $*.c
+ $(CCCMD) $(PLDLFLAGS) $*.c
perlmain.c: miniperlmain.c config.sh $(FIRSTMAKEFILE)
sh writemain $(DYNALOADER) $(static_ext) > tmp
sh mv-if-diff tmp perlmain.c
perlmain$(OBJ_EXT): perlmain.c
- $(CCCMD) $(MAB) $(PLDLFLAGS) $*.c
+ $(CCCMD) $(PLDLFLAGS) $*.c
# The file ext.libs is a list of libraries that must be linked in
# for static extensions, e.g. -lm -lgdbm, etc. The individual
@@ -250,79 +226,77 @@ 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) $(MAB) $(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) $(MAB) $(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) $(MAB) $(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*)
-if test -z "$isnext_4"
-then
-$spitshell >>Makefile <<'!NO!SUBS!'
- $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj)
-!NO!SUBS!
-else
-$spitshell >>Makefile <<!GROK!THIS!
- version=$patchlevel; \\
-!GROK!THIS!
-$spitshell >>Makefile <<'!NO!SUBS!'
- libtool -dynamic -undefined warning -framework System \
- -compatibility_version 1 -current_version $$version \
- -prebind -seg1addr 0x27000000 -install_name $(shrpdir)/$@ \
- -o $@ perl.o $(obj)
-!NO!SUBS!
-fi
-;;
-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
-;;
-*)
-if test -z "$isnext_4"
-then
-$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!
-else
-$spitshell >>Makefile <<'!NO!SUBS!'
- libtool -static -o $(perllib) perl.o $(obj)
+ case "$useshrplib" in
+ true)
+ $spitshell >>Makefile <<'!NO!SUBS!'
+ $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs)
!NO!SUBS!
-fi
-;;
-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) $(LIBPERL) $(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) $(LIBPERL) `cat ext.libs` $(libs)
+
+pureperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+ purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs)
+
+quantperl: $& perlmain$(OBJ_EXT) $(LIBPERL) $(DYNALOADER) $(static_ext) ext.libs
+ quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `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) $(MAB) $(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
+ $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(DYNALOADER) $(static_ext) $(LIBPERL) `cat ext.libs` $(libs)
+
+!NO!SUBS!
+
+fi
+
+$spitshell >>Makefile <<'!NO!SUBS!'
sperl$(OBJ_EXT): perl.c perly.h patchlevel.h $(h)
$(RMS) sperl.c
$(LNS) perl.c sperl.c
- $(CCCMD) $(MAB) -DIAMSUID sperl.c
+ $(CCCMD) -DIAMSUID sperl.c
$(RMS) sperl.c
# We have to call our ./makedir because Ultrix 4.3 make can't handle the line
@@ -368,9 +342,10 @@ run_byacc: FORCE
@ echo 'Expect' 130 shift/reduce and 1 reduce/reduce conflict
$(BYACC) -d perly.y
sh $(shellflags) ./perly.fixer y.tab.c perly.c
- sed -e s/stderr/Perl_debug_log/g perly.c >perly.tmp && mv perly.tmp perly.c
- mv y.tab.h perly.h
- echo 'extern YYSTYPE yylval;' >>perly.h
+ 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
- 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
@@ -406,27 +381,36 @@ 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 $@ 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 $@ 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 $@ LIBPERL_A=$(LIBPERL)
clean:
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
-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 ; \
done
- rm -f perl suidperl miniperl $(perllib)
+ rm -f perl suidperl miniperl $(LIBPERL)
+
+realclean: clean _cleaner
+ @echo "Note that make realclean does not delete config.sh"
+
+clobber: clean _cleaner
+ rm -f config.sh cppstdin
+
+distclean: clobber
-realclean: clean
+# Do not 'make _cleaner' directly.
+_cleaner:
-cd os2; rm -f Makefile
-cd pod; $(MAKE) realclean
-cd utils; $(MAKE) realclean
@@ -442,12 +426,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.
@@ -464,7 +442,7 @@ MAKEDEPEND = makedepend
$(FIRSTMAKEFILE): Makefile $(MAKEDEPEND)
$(MAKE) depend MAKEDEPEND=
-config.h: config.sh
+config.h: config_h.SH config.sh
$(SHELL) config_h.SH
perl.exp: perl_exp.SH config.sh
@@ -480,10 +458,14 @@ depend: makedepend
makedepend: makedepend.SH config.sh
sh ./makedepend.SH
-test: miniperl perl preplibrary $(dynamic_ext)
+check test: miniperl perl preplibrary $(dynamic_ext)
- cd t && (rm -f perl$(EXE_EXT); $(LNS) ../perl$(EXE_EXT) perl$(EXE_EXT)) && ./perl TEST </dev/tty
+# Can't depend on lib/Config.pm because that might be where miniperl
+# is crashing.
minitest: miniperl
+ @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
@@ -499,6 +481,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/Porting/Glossary b/Porting/Glossary
new file mode 100644
index 0000000000..da02084b31
--- /dev/null
+++ b/Porting/Glossary
@@ -0,0 +1,1361 @@
+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.
+
+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_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_gethent (d_gethent.U):
+ This variable conditionally defines HAS_GETHOSTENT if gethostent() is
+ available to dup file descriptors.
+
+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_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_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_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'
+
+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.
+
+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 *'.
+
+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/README b/README
index 0a7ab1ce96..7ed5de4b2f 100644
--- a/README
+++ b/README
@@ -75,7 +75,7 @@ defaults.
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/README.os2 b/README.os2
index f56f7eee09..e6782e3dc1 100644
--- a/README.os2
+++ b/README.os2
@@ -1,652 +1,1397 @@
-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.
+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 B<EMX>'s
+F<.INF> docs as well (text form is available in F</emx/doc> in
+B<EMX>'s distribution).
+
+=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
+ - Starting OS/2 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.
+ 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 OS/2 port
+ - setpriority, getpriority
+ - system()
+ - 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 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 B<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 B<Object REXX>. (Is it possible at all? I know
+of no B<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 B<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 C<RSX> - decided to implement.
+
+Cf. L<Prerequisites>.
+
+=head2 Prerequisites
+
+=over 6
+
+=item B<EMX>
+
+B<EMX> runtime is required (may be substituted by B<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 B<RSX> runtime, which
+has much more functions working (like C<fork>, C<popen> and so on). In
+fact B<RSX> is required if there is no C<VCPI> present. Note the
+B<RSX> requires C<DPMI>.
+
+Only the latest runtime is supported, currently C<0.9c>.
+
+One can get different parts of B<EMX> from, say
+
+ ftp://ftp.cdrom.com/pub/os2/emx0.9c/
+ ftp://hobbes.nmsu.edu/os2/unix/gnu/
+
+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 B<RSX>
+
+To run Perl on C<DPMI> platforms one needs B<RSX> runtime. This is
+needed under DOS-inside-OS/2, Win0.3*, Win0.95 and WinNT (see
+L<"Other OSes">). B<RSX> would not work with C<VCPI>
+only, as B<EMX> would, it requires C<DMPI>.
+
+Having B<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 B<RSX> from, say
+
+ ftp://ftp.cdrom.com/pub/os2/emx0.9c/contrib
+ ftp://ftp.uni-bielefeld.de/pub/systems/msdos/misc
+
+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.exe
+
+=item B<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 B<EMX> to truncate file names. This is not supported,
+read B<EMX> docs to see how to do it.
+
+=back
+
+=head2 Starting Perl programs under OS/2
+
+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 C<CMD> or C<4os2>, put
+the following at the start of your perl script:
+
+ extproc perl -x -S
+ #!/usr/bin/perl -my_opts
+
+rename your program to F<foo.cmd>, and start it by typing
+
+ 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.)
+
+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 -x ../../blah/foo.cmd arg1 arg2 arg3
+
+(note that the argument C<-my_opts> is taken care of by the C<#!> line
+in your script).
+
+To understand what the above I<magic> does, read perl docs about C<-S>
+and C<-x> switches - 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
+B<4OS2>, I<associations> of B<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">.
+
+=head2 Starting OS/2 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
+C<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 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 B<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 C<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> B<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 B<RSX>.
+
+C<DPMI> is required for B<RSX>.
+
+=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
+B<EMX> environment I<running>. The latter means that if you just
+installed B<EMX>, and made all the needed changes to F<Config.sys>,
+you may need to reboot in between. Check B<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 B<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
+
+=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 C<zip> files are not absolute, but
+relative to some directory.
+
+Note that the extraction with the stored paths is still necessary
+(default with C<unzip>, specify C<-d> to C<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
+C<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 C<PATH>, and C<*.dll> on
+C<LIBPATH>);
+
+=item Perl_ VIO executable (statically linked)
+
+ unzip perl_aou.zip -d f:/emx.add/bin
+
+(have the directory on C<PATH>);
+
+=item Executables for Perl utilities
+
+ unzip perl_utl.zip -d f:/emx.add/bin
+
+(have the directory on C<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 C<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 C<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 B<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 .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 C<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. 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).
+
+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 B<GNU> C<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 C<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 B<HTML>
+
+If you have some WWW browser available, installed the Perl
+documentation in the source form, and Perl utilities, you can build
+B<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 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 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 B<EMX> development environment, the full
+B<GNU> tool suite (C<gawk> renamed to C<awk>, and B<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/gnu/
+ ftp://ftp.cdrom.com/pub/os2/unix/
+ ftp://ftp.cdrom.com/pub/os2/dev32/
+ ftp://ftp.cdrom.com/pub/os2/emx0.9c/
+
+
+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 C<gcc> is good for C<-Zomf> linking: run C<omflibs>
+script in F</emx/lib> directory.
+
+Check that you have C<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
+C<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>.
+
+Rename F<configure> to F<configure.gnu>. Extract F<Configure> like this
+
+ tar --case-sensitive -vzxf perl5.00409.tar.gz perl5.00409/Configure
- Andy Dougherty <doughera@lafcol.lafayette.edu>
+Change to the directory of extraction.
-========================================================
+=head2 Application of the patches
-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. Some good
-features from Andreas Kaiser port missed this port. However, most of
-the features are available in different form.
-
-!!! Note that [gs]etpriority functions in this port are compatible
-!!! with *nix, not with ak's port!!!
-
-The priorities are absolute, go from 32 to -95, lower is quickier. 0
-is default,
-
-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 extracting 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:
- ~~~~~~~~~~~~~~~
-!!! At the end of this README is independent description of the build
-!!! process by Rocco Caputo.
-
-# 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
- # Ignore the message about missing `ln', and about `c' option
- # to tr.
-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):
- #
- # To run finer tests, cd t && perl harness
-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. The version 5.2.5alpha was OK for the build,
-
-!!!!!!!!!!!!!!!!!
-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 link386.
-c) Get rid of invalid perl.dll on your LIBPATH.
-
-Note the EMX does not support en_us locale (most nobody does ;-). Some
-TCP/IP update could have installed it to your config.sys. You need to
-delete it until EMX is updated to support this newest discovery by IBM.
-
-
-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).
-======================================================
-
-Building with a.out style is supported by the `perl_' target of make.
-Dynamic extensions are not possible with perl_.exe, since boot code
-should return the retvalue on stack, the address of which is not known
-to the extension.
-
-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().
-
-Check A.OUT compile with the following make targets:
-
- aout_test
- aout_install
- aout_clean
-
-======================================================
-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 (works with perl_.exe).
-lib/"all the dbm".t: 1 test should fail (file permission).
-op/fork all fail, as they should (except with perl_.exe)
-op/stat 3 20 35 as they should, 39 (-t on /dev/null) ???? Sometimes 4
-- timing problem ????
-
-Sometimes I have seen segfault in socket ????, only if run with Testing tools.
+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 B<EMX> distribution
+are not suitable for multi-threaded compile (note that currently perl
+is not multithreaded, but is compiled as multithreaded for
+compatibility with B<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
+
+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
+C<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 C<LIBPATH>. After this done the build
+should finish without a lot of fuss. I<One can avoid it if one has the
+correct prebuilt version of F<perl.dll> on C<LIBPATH>.>
+
+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 -I ../lib 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 C<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 B<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 B<EMX> - test fork()s with
+dynamic extension loaded - unsupported now.
+
+=item F<lib/io_sock.t>
+
+Checks C<IO::Socket> module. Some feature of B<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.
-
-Fail: Total 30 subtests (if stat:4 fails) in 10 scripts (one of 10
-is socket, which runs OK standalone). With newer configs I could not
-reproduce most the crashes.
-
-=======================================================
-
-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 X:/bin/sh.exe will be called. The
-name of the shell is not overridable, except the drive letter.
-
-Thus means that you need to pickup some copy of a sh.exe as well (I use one
-from pdksh). The drive X: above is set up automatically during the
-build, is settable in runtime from $ENV{PERL_SH_DRIVE}.
-
-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.
+platforms. You may disable it by setting PERL_BADFREE environment variable
+to 1.
-===================================================
+=head2 Installing the built perl
-OS/2 extensions
-~~~~~~~~~~~~~~~
-Since binaries cannot go into perl distribution, no extensions are
-included. They are available in .../os2/ilyaz directory of CPAN, as
-well as in my directory
- ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2
+Run
-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. Other extensions
-there are OS2::ExtAttribs, OS2::PrfDB for tied access to EAs and .INI
-files - and maybe some other extensions at the time you read it.
+ make install
-Note that OS2 perl defines 2 pseudo-extension functions
-OS2::Copy::copy and DynaLoader::mod2fname.
+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
+C<PATH>, F<perl.dll> to a location on your C<LIBPATH>.
-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...};
+Run
-Two new functions are supported by REXX code,
- REXX_eval 'string';
- REXX_eval_with 'string', REXX_function_name => \&perl_sub_reference;
+ make cmdscripts INSTALLCMDDIR=d:/ir/on/path
-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.
+to convert perl utilities to F<.cmd> files and put them on
+C<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>.
-==================================================================
-== ==
-== User report [my comments in brackets, IZ] ==
-== ==
-==================================================================
+=head2 C<a.out>-style build
-Starting in x:/usr/src, using 4OS2/32 2.5 as the command interpreter on
-OS/2 2.30 with FixPak-17. DAX is installed, but this shouldn't be a
-factor. Drive X is a TVFS virtual drive pointing to several physical
-HPFS drives.
+Proceed as above, but make F<perl_.exe> (see L<"perl_.exe">) by
->>> Make sure that no copies or perl are currently running. Miniperl
- may fail during the build because it will find an older version
- of perl.dll loaded in memory.
+ make perl_
- Close any running perl scripts.
- Shut down anything that might run perl scripts, like cron.
- `emxload -l` to check for loaded versions of perl.
- `emxload -u perl.exe` to unload them.
+test and install by
->>> Pre-load some common utilities:
+ make aout_test
+ make aout_install
- emxload -e sh.exe make.exe ls.exe tr.exe id.exe sed.exe
- SET GCCLOAD=30 (number of minutes to hold the compiler)
-[grep egrep fgrep cat rm uniq basename uniq sort - are not bad too.]
- The theory is that it's faster to demand-load the development tools
- from virtual memory than it is to re-load and re-link them all the
- time. This is definitely true with my system because swapfile.dat
- is on a faster drive than my development environment.
+Manually put F<perl_.exe> to a location on your C<PATH>.
- ls, tr, and id represent the GNU file, text, and shell utilities.
- These may not be needed, but it makes sure that their respective
- DLLs are in memory.
+Since C<perl_> has the extensions prebuilt, it does not suffer from
+the I<dynamic extensions + fork()> syndrome, thus the failing tests
+look like
->>> Unpack the perl 5_002_01 archive onto an HPFS partition.
+ 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.
- tar vxzf perl5_002_01.tar-gz
- cd perl5.002_01
+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
-[Do not forget to extract Configure as described above.]
+ make perl.dll
->>> Read the README, keeping a copy open in another session for reference.
+first.
- start /c /fg less os2/README
+=head1 Build FAQ
->>> Apply the OS/2 patches included with 5.002_01, as per the README.
+=head2 Some C</> became C<\> in pdksh.
- for %m in (os2\diff.*) patch -p0 < %m
- patch -p0 < os2\POSIX.mkfifo
+You have a very old pdksh. See L<Prerequisites>.
-[The patch below is already applied.]
+=head2 C<'errno'> - unresolved external
->>> You may need to apply this patch if you plan to run a non-standard
- Configure (that is, if you defy the README). This patch will ensure
- that Makefile inherits the libraries specified during Configure.
- People running standard perl builds can probably ignore this patch.
+You do not have MT-safe F<db.lib>. See L<Prerequisites>.
-*** os2\Makefile.SHs Mon Mar 25 02:05:00 1996
---- os2\Makefile.SHs.new Fri May 24 10:37:10 1996
-***************
-*** 9,15 ****
- emximp -o perl.imp perl5.def
-
- perl.dll: $(obj) perl5.def perl$(OBJ_EXT)
-! $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) -lsocket perl5.def
-
- perl5.def: perl.linkexp
- echo "LIBRARY 'Perl' INITINSTANCE TERMINSTANCE" > $@
---- 9,15 ----
- emximp -o perl.imp perl5.def
-
- perl.dll: $(obj) perl5.def perl$(OBJ_EXT)
-! $(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj) $(libs) perl5.def
-
- perl5.def: perl.linkexp
- echo "LIBRARY 'Perl' INITINSTANCE TERMINSTANCE" > $@
-***************
-*** 49,55 ****
- 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
-
---- 49,55 ----
- 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) $(libs) -Zmap -Zlinker /map
- awk '{if ($$3 == "") print $$2}' <dummy.map | sort | uniq > perl.map
- rm dummy.exe dummy.map
+=head2 Problems with C<tr>
+
+reported with very old version of C<tr>.
+
+=head2 Some problem (forget which ;-)
+
+You have an older version of F<perl.dll> on your C<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 C<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 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.
->>> Apply the patches from Ilya's perl5.002_01 binary distribution:
+Two additional extensions by Andreas Kaiser, C<OS2::UPM>, and
+C<OS2::FTP>, are included into my ftp directory, mirrored on CPAN.
- touch os2/dlfcn.h os2/dl_os2.c
- patch -p1 < f:\perllib\README.fix1
-
->>> Run Configure. Most people can run it by following the README:
-
- sh Configure -des -D prefix=f:/usr/local
-
- Advanced perl users (experienced C programmers, recommended) can run
- the interactive Configure and answer the questions. When in doubt
- about an answer, check the EMX headers and documentation. Pick the
- default answer if that doesn't help:
-
- sh Configure
-
-[Yet more advanced users just specify the answers on the command line
-of Configure, like I did with prefix.]
-
- Note: You may need to wrap an answer in quotes if it contains
- spaces. For example, "-lsocket -lm".
-
- Note: If you want to add some options to a long default, you can
- use $* to include the default in your answer: "$* -DDEBUGGING".
+=head2 Prebuilt methods:
- Configure warnings and errors, and possible work-arounds:
+=over 4
- I don't know where 'ln' is....
- (ignored; OS/2 doesn't have a ln command)
+=item C<File::Copy::syscopy>
- nm didn't seem to work right. Trying emxomfar instead...
- (nothing to worry about)
-
- The recommended value for $d_shrplib on this machine was "define"!
- (kept the recommended value: y)
-
- Directory f:/usr/lib/perl5/os2/5.00201/CORE doesn't exist.
- (created the directory from another window with
- \usr\bin\mkdir -p f:/usr/lib/perl5/os2/5.00201/CORE
- and then answered: y. Your directory may look different.)
-
-[Ignore this as well, install script will create it for you.]
-
- The recommended value for $i_dlfcn on this machine was "define"!
- (kept the recommended value: y)
-
- The recommended value for $d_fork on this machine was "undef"!
- (kept the recommended value: y)
-
- Figuring out the flag used by open() for non-blocking I/O...
- Seems like we can use O_NONBLOCK.
- This seems to be used for informative purposes only.
- The errors that follow this (including a SIGPIPE) don't seem
- to affect perl at all. These were safely ignored.
+used by C<File::Copy::copy>, see L<File::Copy/copy>.
- What pager is used on your system? [/usr/ucb/more]
- Had to answer "/usr/bin/less.exe" because Configure wants a
- leading / (unix full path). Need to edit config.sh later with
- the real full path to the pager, including the drive letter.
+=item C<DynaLoader::mod2fname>
-[Apparently this setting is never used, so it is safe to ignore it.]
+used by C<DynaLoader> for DLL name mangling.
- Hmm... F:/USR/BIN/sed: Unterminated `s' command
- Perl built fine even with this error, so it seems safe to
- ignore.
+=item C<Cwd::current_drive()>
- Things I did different from the defaults. Most (if not all) of these
- are optional changes. They're listed here to show how good Configure
- is at detecting the system setup.
+Self explanatory.
-[I add the options to put it on command line of Configure, see below.]
+=item C<Cwd::sys_chdir(name)>
- Selected 'none' for the man1 location.
- (I prefer the pod2html version.)
-[-D man1dir=none]
- Selected 'none' for the man3 location.
- (I prefer the pod2html version.)
-[-D man3dir=none]
- Changed the hostname and domain.
- (I wanted to override a dynamic PPP address. This only
- matters if other people will be using your perl build.)
-[-D myhostname=my_host_name -D mydomain=.foo.org]
- Fixed the e-mail address.
- (Put in a known working e-mail address. This only matters
- if other people will be using your perl build.)
-[-D cf_email=root@myhostname.uucp]
- Added some directories to the library search path.
-[-D "libpth=f:/emx/lib/st f:/emx/lib"]
- Added -g to the optimizer/debugger flags.
-[-D optimize=-g]
- Added "-lgdbm -ldb -lcrypt -lbsd" to the additional libraries.
-[ -D "libs=-lsocket -lcrypt -lgdbm"
- the rest of libraries will not be used]
+leaves drive as it is.
->>> Advanced users may want to edit config.sh when prompted by Configure.
- Most (all?) of these changes aren't really necessary:
+=item C<Cwd::change_drive(name)>
- d_getprior='define'
- d_setprior='define'
- (getpriority and setpriority are included in os2.c, but
- Configure doesn't know to look there.)
-[fixed already]
- pager='f:/usr/bin/less.exe'
- (Correcting Configure's insistence on a leading slash.)
- bin_sh='f:/usr/bin/sh.exe'
- (If Configure detects sh.exe somewhere else first. Example:
- it saw sh.exe at /bin/sh.exe on my TVFS drive, but I want
- perl to look for it on the physical F drive.)
- aout_ccflags='... existing flags... -DDEBUGGING'
- aout_cppflags='... existing flags... -DDEBUGGING'
- (If you want to include DEBUGGING for the aout version.)
-[Do not do it, -D optimize=-g will automatically add these flags.]
->>> Allow Configure to make the build scripts.
+=item C<Cwd::sys_is_absolute(name)>
->>> Allow Configure to run `make depend`. Ignore the following warning:
+means has drive letter and is_rooted.
- perl.h:861: warning: `DEBUGGING_MSTATS' redefined
-[corrected now]
-
->>> Rename any existing perl.dll, preventing anything from loading it and
- saving a known working copy in case something goes wrong:
-
- mv /usr/lib/perl.dll /usr/lib/ilya-perl.dll
+=item C<Cwd::sys_is_rooted(name)>
->>> Run `make`, and ignore the following warnings:
-
- perl.h:861: warning: `DEBUGGING_MSTATS' redefined
-[corrected now]
- invalid preprocessing directive name
- emxomf warning: Cycle detected by make_type
- LINK386 : warning L4071: application type not specified; assuming WINDOWCOMPAT
- Warning (will try anyway): No library found for -lposix
- Warning (will try anyway): No library found for -lcposix
- POSIX.c:203: warning: `mkfifo' redefined
- POSIX.c:4603: warning: assignment makes pointer from integer without a cast
-
->>> If `make` dies while "Making DynaLoader (static)", you'll need to
- put miniperl in the OS/2 paths. This step is only necessary if `make`
- can't find miniperl:
-[I would be interested if somebody confirmes this.]
-
- cp perl.dll /usr/lib (where /usr/lib is in your LIBPATH)
- cp miniperl.exe /usr/bin (where /usr/bin is in your PATH)
- make (ignore the errors in the previous step)
-
- This should run to completion.
-
->>> Test the build:
-
- make test
-
- These tests fail:
+means has leading C<[/\\]> (maybe after a drive-letter:).
- io/fs..........FAILED on test 2
-
- "OS/2 is not unix". Test 2 checks the link() command, which
- is not supported by OS/2.
-
- io/pipe........f:/usr/bin/sh.exe: -c requires an argument
- f:/usr/bin/sh.exe: -c requires an argument
- The Unsupported function fork function is unimplemented at
- io/pipe.t line 26.
- FAILED on test 1
-
- More "OS/2 is not unix" errors. Read ahead to find out
- why fork() fails.
-
- op/exec........FAILED on test 4
-
- if (system "true") {print "not ok 4\n";} else \
- {print "ok 4\n";}
-
- This fails for me, but changing it to read like this works:
-
- if (system '\usr\bin\true.cmd') {print "not ok 4\n";} \
- else {print "ok 4\n";}
-
- So you can count this as another "OS/2 is not unix".
+=item C<Cwd::sys_is_relative(name)>
- op/fork........The Unsupported function fork function is \
- unimplemented at op/fork.t line 8.
- FAILED on test 1
+means changes with current dir.
- The dynamically-loaded version of perl currently doesn't
- support fork(). This is a known behavior of EMX.
+=item C<Cwd::sys_cwd(name)>
- op/magic.......
- Process terminated by SIGINT
- ok
+Interface to cwd from B<EMX>. Used by C<Cwd::cwd>.
- The test passed even with the SIGINT message. I don't
- know why, but I won't argue.
+=item C<Cwd::sys_abspath(name, dir)>
- op/stat........ls: /dev: No such file or directory
- f:/usr/bin/sh.exe: ln: not found
- ls: perl: No such file or directory
- FAILED on test 3
+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.
- "OS/2 is not unix". We don't have the ln command.
+=item C<Cwd::extLibpath([type])
- lib/anydbm.....Bad free() ignored at lib/anydbm.t line 51.
- Bad free() ignored at lib/anydbm.t line 51.
- Bad free() ignored at lib/anydbm.t line 51.
- Bad free() ignored during global destruction.
- Bad free() ignored during global destruction.
- Bad free() ignored during global destruction.
- FAILED on test 2
+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>.
- Test 2 looks at the file permissions for a database. "OS/2
- is not unix" so the permissions aren't exactly what this test
- expects.
+=item C<Cwd::extLibpath_set( path [, type ] )>
- lib/db-btree...Bad free() ignored at lib/db-btree.t line 109.
- Bad free() ignored at lib/db-btree.t line 221.
- Bad free() ignored at lib/db-btree.t line 337.
- Bad free() ignored at lib/db-btree.t line 349.
- Bad free() ignored at lib/db-btree.t line 349.
- Bad free() ignored at lib/db-btree.t line 399.
- Bad free() ignored at lib/db-btree.t line 400.
- Bad free() ignored at lib/db-btree.t line 401.
- FAILED on test 20
+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>.
- Another file permissions test fails.
+=back
- lib/db-hash....Bad free() ignored at lib/db-hash.t line 101.
- Bad free() ignored at lib/db-hash.t line 101.
- Bad free() ignored at lib/db-hash.t line 101.
- Bad free() ignored at lib/db-hash.t line 239.
- Bad free() ignored at lib/db-hash.t line 239.
- Bad free() ignored at lib/db-hash.t line 239.
- Bad free() ignored at lib/db-hash.t line 253.
- Bad free() ignored at lib/db-hash.t line 253.
- Bad free() ignored at lib/db-hash.t line 253.
- FAILED on test 16
+(Note that some of these may be moved to different libraries -
+eventually).
- Another file permissions test fails.
- lib/db-recno...Bad free() ignored at lib/db-recno.t line 138.
- Bad free() ignored at lib/db-recno.t line 138.
- FAILED on test 18
+=head2 Misfeatures
- Another file permissions test fails.
+=over 4
- lib/gdbm.......FAILED on test 2
+=item
- Another file permissions test fails.
+Since <flock> is present in B<EMX>, but is not functional, the same is
+true for perl. Here is the list of things which may be "broken" on
+EMX (from EMX docs):
- lib/sdbm.......FAILED on test 2
+ - The functions recvmsg(), sendmsg(), and socketpair() are not
+ implemented.
+ - sock_init() is not required and not implemented.
+ - flock() is not yet implemented (dummy function).
+ - kill:
+ Special treatment of PID=0, PID=1 and PID=-1 is not implemented.
+ - waitpid:
+ WUNTRACED
+ Not implemented.
+ waitpid() is not implemented for negative values of PID.
- Another file permissions test fails.
+Note that C<kill -9> does not work with the current version of EMX.
- Failed 11/94 tests, 88.30% okay.
+=item
- All of which are known differences with unix or documented
- behaviors in EMX. I re-run the test with Ilya's version,
- and the same tests fail. This new build is a success.
-[Note that bad free() mentioned above are bugs in the Berkeley
-DB. They just are more visible under OS/2 with perl free(), because of
-"rigid" function name resolution.
- To get finer tests, cd to ./t and run
- perl harness
-]
+Since F<sh.exe> is used for globing (see L<perlfunc/glob>), the bugs
+of F<sh.exe> plague perl as well.
- (Actually, Ilya's perl release fails an extra test because I don't
- have sed in f:\emx.add. This shows how important it is to configure
- and build perl yourself instead of grabbing pre-built binaries.)
-[Hmm, should not happen... There is no mentions of full_sed under ./t
-directory...]
+In particular, uppercase letters do not work in C<[...]>-patterns with
+the current C<pdksh>.
->>> Cross your fingers and install it:
+=back
- make install
+=head2 Modifications
- Warnings encountered and workarounds presented.:
+Perl modifies some standard C library calls in the following ways:
- WARNING: You've never run 'make test'!!! (Installing anyway.)
- (Lies! All lies! At least it still installs.)
+=over 9
- WARNING: Can't find libperl*.dll* to install into \
- f:/usr/lib/perl5/os2/5.00201/CORE. (Installing other things anyway.)
- (Safe to ignore. The important one, libperl.lib, gets copied.)
+=item C<popen>
- Couldn't copy f:/usr/bin/perl5.00201.exe to f:/usr/bin/perl.exe: \
- No such file or directory
- cp /usr/bin/perl5.00201.exe /usr/bin/perl.exe
+C<my_popen> uses F<sh.exe> if shell is required, cf. L<"PERL_SH_DIR">.
- Couldn't copy f:/usr/bin/perl.exe to /usr/bin/perl.exe: No such \
- file or directory
- (I think this one is safe to ignore since the two directories
- point to the same place.)
+=item C<tmpnam>
->>> Laugh maniacally because you just built and installed your own copy
- of perl, with all the paths set "just so" and with whatever little
- psychotic modifications you've always wanted but were afraid to add.
+is created using C<TMP> or C<TEMP> environment variable, via
+C<tempnam>.
------------------------------------------------------------------------------
+=item C<tmpfile>
-Development tools and versions:
+If the current directory is not writable, file is created using modified
+C<tmpnam>, so there may be a race condition.
- EMX 0.9b with emxfix04 applied.
+=item C<ctermid>
- `ls --version` reports: 'GNU file utilities 3.12'
- `tr --version` reports: 'tr - GNU textutils 1.14'
- `id --version` reports: 'id - GNU sh-utils 1.12'
+a dummy implementation.
- `sed --version` reports: 'GNU sed version 2.05'
- `awk --version` reports: 'Gnu Awk (gawk) 2.15, patchlevel 6'
- `grep --version` reports an illegal option and: 'GNU grep version 2.0'
- (this includes egrep)
+=item C<stat>
+
+C<os2_stat> special-cases F</dev/tty> and F</dev/con>.
+
+=back
+
+=head1 Perl flavors
+
+Because of idiosyncrasies of OS/2 one cannot have all the eggs in the
+same basket (though C<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 B<CRT> DLL. This executable is a
+C<VIO> application.
+
+It can load perl dynamic extensions, and it can fork(). Unfortunately,
+with the current version of B<EMX> it cannot fork() with dynamic
+extensions loaded (may be fixed by patches to B<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 C<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 C<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 <perl___.exe>, but it is a C<PM>
+application.
+
+B<Note.> Usually C<STDIN>, C<STDERR>, and C<STDOUT> of a C<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 C<Emacs> or C<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 C<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 C<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 C<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 C<CRT> is basically forced to reside in a DLL as well (otherwise
+extensions would not be able to use C<CRT>).
+
+=head2 Why chimera build?
+
+Current C<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 C<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-specific, or
+are more important under OS/2 than under other OSes.
+
+=head2 C<PERLLIB_PREFIX>
+
+Specific for OS/2. 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>.
+
+=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 OS/2. Gives the directory part of the location for
+F<sh.exe>.
+
+=head2 C<TMP> or C<TEMP>
+
+Specific for OS/2. 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 C<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 C<XFreeOS/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.
+
+B<Disadvantages:> currently F<sh.exe> of C<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.
+
+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;
- `sort --version` reports: 'sort - GNU textutils 1.14'
- `uniq --version` reports: 'uniq - GNU textutils 1.14'
- `find --version` reports: 'GNU find version 4.1'
+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.
- KSH_VERSION='@(#)PD KSH v5.2.4 96/01/17'
- (Ilya's patched version.)
+=head1 AUTHOR
- `make --version` reports: 'GNU Make version 3.74'
- (Ilya's patched version.)
+Ilya Zakharevich, ilya@math.ohio-state.edu
- `emxrev` reports:
- EMX : revision = 42
- EMXIO : revision = 40
- EMXLIBC : revision = 40
- EMXLIBCM : revision = 43
- EMXLIBCS : revision = 43
- EMXWRAP : revision = 40
+=head1 SEE ALSO
------------------------------------------------------------------------------
+perl(1).
-Rocco
-<troc@shadow.net>
+=cut
diff --git a/README.qnx b/README.qnx
new file mode 100644
index 0000000000..0cfe3533ca
--- /dev/null
+++ b/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/README.vms b/README.vms
index ba0ba190fd..9a6a712f4a 100644
--- a/README.vms
+++ b/README.vms
@@ -292,10 +292,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 +305,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 +342,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/av.c b/av.c
index dfd25df760..554f2619a9 100644
--- a/av.c
+++ b/av.c
@@ -153,12 +153,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 +179,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,9 +195,8 @@ SV *val;
if (key < 0)
return 0;
}
- if (!val)
- val = &sv_undef;
-
+ if (SvREADONLY(av) && key >= AvFILL(av))
+ croak(no_modify);
if (key > AvMAX(av))
av_extend(av,key);
if (AvREIFY(av))
@@ -327,10 +336,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;
@@ -359,6 +364,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))
@@ -376,6 +383,8 @@ register I32 num;
if (!av || num <= 0)
return;
+ if (SvREADONLY(av))
+ croak(no_modify);
if (!AvREAL(av)) {
if (AvREIFY(av))
av_reify(av);
@@ -419,6 +428,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/av.h b/av.h
index 93dcc0cfdc..56b6e325d0 100644
--- a/av.h
+++ b/av.h
@@ -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/cflags.SH b/cflags.SH
index 88aa4e0961..39e96cc1ee 100755
--- a/cflags.SH
+++ b/cflags.SH
@@ -123,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/compat3.sym b/compat3.sym
new file mode 100644
index 0000000000..db53dd67be
--- /dev/null
+++ b/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/config_H b/config_H
index 0b87638f7c..11e9033ae2 100644
--- a/config_H
+++ b/config_H
@@ -14,9 +14,9 @@
* $Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram 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_
@@ -32,11 +32,14 @@
* 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" /**/
+#define BIN "/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 +89,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 +98,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 +149,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 +241,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,6 +255,17 @@
*/
#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
@@ -278,17 +292,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 +308,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 +346,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 +537,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 +545,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 +584,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 +592,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 +614,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 +627,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 +698,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,13 +716,33 @@
* This symbol is defined if the FILE_cnt macro can be used as an
* lvalue.
*/
+/* FILE_filbuf:
+ * This macro is used to access the internal stdio _filbuf function
+ * (or equivalent), if STDIO_CNT_LVALUE and STDIO_PTR_LVALUE
+ * are defined. It is typically either _filbuf or __filbuf.
+ * This macro will only be defined if both STDIO_CNT_LVALUE and
+ * STDIO_PTR_LVALUE are defined.
+ */
+#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 /**/
+#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
+#define FILE_filbuf(fp) _filbuf(fp) /**/
+#endif
#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 +754,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 +770,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 +804,24 @@
#define HAS_SYS_ERRLIST /**/
#define Strerror(e) strerror(e)
+/* HAS_STRTOD:
+ * This symbol, if defined, indicates that the strtod routine is
+ * available to translate strings to doubles.
+ */
+#define HAS_STRTOD /**/
+
+/* HAS_STRTOL:
+ * This symbol, if defined, indicates that the strtol routine is
+ * available to translate strings to integers.
+ */
+#define HAS_STRTOL /**/
+
+/* HAS_STRTOUL:
+ * This symbol, if defined, indicates that the strtoul routine is
+ * available to translate strings to integers.
+ */
+#define HAS_STRTOUL /**/
+
/* HAS_STRXFRM:
* This symbol, if defined, indicates that the strxfrm() routine is
* available to transform strings.
@@ -875,7 +899,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 +930,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
@@ -989,7 +1013,7 @@
* portably declare your directory entries.
*/
#define I_DIRENT /**/
-/*#define DIRNAMLEN /**/
+/*#define DIRNAMLEN / **/
#define Direntry_t struct dirent
/* I_DLFCN:
@@ -1033,7 +1057,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 +1069,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 +1106,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 +1135,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 +1153,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 +1161,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 +1191,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 +1213,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 +1229,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 +1245,28 @@
*/
#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 size of an int, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define INTSIZE 4 /**/
/* Off_t:
* This symbol holds the type used to declare offsets in the kernel.
@@ -1260,7 +1313,7 @@
* is often a directory that is mounted across diverse architectures.
* Programs must be prepared to deal with ~name expansion.
*/
-#define SCRIPTDIR "/usr/local/script" /**/
+#define SCRIPTDIR "/opt/perl/script" /**/
/* Select_fd_set_t:
* This symbol holds the type used for the 2nd, 3rd, and 4th
@@ -1278,16 +1331,6 @@
*/
#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".
@@ -1301,34 +1344,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 +1413,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 +1433,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 +1452,78 @@
*/
#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_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 +1540,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 +1549,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
@@ -1491,18 +1611,42 @@
#define RD_NODATA -1
#define 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 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_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,32 +1676,64 @@
* 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" /**/
+
+/* 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 */
/* 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" /**/
-/* BIN_SH:
- * This variable contains the path to the shell.
+/* 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 BIN_SH "/bin/sh" /**/
+/*#define USE_PERLIO / **/
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
diff --git a/config_h.SH b/config_h.SH
index 331a722fb4..dd73771d2c 100755
--- a/config_h.SH
+++ b/config_h.SH
@@ -1,4 +1,3 @@
-#! /bin/sh
case $CONFIG in
'')
if test -f config.sh; then TOP=.;
@@ -12,19 +11,11 @@ case $CONFIG in
. $TOP/config.sh
;;
esac
-
-case "$bin_sh" in
-'')
- bin_sh='/bin/sh'
- ;;
-esac
-
case "$0" in
*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
esac
echo "Extracting config.h (with variable substitutions)"
-rm -f config.h
-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
@@ -34,7 +25,7 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
* 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.SH,v 1.2 1996/07/05 23:49:13 gerti Exp $
+ * \$Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $
*/
/* Configuration time: $cf_time
@@ -60,6 +51,9 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
/* 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
@@ -275,6 +269,17 @@ 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
@@ -301,12 +306,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.
@@ -562,6 +561,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
@@ -600,24 +606,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.
@@ -724,18 +712,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
@@ -754,13 +730,33 @@ 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.
*/
+/* FILE_filbuf:
+ * This macro is used to access the internal stdio _filbuf function
+ * (or equivalent), if STDIO_CNT_LVALUE and STDIO_PTR_LVALUE
+ * are defined. It is typically either _filbuf or __filbuf.
+ * This macro will only be defined if both STDIO_CNT_LVALUE and
+ * STDIO_PTR_LVALUE are defined.
+ */
+#$d_stdstdio USE_STDIO_PTR /**/
#ifdef USE_STDIO_PTR
#define FILE_ptr(fp) $stdio_ptr
#$d_stdio_ptr_lval STDIO_PTR_LVALUE /**/
#define FILE_cnt(fp) $stdio_cnt
#$d_stdio_cnt_lval STDIO_CNT_LVALUE /**/
+#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
+#define FILE_filbuf(fp) $stdio_filbuf /**/
+#endif
#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
@@ -772,6 +768,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
@@ -821,6 +818,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.
@@ -1160,6 +1175,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.
@@ -1184,6 +1205,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
@@ -1232,12 +1259,29 @@ 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 size of an int, so that the C preprocessor
+ * can make decisions based on it.
+ */
+#define INTSIZE $intsize /**/
+
/* 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
@@ -1301,16 +1345,6 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#define Size_t $sizetype /* 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 $ssizetype /* 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".
@@ -1324,44 +1358,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 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 0x$byteorder /* large digits for MSB */
-#else /* NeXT */
-
-#ifdef __BIG_ENDIAN__
-#define BYTEORDER 0x4321
-#else /* __LITTLE_ENDIAN__ */
+#else /* NeXT */
+#ifdef __LITTLE_ENDIAN__
#define BYTEORDER 0x1234
+#else /* __BIG_ENDIAN__ */
+#define BYTEORDER 0x4321
#endif /* ENDIAN CHECK */
-
-#endif /* !NeXT */
+#endif /* NeXT */
/* CSH:
* This symbol, if defined, indicates that the C-shell exists.
@@ -1375,7 +1427,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
@@ -1414,26 +1466,78 @@ 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_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:
@@ -1459,28 +1563,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>.
- */
-#$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.
+ * 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 INTSIZE $intsize /**/
+#$i_values I_VALUES /**/
/* Free_t:
* This variable contains the return type of free(). It is usually
@@ -1524,19 +1625,43 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
#define RD_NODATA $rd_nodata
#$d_eofnblk 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
* 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
@@ -1568,18 +1693,48 @@ 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" /**/
+/* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+#define SSize_t $ssizetype /* signed count of bytes */
+
/* 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
@@ -1587,10 +1742,12 @@ sed <<!GROK!THIS! >config.h -e 's!^#undef!/\*#define!' -e 's!^#un-def!#undef!'
*/
#define STARTPERL "$startperl" /**/
-/* BIN_SH:
- * This variable contains the path to the shell.
+/* 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 BIN_SH "$bin_sh" /**/
+#$useperlio USE_PERLIO /**/
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
diff --git a/configpm b/configpm
index 37fe925252..eab7f5bea4 100755
--- a/configpm
+++ b/configpm
@@ -196,7 +196,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
diff --git a/configure b/configure
index 29e7d351b4..868e454111 100644..100755
--- a/configure
+++ b/configure
@@ -21,6 +21,18 @@
#
(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 explicitely extract Configure and run that."
+ exit 1
+ fi
+ ;;
+esac
+
opts=''
verbose=''
create='-e'
diff --git a/cop.h b/cop.h
index bea47c4c6a..299873bf13 100644
--- a/cop.h
+++ b/cop.h
@@ -93,6 +93,7 @@ struct block_loop {
OP * last_op;
SV ** itervar;
SV * itersave;
+ SV * iterlval;
AV * iterary;
I32 iterix;
};
@@ -103,12 +104,14 @@ 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.iterlval = Nullsv; \
cx->blk_loop.itervar = ivar; \
if (ivar) \
cx->blk_loop.itersave = *cx->blk_loop.itervar;
#define POPLOOP(cx) \
- newsp = stack_base + cx->blk_loop.resetsp;
+ newsp = stack_base + cx->blk_loop.resetsp; \
+ SvREFCNT_dec(cx->blk_loop.iterlval)
/* context common to subroutines, evals and loops */
struct block {
@@ -147,7 +150,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). */
@@ -159,7 +162,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). */
diff --git a/deb.c b/deb.c
index 381fc52840..fea6ffa2e7 100644
--- a/deb.c
+++ b/deb.c
@@ -30,12 +30,12 @@ deb(pat,a1,a2,a3,a4,a5,a6,a7,a8)
register I32 i;
GV* gv = curcop->cop_filegv;
- fprintf(Perl_debug_log,"(%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(Perl_debug_log,"%c%c ",debname[i],debdelim[i]);
- fprintf(Perl_debug_log,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) */
@@ -55,18 +55,18 @@ deb(pat, va_alist)
register I32 i;
GV* gv = curcop->cop_filegv;
- fprintf(Perl_debug_log,"(%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(Perl_debug_log,"%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(Perl_debug_log,pat,args);
+ (void) PerlIO_vprintf(Perl_debug_log,pat,args);
va_end( args );
}
#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
@@ -82,11 +82,11 @@ deb_growlevel()
I32
debstackptrs()
{
- fprintf(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
+ 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(Perl_debug_log, "%8lx %8lx %8ld %8ld %8ld\n",
+ 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(Perl_debug_log, i ? " => ... " : " => ");
+ PerlIO_printf(Perl_debug_log, i ? " => ... " : " => ");
if (stack_base[0] != &sv_undef || stack_sp < stack_base)
- fprintf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
+ PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
do {
++i;
if (markscan <= markstack_ptr && *markscan < i) {
do {
++markscan;
- putc('*', Perl_debug_log);
+ PerlIO_putc(Perl_debug_log, '*');
}
while (markscan <= markstack_ptr && *markscan < i);
- fprintf(Perl_debug_log, " ");
+ PerlIO_printf(Perl_debug_log, " ");
}
if (i > top)
break;
- fprintf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
+ PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
}
while (1);
- fprintf(Perl_debug_log, "\n");
+ PerlIO_printf(Perl_debug_log, "\n");
return 0;
}
#else
diff --git a/doio.c b/doio.c
index 575427a7ad..175b6b065a 100644
--- a/doio.c
+++ b/doio.c
@@ -43,6 +43,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>
@@ -60,21 +69,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 +96,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,7 +118,7 @@ FILE *supplied_fp;
if (fd == -1)
fp = NULL;
else {
- fp = fdopen(fd, ((result == 0) ? "r"
+ fp = PerlIO_fdopen(fd, ((result == 0) ? "r"
: (result == 1) ? "w"
: "r+"));
if (!fp)
@@ -183,7 +192,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,7 +201,7 @@ FILE *supplied_fp;
}
if (dodup)
fd = dup(fd);
- if (!(fp = fdopen(fd,mode))) {
+ if (!(fp = PerlIO_fdopen(fd,mode))) {
if (dodup)
close(fd);
}
@@ -202,11 +211,11 @@ FILE *supplied_fp;
/*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);
}
}
}
@@ -217,11 +226,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';
@@ -240,11 +249,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) {
@@ -254,8 +263,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))
@@ -269,7 +278,7 @@ FILE *supplied_fp;
#endif
) {
int buflen = sizeof tokenbuf;
- if (getsockname(fileno(fp), (struct sockaddr *)tokenbuf, &buflen) >= 0
+ 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 */
@@ -277,43 +286,43 @@ FILE *supplied_fp;
#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;
}
@@ -330,7 +339,7 @@ say_false:
return FALSE;
}
-FILE *
+PerlIO *
nextargv(gv)
register GV *gv;
{
@@ -345,7 +354,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
@@ -409,7 +418,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) {
@@ -422,13 +431,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
@@ -444,7 +455,7 @@ 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);
@@ -464,7 +475,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);
@@ -499,15 +510,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;
}
@@ -573,11 +584,11 @@ IO* 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;
}
@@ -599,20 +610,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;
@@ -637,11 +648,11 @@ GV *gv;
goto phooey;
#ifdef ULTRIX_STDIO_BOTCH
- if (feof(IoIFP(io)))
- (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */
+ if (PerlIO_eof(IoIFP(io)))
+ (void)PerlIO_seek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */
#endif
- return ftell(IoIFP(io));
+ return PerlIO_tell(IoIFP(io));
phooey:
if (dowarn)
@@ -666,11 +677,11 @@ int whence;
goto nuts;
#ifdef ULTRIX_STDIO_BOTCH
- if (feof(IoIFP(io)))
- (void)fseek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */
+ if (PerlIO_eof(IoIFP(io)))
+ (void)PerlIO_seek (IoIFP(io), 0L, 2); /* ultrix 1.2 workaround */
#endif
- return fseek(IoIFP(io), pos, whence) >= 0;
+ return PerlIO_seek(IoIFP(io), pos, whence) >= 0;
nuts:
if (dowarn)
@@ -731,60 +742,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;
@@ -796,13 +757,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)) {
@@ -814,17 +775,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
@@ -844,7 +805,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)
@@ -955,6 +916,8 @@ do_execfree()
}
}
+#ifndef OS2
+
bool
do_exec(cmd)
char *cmd;
@@ -1014,7 +977,7 @@ char *cmd;
break;
}
doshell:
- execl(SH_PATH, "sh", "-c", cmd, (char*)0);
+ execl(sh_path, "sh", "-c", cmd, (char*)0);
return FALSE;
}
}
@@ -1044,6 +1007,8 @@ char *cmd;
return FALSE;
}
+#endif /* OS2 */
+
I32
apply(type,mark,sp)
I32 type;
@@ -1058,9 +1023,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;
}
@@ -1093,6 +1059,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)) {
@@ -1243,7 +1211,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))
@@ -1264,7 +1232,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 */
diff --git a/doop.c b/doop.c
index 85146bf6f6..836027ef4d 100644
--- a/doop.c
+++ b/doop.c
@@ -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;
@@ -273,6 +265,15 @@ register SV **sarg;
*t = '\0';
(void)sprintf(xs,f,SvNV(arg));
xlen = strlen(xs);
+#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 (op->op_type == OP_SPRINTF)
+ SvTAINTED_on(sv);
+#endif /* LC_NUMERIC */
break;
case 's':
ch = *(++t);
@@ -320,7 +321,7 @@ register SV **sarg;
/* end of switch, copy results */
*t = ch;
if (xs == buf && xlen >= sizeof(buf)) { /* Ooops! */
- fputs("panic: sprintf overflow - memory corrupted!\n",stderr);
+ PerlIO_puts(PerlIO_stderr(),"panic: sprintf overflow - memory corrupted!\n");
my_exit(1);
}
SvGROW(sv, SvCUR(sv) + (f - s) + xlen + 1 + pre + post);
@@ -498,7 +499,7 @@ register SV *sv;
goto nope;
len -= rslen - 1;
s -= rslen - 1;
- if (bcmp(s, rsptr, rslen))
+ if (memNE(s, rsptr, rslen))
goto nope;
count += rslen;
}
@@ -531,13 +532,24 @@ SV *right;
register char *rc = SvPV(right, rightlen);
register I32 len;
I32 lensave;
+ char *lsave = lc;
+ char *rsave = rc;
- dc = SvPV_force(sv,na);
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)) {
+ 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 +600,6 @@ SV *right;
}
#endif
{
- char *lsave = lc;
- char *rsave = rc;
-
switch (optype) {
case OP_BIT_AND:
while (len--)
@@ -630,8 +639,15 @@ dARGS
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 */
@@ -639,6 +655,17 @@ dARGS
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 {
diff --git a/dosish.h b/dosish.h
index 7a8b4313f3..ff7e245834 100644
--- a/dosish.h
+++ b/dosish.h
@@ -1,11 +1,39 @@
#define ABORT() abort();
-#define BIT_BUCKET "\dev\nul"
+#define SH_PATH "/bin/sh"
+
+#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
#define PERL_SYS_INIT(c,v)
+#define BIT_BUCKET "\dev\nul"
+#endif
+
#define PERL_SYS_TERM()
#define dXSUB_SYS int dummy
#define TMPPATH "plXXXXXX"
+/*
+ * 5.003_07 and earlier keyed on #ifdef MSDOS for determining if we were
+ * running on DOS, *and* if we had to cope with 16 bit memory addressing
+ * constraints, *and* we need to have memory allocated as unsigned long.
+ *
+ * with the advent of *real* compilers for DOS, they are not locked together.
+ * MSDOS means "I am running on MSDOS". HAS_64K_LIMIT means "I have
+ * 16 bit memory addressing constraints".
+ *
+ * if you need the last, try #DEFINE MEM_SIZE unsigned long.
+ */
+#ifdef MSDOS
+ #ifndef DJGPP
+ #define HAS_64K_LIMIT
+ #endif
+#endif
+
/* USEMYBINMODE
* This symbol, if defined, indicates that the program should
* use the routine my_binmode(FILE *fp, char iotype) to insure
diff --git a/dump.c b/dump.c
index e461d69750..c0749b855f 100644
--- a/dump.c
+++ b/dump.c
@@ -25,25 +25,13 @@ dump_all()
#ifdef I_STDARG
static void dump(char *pat, ...);
#else
-# if defined(I_VARARGS)
-/*VARARGS0*/
-static void
-dump(pat, va_alist)
- char *pat;
- va_dcl
-# else
static void dump();
-# endif
#endif
void
dump_all()
{
-#ifdef HAS_SETLINEBUF
- setlinebuf(Perl_debug_log);
-#else
- setvbuf(Perl_debug_log, Nullch, _IOLBF, 0);
-#endif
+ PerlIO_setlinebuf(Perl_debug_log);
if (main_root)
dump_op(main_root);
dump_packsubs(defstash);
@@ -79,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",
@@ -97,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)));
@@ -119,18 +107,18 @@ register OP *op;
dump("{\n");
if (op->op_seq)
- fprintf(Perl_debug_log, "%-4d", op->op_seq);
+ PerlIO_printf(Perl_debug_log, "%-4d", op->op_seq);
else
- fprintf(Perl_debug_log, " ");
+ PerlIO_printf(Perl_debug_log, " ");
dump("TYPE = %s ===> ", op_name[op->op_type]);
if (op->op_next) {
if (op->op_seq)
- fprintf(Perl_debug_log, "%d\n", op->op_next->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", op->op_next->op_seq);
else
- fprintf(Perl_debug_log, "(%d)\n", op->op_next->op_seq);
+ PerlIO_printf(Perl_debug_log, "(%d)\n", op->op_next->op_seq);
}
else
- fprintf(Perl_debug_log, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
dumplvl++;
if (op->op_targ) {
if (op->op_type == OP_NULL)
@@ -201,10 +189,17 @@ register OP *op;
(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,");
+ switch (op->op_private & OPpDEREF) {
+ case OPpDEREF_SV:
+ (void)strcat(buf, "SV,");
+ break;
+ case OPpDEREF_AV:
+ (void)strcat(buf, "AV,");
+ break;
+ case OPpDEREF_HV:
+ (void)strcat(buf, "HV,");
+ break;
+ }
if (op->op_private & HINT_STRICT_REFS)
(void)strcat(buf,"STRICT_REFS,");
}
@@ -235,7 +230,7 @@ register OP *op;
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;
}
@@ -255,31 +250,31 @@ register OP *op;
case OP_ENTERLOOP:
dump("REDO ===> ");
if (cLOOP->op_redoop)
- fprintf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq);
else
- fprintf(Perl_debug_log, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
dump("NEXT ===> ");
if (cLOOP->op_nextop)
- fprintf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq);
else
- fprintf(Perl_debug_log, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
dump("LAST ===> ");
if (cLOOP->op_lastop)
- fprintf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq);
else
- fprintf(Perl_debug_log, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
break;
case OP_COND_EXPR:
dump("TRUE ===> ");
if (cCONDOP->op_true)
- fprintf(Perl_debug_log, "%d\n", cCONDOP->op_true->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_true->op_seq);
else
- fprintf(Perl_debug_log, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
dump("FALSE ===> ");
if (cCONDOP->op_false)
- fprintf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq);
else
- fprintf(Perl_debug_log, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
break;
case OP_MAPWHILE:
case OP_GREPWHILE:
@@ -287,9 +282,9 @@ register OP *op;
case OP_AND:
dump("OTHER ===> ");
if (cLOGOP->op_other)
- fprintf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq);
+ PerlIO_printf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq);
else
- fprintf(Perl_debug_log, "DONE\n");
+ PerlIO_printf(Perl_debug_log, "DONE\n");
break;
case OP_PUSHRE:
case OP_MATCH:
@@ -315,16 +310,16 @@ register GV *gv;
SV *sv;
if (!gv) {
- fprintf(Perl_debug_log,"{}\n");
+ PerlIO_printf(Perl_debug_log, "{}\n");
return;
}
sv = sv_newmortal();
dumplvl++;
- fprintf(Perl_debug_log,"{\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");
@@ -369,8 +364,6 @@ register PMOP *pm;
(void)strcat(buf,"ALL,");
if (pm->op_pmflags & PMf_SKIPWHITE)
(void)strcat(buf,"SKIPWHITE,");
- if (pm->op_pmflags & PMf_FOLD)
- (void)strcat(buf,"FOLD,");
if (pm->op_pmflags & PMf_CONST)
(void)strcat(buf,"CONST,");
if (pm->op_pmflags & PMf_KEEP)
@@ -400,8 +393,8 @@ long arg2, arg3, arg4, arg5;
I32 i;
for (i = dumplvl*4; i; i--)
- (void)putc(' ',Perl_debug_log);
- fprintf(Perl_debug_log,arg1, arg2, arg3, arg4, arg5);
+ (void)PerlIO_putc(Perl_debug_log,' ');
+ PerlIO_printf(Perl_debug_log, arg1, arg2, arg3, arg4, arg5);
}
#else
@@ -419,9 +412,6 @@ dump(pat,va_alist)
{
I32 i;
va_list args;
-#ifndef HAS_VPRINTF
- int vfprintf();
-#endif
#ifdef I_STDARG
va_start(args, pat);
@@ -429,8 +419,8 @@ dump(pat,va_alist)
va_start(args);
#endif
for (i = dumplvl*4; i; i--)
- (void)putc(' ',stderr);
- vfprintf(Perl_debug_log,pat,args);
+ (void)PerlIO_putc(Perl_debug_log,' ');
+ PerlIO_vprintf(Perl_debug_log,pat,args);
va_end(args);
}
#endif
diff --git a/eg/README b/eg/README
index 87cfc334f1..15eb6551a3 100644
--- a/eg/README
+++ b/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/eg/nih b/eg/nih
index 2066f4bd06..4475c499da 100644
--- a/eg/nih
+++ b/eg/nih
@@ -1,4 +1,4 @@
-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: 4.1 $$Date: 92/08/07 17:20:27 $
@@ -6,5 +6,6 @@ eval "exec /usr/bin/perl -Spi.bak $0 $*"
# 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/eg/sysvipc/ipcmsg b/eg/sysvipc/ipcmsg
index 317e027ea7..646d8b6aed 100644
--- a/eg/sysvipc/ipcmsg
+++ b/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/eg/sysvipc/ipcsem b/eg/sysvipc/ipcsem
index d72a2dd77c..4d871b901a 100644
--- a/eg/sysvipc/ipcsem
+++ b/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';
diff --git a/eg/sysvipc/ipcshm b/eg/sysvipc/ipcshm
index d40e46b945..ecc1ba4366 100644
--- a/eg/sysvipc/ipcshm
+++ b/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/emacs/cperl-mode.el b/emacs/cperl-mode.el
index 059b991f58..6fa07ad29a 100644
--- a/emacs/cperl-mode.el
+++ b/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.24 1996/07/04 02:14:27 ilya Exp ilya $
+;; $Id: cperl-mode.el,v 1.31+ 1996/12/09 08:03:14 ilya Exp ilya $
;;; To use this mode put the following into your .emacs file:
@@ -41,6 +46,10 @@
;;; 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'. <<<<<<
+
;;; Additional useful commands to put into your .emacs file:
;; (setq auto-mode-alist
@@ -50,7 +59,7 @@
;;; The mode information (on C-h m) provides 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
@@ -281,6 +290,70 @@
;;; 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'.
+;;; 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!
+
(defvar cperl-extra-newline-before-brace nil
"*Non-nil means that if, elsif, while, until, else, for, foreach
and do constructs look like:
@@ -341,7 +414,7 @@ Can be overwritten by `cperl-hairy' if nil.")
"*Non-nil (and non-null) means { after $ in CPerl buffers should be preceeded by ` '.
Can be overwritten by `cperl-hairy' if nil.")
-(defvar cperl-electric-parens-string "({[<"
+(defvar cperl-electric-parens-string "({[]})<"
"*String of parentheses that should be electric in CPerl.")
(defvar cperl-electric-parens nil
@@ -384,6 +457,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.")
@@ -405,6 +481,16 @@ You can always make lookup from menu or using \\[cperl-find-pods-heres].")
"*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'.")
+
;;; Short extra-docs.
@@ -425,18 +511,23 @@ 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 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 is very
-rudimental, the first one requires generation of TAGS from
+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.")
@@ -447,26 +538,26 @@ 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.
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.
@@ -489,6 +580,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:
@@ -498,7 +593,7 @@ 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.
@@ -514,8 +609,13 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove
;;; Portability stuff:
-(defsubst cperl-xemacs-p ()
- (string-match "XEmacs\\|Lucid" emacs-version))
+(defconst 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)))
@@ -524,7 +624,7 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove
(and (vectorp del-back-ch) (= (length del-back-ch) 1)
(setq del-back-ch (aref del-back-ch 0)))
-(if (cperl-xemacs-p)
+(if cperl-xemacs-p
(progn
;; "Active regions" are on: use region only if active
;; "Active regions" are off: use region unconditionally
@@ -536,10 +636,10 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove
(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
@@ -596,39 +696,37 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove
(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 "\C-c\C-a" 'cperl-toggle-auto-newline)
- (define-key cperl-mode-map "\C-c\C-k" 'cperl-toggle-abbrev)
- (define-key cperl-mode-map "\C-c\C-e" 'cperl-toggle-electric)
- (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" 'cperl-electric-backspace)
- (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 "\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-hf" 'cperl-info-on-command [(control h) f])
+ (cperl-define-key "\C-c\C-hf" 'cperl-info-on-current-command
+ [(control c) (control h) f])
+ (cperl-define-key "\C-hv" '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)
@@ -655,8 +753,8 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove
["Line up a construction" cperl-lineup (cperl-use-region-p)]
"----"
["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)
@@ -664,10 +762,11 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove
["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)]
@@ -695,7 +794,11 @@ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove
["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]
@@ -740,6 +843,7 @@ 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 ?_ "w" cperl-mode-syntax-table)
+ (modify-syntax-entry ?: "_" cperl-mode-syntax-table)
(modify-syntax-entry ?| "." cperl-mode-syntax-table))
@@ -796,13 +900,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'.
@@ -828,6 +932,15 @@ 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'.
+
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
@@ -892,15 +1005,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)
@@ -938,7 +1046,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)
@@ -975,10 +1083,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 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))))
+
;; Fix for msb.el
(defvar cperl-msb-fixed nil)
@@ -1040,7 +1165,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)
@@ -1048,6 +1173,22 @@ 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
@@ -1055,55 +1196,74 @@ 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)))
- (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)))
+ (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-brace-recursing t)
(cperl-auto-newline cperl-auto-newline)
- (other-end (if (and cperl-electric-parens-mark
- (cperl-mark-active)
- (> (mark) (point)))
- (save-excursion
- (goto-char (mark))
- (point-marker))
- nil)))
+ (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
@@ -1152,10 +1312,42 @@ char is \"{\", insert extra newline before only if
(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)))
- (dollar (eq (preceding-char) ?$)))
+ (dollar (eq last-command-char ?$)))
(and (save-excursion
(backward-sexp 1)
(cperl-after-expr-p nil "{};:"))
@@ -1228,21 +1420,24 @@ char is \"{\", insert extra newline before only if
(if (and ; Check if we need to split:
; i.e., on a boundary and inside "{...}"
(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)
+ (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)))))
+ (<= start pos))))) ; Redundant? Are after the
+ ; start of parens group.
(progn
(skip-chars-backward " \t")
(or (memq (preceding-char) (append ";{" nil))
@@ -1275,10 +1470,19 @@ char is \"{\", insert extra newline before only if
(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."
@@ -1294,7 +1498,8 @@ char is \"{\", insert extra newline before only if
(auto (and cperl-auto-newline
(or (not (eq last-command-char ?:))
cperl-auto-newline-after-colon))))
- (if (and (not arg) (eolp)
+ (if (and ;;(not arg)
+ (eolp)
(not (save-excursion
(beginning-of-line)
(skip-chars-forward " \t")
@@ -1317,9 +1522,9 @@ char is \"{\", insert extra newline before only if
(or (nth 3 pps) (nth 4 pps) (nth 5 pps))))))))
(progn
(insert last-command-char)
- (forward-char -1)
+ ;;(forward-char -1)
(if auto (setq insertpos (point-marker)))
- (forward-char 1)
+ ;;(forward-char 1)
(cperl-indent-line)
(if auto
(progn
@@ -1332,7 +1537,7 @@ char is \"{\", insert extra newline before only if
;; (setq insertpos (1- (point)))))
;; (delete-char -1))))
(save-excursion
- (if insertpos (goto-char (marker-position insertpos))
+ (if insertpos (goto-char (1- (marker-position insertpos)))
(forward-char -1))
(delete-char 1))))
(if insertpos
@@ -1450,7 +1655,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
@@ -1488,19 +1693,19 @@ 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)
;; Need take into account `bless', `return', `tr',...
- (or (and (looking-at "\\sw+[ \t\n\f]*[{#]") ; Method call syntax
+ (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]*[#{]")))))))))
(defun cperl-calculate-indent (&optional parse-start symbol)
"Return appropriate indentation for current line as Perl code.
@@ -1583,7 +1788,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) ?{)
@@ -1645,7 +1855,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)
@@ -1668,7 +1878,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,
@@ -1818,7 +2028,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)
@@ -1844,7 +2054,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
@@ -1956,94 +2166,274 @@ the sections using `cperl-pod-head-face', `cperl-pod-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 err b1 e1 argument
(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))
- (after-change-functions nil))
+ (after-change-functions nil)
+ (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]*$")))
(unwind-protect
(progn
(save-excursion
- (message "Scanning for pods and here-docs...")
+ (message "Scanning for pods, formats and here-docs...")
(if cperl-pod-here-fontify
- (setq face (eval cperl-pod-face)
- head-face (eval cperl-pod-head-face)
- here-face (eval cperl-here-face)))
+ ;; 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))
;; 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 3)
- (setq e (point))
- (put-text-property b e 'in-pod t)
- (goto-char b)
- (while (re-search-forward "\n\n[ \t]" e t)
+ (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 preceeded by a pod section")
+ (setq err (point)))
(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]" 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]\\)+\\)$")
+
+ (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))
- (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)
- (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)))))
+ 'face head-face))))
+ (goto-char e)))
+ ;; Here document
+ ;; 1 () ahead
+ ;; "<<\\(\\([\"'`]\\)\\([^\"'`\n]*\\)\\3\\|\\(\\([a-zA-Z_][a-zA-Z_0-9]*\\)?\\)\\)"
+ ((match-beginning 2) ; 1 + 1
+ ;; Abort in comment (_extremely_ simplified):
+ (setq b (point))
+ (if (save-excursion
+ (beginning-of-line)
+ (search-forward "#" b t))
+ nil
+ (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)))
+ (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)))))
+ ;; format
+ (t
+ ;; 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
+ (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-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-put-do-not-fontify (point) (+ (point) 2)))
+ (message "End of format `%s' not found." name))
+ (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)))
+ )))
+;;; (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 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 err (goto-char err)
- (message "Scan for pods and here-docs completed.")))
+ (message "Scan for pods, formats and here-docs completed.")))
(and (buffer-modified-p)
(not modified)
(set-buffer-modified-p nil)))))
@@ -2342,6 +2732,9 @@ indentation and initial hashes. Behaves usually outside of comment."
end-range (or (car ends-ranges) 0))
(if (eq fchar ?p)
(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
@@ -2355,6 +2748,7 @@ indentation and initial hashes. Behaves usually outside of comment."
(setq index (imenu-example--name-and-position))
(if (eq fchar ?p) nil
(setq name (buffer-substring (match-beginning 3) (match-end 3)))
+ (set-text-properties 0 (length name) nil name)
(cond ((string-match "[:']" name)
(setq meth t))
((> p end-range) nil)
@@ -2370,6 +2764,7 @@ indentation and initial hashes. Behaves usually outside of comment."
;; (beginning-of-line)
(setq index (imenu-example--name-and-position)
name (buffer-substring (match-beginning 5) (match-end 5)))
+ (set-text-properties 0 (length name) nil name)
(if (eq (char-after (match-beginning 4)) ?2)
(setq name (concat " " name)))
(setcar index name)
@@ -2395,26 +2790,28 @@ indentation and initial hashes. Behaves usually outside of comment."
(setq lst index-meth-alist)
(while lst
(setq elt (car lst) lst (cdr lst))
- (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))))
+ (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)))
@@ -2490,36 +2887,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\\|"
@@ -2553,18 +2957,20 @@ indentation and initial hashes. Behaves usually outside of comment."
"x\\(\\|or\\)\\|__\\(FILE__\\|LINE__\\)"
"\\)\\>") 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\\|"
@@ -2581,11 +2987,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]"
+ font-lock-function-name-face keep) ; Not very good, triggers at "[a-z]"
'("\\<sub[ \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)
@@ -2625,8 +3033,14 @@ indentation and initial hashes. Behaves usually outside of comment."
(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)) ?{)
@@ -2634,11 +3048,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_]\\)\\|\\(/\\)\\)"
@@ -2750,7 +3159,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
@@ -2936,34 +3345,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
@@ -2975,21 +3402,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."
@@ -3014,7 +3492,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
@@ -3037,7 +3515,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.
@@ -3057,8 +3535,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
@@ -3078,7 +3556,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)))))
@@ -3160,6 +3638,7 @@ in subdirectories too."
(defun cperl-xsub-scan ()
(require 'cl)
+ (require 'imenu)
(let ((index-alist '())
(prev-pos 0) index index1 name package prefix)
(goto-char (point-min))
@@ -3186,7 +3665,6 @@ in subdirectories too."
(setq name (buffer-substring (match-beginning 3) (match-end 3)))
(if (and prefix (string-match (concat "^" prefix) name))
(setq name (substring name (length prefix))))
- (setq meth nil)
(cond ((string-match "::" name) nil)
(t
(setq index1 (cons (concat package "::" name) (cdr index)))
@@ -3269,6 +3747,7 @@ in subdirectories too."
(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!")))
@@ -3300,7 +3779,7 @@ in subdirectories too."
)
(t
(setq xs (string-match "\\.xs$" file))
- (cond ((eq erase 'ignore) nil)
+ (cond ((eq erase 'ignore) (goto-char (point-max)))
(erase (erase-buffer))
(t
(goto-char 1)
@@ -3311,12 +3790,13 @@ in subdirectories too."
(progn
(forward-char 1)
(search-forward "\f\n" nil 'toend)
- (point)))
- (goto-char 1)))))
+ (point))))
+ (goto-char (point-max)))))
(insert (cperl-find-tags file xs))))
(if inbuffer nil ; Delegate to the caller
(save-buffer 0) ; No backup
- (initialize-new-tags-table)))))
+ (if (fboundp 'initialize-new-tags-table) ; Do we need something special in XEmacs?
+ (initialize-new-tags-table))))))
(defvar cperl-tags-hier-regexp-list
"^\\(\\(package\\)\\>\\|sub\\>[^\n]+::\\|[a-zA-Z_][a-zA-Z_0-9:]*(\C-?[^\n]+::\\|[ \t]*BOOT:\C-?[^\n]+::\\)")
@@ -3349,7 +3829,7 @@ in subdirectories too."
;; Name known
(setcdr cons1 (cons (cons fileind (vector file info))
(cdr cons1)))
- ;; First occurence of the name, start alist
+ ;; First occurrence of the name, start alist
(setq cons1 (cons name (list (cons fileind (vector file info)))))
(if pack
(setcar (cdr cperl-hierarchy)
@@ -3512,3 +3992,705 @@ One may build such TAGS files from CPerl mode menu."
(t
(list (cdr elt) (car elt))))))
(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-Z0-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-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) (+ 5 (point)))))))))
+
+;;; 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 a reference to whatever follows, like \$var.
+\\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).
+\\r Return character (octal 015).
+\\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.
+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]))
+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)
+pack(TEMPLATE,LIST)
+package NAME Introduces package context.
+pipe(READHANDLE,WRITEHANDLE)
+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
+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 Docs missing
+chr Docs missing
+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 Docs missing
+formline Docs missing
+glob EXPR Synonym of <EXPR>.
+lc [ EXPR ] Returns lowercased EXPR.
+lcfirst [ EXPR ] Returns EXPR with lower-cased first letter.
+map Docs missing
+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 metacharacters.
+qw Docs missing
+readline FH Synonym of <FH>.
+readpipe CMD Synonym of `CMD`.
+ref [ EXPR ] Type of EXPR when dereferenced.
+sysopen Docs missing
+tie Docs missing
+tied Docs missing
+uc [ EXPR ] Returns upcased EXPR.
+ucfirst [ EXPR ] Returns EXPR with upcased first letter.
+untie Docs missing
+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)))))
+
+(if (fboundp 'run-with-idle-timer)
+ (progn
+ (defvar cperl-help-shown nil
+ "Non-nil means that the help was already shown now.")
+
+ (defvar cperl-help-timer nil
+ "Non-nil means that the help was already shown now.")
+
+ (defun cperl-lazy-install ()
+ (interactive)
+ (make-variable-buffer-local 'cperl-help-shown)
+ (if (cperl-val cperl-lazy-help-time)
+ (progn
+ (add-hook 'post-command-hook 'cperl-lazy-hook)
+ (setq cperl-help-timer
+ (run-with-idle-timer
+ (cperl-val cperl-lazy-help-time 1000000 5)
+ t
+ 'cperl-get-help-defer)))))
+
+ (defun cperl-lazy-unstall ()
+ (interactive)
+ (remove-hook 'post-command-hook 'cperl-lazy-hook)
+ (cancel-timer cperl-help-timer))
+
+ (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)))
diff --git a/embed.h b/embed.h
index 9d474835b3..82cb97f6bd 100644
--- a/embed.h
+++ b/embed.h
@@ -1,6 +1,6 @@
/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- This file is derived from global.sym and interp.sym
- Any changes made here will be lost
+ 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.) */
@@ -15,1401 +15,1616 @@
# 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_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_start Perl_block_start
+#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 calllist Perl_calllist
+#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_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_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 comppad_name_floor Perl_comppad_name_floor
-#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 curcopdb Perl_curcopdb
-#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 psig_ptr Perl_psig_ptr
-#define psig_name Perl_psig_name
-#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_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 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 cpytill Perl_cpytill
+#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_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 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_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 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_stashpvn Perl_gv_stashpvn
-#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_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_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_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 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_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_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_delayfree Perl_he_delayfree
+#define he_free Perl_he_free
+#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_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_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 magic_clearsig Perl_magic_clearsig
+#define lshift_amg Perl_lshift_amg
+#define lshift_ass_amg Perl_lshift_ass_amg
+#define lt_amg Perl_lt_amg
+#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_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_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 magic_freevivary Perl_magic_freevivary
+#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_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_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_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_setvivary Perl_magic_setvivary
+#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_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 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 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 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 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_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 provide_ref Perl_provide_ref
+#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 qrt_amg Perl_qrt_amg
+#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 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 sharepvn Perl_sharepvn
-#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 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_generation Perl_sub_generation
+#define sublex_done Perl_sublex_done
+#define sublex_start Perl_sublex_start
+#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_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_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_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 unsharepvn Perl_unsharepvn
-#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 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_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
-#endif /* EMBED */
+/* Hide global symbols that 5.003 revealed? */
-/* Put interpreter specific symbols into a struct? */
+#ifndef BINCOMPAT3
-#ifdef MULTIPLICITY
+#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
-/* Undefine symbols that were defined by EMBED. Somewhat ugly */
+#endif /* !BINCOMPAT3 */
-#undef curcop
-#undef envgv
-#undef siggv
-#undef stack
-#undef tainting
+#endif /* EMBED */
+
+/* Put interpreter-specific symbols into a struct? */
-#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 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 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 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 perldb (curinterp->Iperldb)
+#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 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 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 statcache (curinterp->Istatcache)
-#define statgv (curinterp->Istatgv)
-#define statname (curinterp->Istatname)
-#define statusvalue (curinterp->Istatusvalue)
-#define stdingv (curinterp->Istdingv)
-#define strchop (curinterp->Istrchop)
-#define strtab (curinterp->Istrtab)
-#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 pidstatus (curinterp->Ipidstatus)
+#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 statcache (curinterp->Istatcache)
+#define statgv (curinterp->Istatgv)
+#define statname (curinterp->Istatname)
+#define statusvalue (curinterp->Istatusvalue)
+#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 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 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 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 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 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 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 Istatcache statcache
-#define Istatgv statgv
-#define Istatname statname
-#define Istatusvalue statusvalue
-#define Istdingv stdingv
-#define Istrchop strchop
-#define Istrtab strtab
-#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 Ipidstatus pidstatus
+#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 Istatcache statcache
+#define Istatgv statgv
+#define Istatname statname
+#define Istatusvalue statusvalue
+#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 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 pidstatus Perl_pidstatus
+#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 statcache Perl_statcache
+#define statgv Perl_statgv
+#define statname Perl_statname
+#define statusvalue Perl_statusvalue
+#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/embed.pl b/embed.pl
index e4469c92e1..266a33e7e0 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1,11 +1,52 @@
-#!/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';
/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
- This file is derived from global.sym and interp.sym
- Any changes made here will be lost
+ 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.) */
@@ -20,69 +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
-/* Undefine symbols that were defined by EMBED. Somewhat ugly */
+END
+
+for $sym (sort keys %interp) {
+ print EM multon($sym);
+}
+
+print EM <<'END';
-#undef curcop
-#undef envgv
-#undef siggv
-#undef stack
-#undef tainting
+#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 $1\t\t(curinterp->I$1)/;
- s/(................\t)\t/$1/;
- print EM $_;
+for $sym (sort keys %interp) {
+ print EM multoff($sym);
}
-close(INT) || warn "Can't close interp.sym: $!\n";
print EM <<'END';
-#else /* not multiple, so translate interpreter symbols the other way... */
+/* Hide interpreter-specific symbols? */
+
+#ifdef EMBED
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 embed($sym) if $compat3{$sym};
+}
+
+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};
}
-close(INT) || warn "Can't close interp.sym: $!\n";
print EM <<'END';
+#endif /* !BINCOMPAT3 */
+
+#endif /* EMBED */
+
#endif /* MULTIPLICITY */
END
diff --git a/ext/DB_File/DB_File.pm b/ext/DB_File/DB_File.pm
index 0fff53845d..fe9c34dd14 100644
--- a/ext/DB_File/DB_File.pm
+++ b/ext/DB_File/DB_File.pm
@@ -1,11 +1,18 @@
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
-# last modified 28th June 1996
-# version 1.02
+# last modified 18th Dec 1996
+# version 1.09
+#
+# Copyright (c) 1995, 1996 Paul Marquess. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
package DB_File::HASHINFO ;
+require 5.003 ;
+
use strict;
use Carp;
require Tie::Hash;
@@ -19,25 +26,25 @@ sub new
bless \%x, $pkg ;
}
+
sub TIEHASH
{
my $pkg = shift ;
- bless { 'bsize' => undef,
- 'ffactor' => undef,
- 'nelem' => undef,
- 'cachesize' => undef,
- 'hash' => undef,
- 'lorder' => undef,
- }, $pkg ;
+ bless { VALID => { map {$_, 1}
+ qw( bsize ffactor nelem cachesize hash lorder)
+ },
+ GOT => {}
+ }, $pkg ;
}
+
sub FETCH
{
my $self = shift ;
my $key = shift ;
- return $self->{$key} if exists $self->{$key} ;
+ return $self->{GOT}{$key} if exists $self->{VALID}{$key} ;
my $pkg = ref $self ;
croak "${pkg}::FETCH - Unknown element '$key'" ;
@@ -50,9 +57,9 @@ sub STORE
my $key = shift ;
my $value = shift ;
- if ( exists $self->{$key} )
+ if ( exists $self->{VALID}{$key} )
{
- $self->{$key} = $value ;
+ $self->{GOT}{$key} = $value ;
return ;
}
@@ -65,9 +72,9 @@ sub DELETE
my $self = shift ;
my $key = shift ;
- if ( exists $self->{$key} )
+ if ( exists $self->{VALID}{$key} )
{
- delete $self->{$key} ;
+ delete $self->{GOT}{$key} ;
return ;
}
@@ -80,21 +87,21 @@ sub EXISTS
my $self = shift ;
my $key = shift ;
- exists $self->{$key} ;
+ exists $self->{VALID}{$key} ;
}
sub NotHere
{
- my $pkg = shift ;
+ my $self = shift ;
my $method = shift ;
- croak "${pkg} does not define the method ${method}" ;
+ croak ref($self) . " does not define the method ${method}" ;
}
sub DESTROY { undef %{$_[0]} }
-sub FIRSTKEY { my $self = shift ; $self->NotHere(ref $self, "FIRSTKEY") }
-sub NEXTKEY { my $self = shift ; $self->NotHere(ref $self, "NEXTKEY") }
-sub CLEAR { my $self = shift ; $self->NotHere(ref $self, "CLEAR") }
+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 ;
@@ -106,14 +113,11 @@ sub TIEHASH
{
my $pkg = shift ;
- bless { 'bval' => undef,
- 'cachesize' => undef,
- 'psize' => undef,
- 'flags' => undef,
- 'lorder' => undef,
- 'reclen' => undef,
- 'bfname' => "",
- }, $pkg ;
+ bless { VALID => { map {$_, 1}
+ qw( bval cachesize psize flags lorder reclen bfname )
+ },
+ GOT => {},
+ }, $pkg ;
}
package DB_File::BTREEINFO ;
@@ -126,15 +130,12 @@ sub TIEHASH
{
my $pkg = shift ;
- bless { 'flags' => undef,
- 'cachesize' => undef,
- 'maxkeypage' => undef,
- 'minkeypage' => undef,
- 'psize' => undef,
- 'compare' => undef,
- 'prefix' => undef,
- 'lorder' => undef,
- }, $pkg ;
+ bless { VALID => { map {$_, 1}
+ qw( flags cachesize maxkeypage minkeypage psize
+ compare prefix lorder )
+ },
+ GOT => {},
+ }, $pkg ;
}
@@ -145,13 +146,9 @@ use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO) ;
use Carp;
-$VERSION = "1.02" ;
+$VERSION = "1.09" ;
#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 ;
@@ -214,11 +211,35 @@ sub AUTOLOAD {
goto &$AUTOLOAD;
}
+
+# import borrowed from IO::File
+# exports Fcntl constants if available.
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+ Exporter::export $pkg, $callpkg, @_;
+ eval {
+ require Fcntl;
+ Exporter::export 'Fcntl', $callpkg, '/^O_/';
+ };
+}
+
bootstrap DB_File $VERSION;
# Preloaded methods go here. Autoload methods go after __END__, and are
# processed by the autosplit program.
+sub TIEHASH
+{
+ my (@arg) = @_ ;
+
+ $arg[4] = tied %{ $arg[4] }
+ if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ;
+
+ DoTie_(@arg) ;
+}
+
+*TIEARRAY = \&TIEHASH ;
sub get_dup
{
@@ -228,31 +249,33 @@ sub get_dup
my $db = shift ;
my $key = shift ;
my $flag = shift ;
- my $value ;
+ my $value = 0 ;
my $origkey = $key ;
my $wantarray = wantarray ;
+ my %values = () ;
my @values = () ;
my $counter = 0 ;
+ my $status = 0 ;
- # get the first value associated with the key, $key
- $db->seq($key, $value, R_CURSOR()) ;
+ # 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()) ) {
- if ( $key eq $origkey) {
-
- while (1) {
- # save the value or count matches
- if ($wantarray)
- { push (@values, $value) ; push(@values, 1) if $flag }
- else
- { ++ $counter }
+ # save the value or count number of matches
+ if ($wantarray) {
+ if ($flag)
+ { ++ $values{$value} }
+ else
+ { push (@values, $value) }
+ }
+ else
+ { ++ $counter }
- # iterate through the database until either EOF
- # or a different key is encountered.
- last if $db->seq($key, $value, R_NEXT()) != 0 or $key ne $origkey ;
- }
}
- $wantarray ? @values : $counter ;
+ return ($wantarray ? ($flag ? %values : @values) : $counter) ;
}
@@ -268,27 +291,30 @@ DB_File - Perl5 access to Berkeley DB
=head1 SYNOPSIS
use DB_File ;
- use Fcntl ;
[$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 ;
@@ -296,7 +322,7 @@ 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 manual page 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.
@@ -321,11 +347,6 @@ 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.
-When opening an existing database, you may omit the final three arguments
-to C<tie>; they default to O_RDWR, 0644, and $DB_HASH. If you're
-creating a new file, you need to specify at least the C<$flags>
-argument, which must include O_CREAT.
-
=item B<DB_BTREE>
The btree format allows arbitrary key/value pairs to be stored in a
@@ -354,12 +375,12 @@ array (for the DB_RECNO file type).
In addition to the tie() interface, it is also possible to access most
of the functions provided in the Berkeley DB API directly.
-See L<"Using the Berkeley DB API Directly">.
+See L<THE API INTERFACE>.
=head2 Opening a Berkeley DB Database File
Berkeley DB uses the function dbopen() to open or create a database.
-Below is the C prototype for dbopen().
+Here is the C prototype for dbopen():
DB*
dbopen (const char * file, int flags, int mode,
@@ -431,14 +452,14 @@ for DB_HASH, DB_BTREE and DB_RECNO respectively.
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 set of values - that means you don't have to set I<all> of the
+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 values need extra discussion here. When used, the C
+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:
@@ -470,7 +491,11 @@ to Perl subs. Below are templates for each of the subs:
return $bytes ;
}
-See L<"Using BTREE"> for an example of using the C<compare>
+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
@@ -482,7 +507,7 @@ common file format used, the call:
is equivalent to:
- tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0640, $DB_HASH ;
+ 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:
@@ -491,25 +516,150 @@ call:
is equivalent to:
- tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0640, $DB_HASH ;
+ 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>
+See L<In Memory Databases> for a discussion on the use of C<undef>
in place of a filename.
-=head2 Handling duplicate keys in BTREE databases
+=head2 In Memory Databases
+
+Berkeley DB allows the creation of in-memory databases by using NULL
+(that is, a C<(char *)0> in C) in place of the filename. B<DB_File>
+uses C<undef> instead of NULL to provide this functionality.
+
+=head1 DB_HASH
+
+The DB_HASH file format is probably the most commonly used of the three
+file formats that B<DB_File> supports. It is also very straightforward
+to use.
+
+=head2 A Simple Example.
+
+This example shows how to create a database, add key/value pairs to the
+database, delete keys/value pairs and finally how to enumerate the
+contents of the database.
+
+ use strict ;
+ use DB_File ;
+ use vars qw( %h $k $v ) ;
+
+ tie %h, "DB_File", "fruit", O_RDWR|O_CREAT, 0640, $DB_HASH
+ or die "Cannot open file 'fruit': $!\n";
+
+ # Add a few key/value pairs to the file
+ $h{"apple"} = "red" ;
+ $h{"orange"} = "orange" ;
+ $h{"banana"} = "yellow" ;
+ $h{"tomato"} = "red" ;
+
+ # Check for existence of a key
+ print "Banana Exists\n\n" if $h{"banana"} ;
+
+ # Delete a key/value pair.
+ delete $h{"apple"} ;
+
+ # print the contents of the file
+ while (($k, $v) = each %h)
+ { print "$k -> $v\n" }
+
+ untie %h ;
+
+here is the output:
+
+ Banana Exists
+
+ orange -> orange
+ tomato -> red
+ banana -> yellow
+
+Note that the like ordinary associative arrays, the order of the keys
+retrieved is in an apparently random order.
+
+=head1 DB_BTREE
+
+The DB_BTREE format is useful when you want to store data in a given
+order. By default the keys will be stored in lexical order, but as you
+will see from the example shown in the next section, it is very easy to
+define your own sorting function.
+
+=head2 Changing the BTREE sort order
+
+This script shows how to override the default sorting algorithm that
+BTREE uses. Instead of using the normal lexical ordering, a case
+insensitive compare function will be used.
+
+ use strict ;
+ use DB_File ;
+
+ my %h ;
+
+ sub Compare
+ {
+ my ($key1, $key2) = @_ ;
+ "\L$key1" cmp "\L$key2" ;
+ }
+
+ # specify the Perl sub that will do the comparison
+ $DB_BTREE->{'compare'} = \&Compare ;
+
+ tie %h, "DB_File", "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE
+ or die "Cannot open file 'tree': $!\n" ;
+
+ # Add a key/value pair to the file
+ $h{'Wall'} = 'Larry' ;
+ $h{'Smith'} = 'John' ;
+ $h{'mouse'} = 'mickey' ;
+ $h{'duck'} = 'donald' ;
+
+ # Delete
+ delete $h{"duck"} ;
+
+ # Cycle through the keys printing them in order.
+ # Note it is not necessary to sort the keys as
+ # the btree will have kept them in order automatically.
+ foreach (keys %h)
+ { print "$_\n" }
+
+ untie %h ;
+
+Here is the output from the code above.
+
+ mouse
+ Smith
+ Wall
+
+There are a few point to bear in mind if you want to change the
+ordering in a BTREE database:
+
+=over 5
+
+=item 1.
+
+The new compare function must be specified when you create the database.
+
+=item 2.
-The BTREE file type in Berkeley DB 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
+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 Fcntl ;
-
+
+ use vars qw($filename %h ) ;
+
$filename = "tree" ;
unlink $filename ;
@@ -522,6 +672,7 @@ code:
# 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' ;
@@ -530,20 +681,22 @@ code:
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 2 records have been successfully created with key C<Wall>
+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
-both 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.
+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
@@ -551,14 +704,16 @@ 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<"Using the Berkeley DB API Directly"> for details of both
-the C<seq> method and the API in general.
+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 Fcntl ;
+ use vars qw($filename $x %h $status $key $value) ;
+
$filename = "tree" ;
unlink $filename ;
@@ -571,16 +726,16 @@ Here is the script above rewritten using the C<seq> API method.
# 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' ;
- # Point to the first record in the btree
- $x->seq($key, $value, R_FIRST) ;
-
- # now iterate through the rest of the btree
+ # iterate through the btree using seq
# and print each key/value pair.
- print "$key -> $value\n" ;
- while ( $x->seq($key, $value, R_NEXT) == 0)
+ $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 ;
@@ -590,13 +745,16 @@ that prints:
Smith -> John
Wall -> Brick
+ Wall -> Brick
Wall -> Larry
mouse -> mickey
-This time we have got all the key/value pairs, including both the
+This time we have got all the key/value pairs, including the multiple
values associated with the key C<Wall>.
-C<DB_File> comes with a utility method, called C<get_dup>, to assist in
+=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:
@@ -608,40 +766,124 @@ 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 returned will be in an apparently random order.
+that the values will be returned in an apparently random order.
-If the second parameter is present and evaluates TRUE, the method
-returns an associative array whose keys correspond to the the values
-from the BTREE and whose values are all C<1>.
+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 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_dups> like
+So assuming the database created above, we can use C<get_dup> like
this:
- $cnt = $x->get_dups("Wall") ;
+ my $cnt = $x->get_dup("Wall") ;
print "Wall occurred $cnt times\n" ;
- %hash = $x->get_dups("Wall", 1) ;
+ my %hash = $x->get_dup("Wall", 1) ;
print "Larry is there\n" if $hash{'Larry'} ;
+ print "There are $hash{'Brick'} Brick Walls\n" ;
- @list = $x->get_dups("Wall") ;
+ my @list = $x->get_dup("Wall") ;
print "Wall => [@list]\n" ;
- @list = $x->get_dups("Smith") ;
+ @list = $x->get_dup("Smith") ;
print "Smith => [@list]\n" ;
- @list = $x->get_dups("Dog") ;
+ @list = $x->get_dup("Dog") ;
print "Dog => [@list]\n" ;
and it will print:
- Wall occurred 2 times
+ Wall occurred 3 times
Larry is there
- Wall => [Brick Larry]
+ There are 2 Brick Walls
+ Wall => [Brick Brick Larry]
Smith => [John]
Dog => []
-=head2 RECNO
+=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.
@@ -651,14 +893,231 @@ 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 In Memory Databases
+=head2 The bval option
-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.
+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
-=head2 Using the Berkeley DB API Directly
+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) ;>
+
+Pushes the elements of C<list> to the start of the array.
+
+=item B<$X-E<gt>length>
+
+Returns the number of elements in the array.
+
+=back
+
+=head2 Another Example
+
+Here is a more complete example that makes use of some of the methods
+described above. It also makes use of the API interface directly (see
+L<THE API INTERFACE>).
+
+ use strict ;
+ use vars qw(@h $H $file $i) ;
+ use DB_File ;
+ use Fcntl ;
+
+ $file = "text" ;
+
+ unlink $file ;
+
+ $H = tie @h, "DB_File", $file, O_RDWR|O_CREAT, 0640, $DB_RECNO
+ or die "Cannot open file $file: $!\n" ;
+
+ # first create a text file to play with
+ $h[0] = "zero" ;
+ $h[1] = "one" ;
+ $h[2] = "two" ;
+ $h[3] = "three" ;
+ $h[4] = "four" ;
+
+
+ # Print the records in order.
+ #
+ # The length method is needed here because evaluating a tied
+ # array in a scalar context does not return the number of
+ # elements in the array.
+
+ print "\nORIGINAL\n" ;
+ foreach $i (0 .. $H->length - 1) {
+ print "$i: $h[$i]\n" ;
+ }
+
+ # use the push & pop methods
+ $a = $H->pop ;
+ $H->push("last") ;
+ print "\nThe last record was [$a]\n" ;
+
+ # and the shift & unshift methods
+ $a = $H->shift ;
+ $H->unshift("first") ;
+ print "The first record was [$a]\n" ;
+
+ # Use the API to add a new record after record 2.
+ $i = 2 ;
+ $H->put($i, "Newbie", R_IAFTER) ;
+
+ # and a new record before record 1.
+ $i = 1 ;
+ $H->put($i, "New One", R_IBEFORE) ;
+
+ # delete record 3
+ $H->del(3) ;
+
+ # now print the records in reverse order
+ print "\nREVERSE\n" ;
+ for ($i = $H->length - 1 ; $i >= 0 ; -- $i)
+ { print "$i: $h[$i]\n" }
+
+ # same again, but use the API functions instead
+ print "\nREVERSE again\n" ;
+ my ($s, $k, $v) = (0, 0, 0) ;
+ for ($s = $H->seq($k, $v, R_LAST) ;
+ $s == 0 ;
+ $s = $H->seq($k, $v, R_PREV))
+ { print "$k: $v\n" }
+
+ undef $H ;
+ untie @h ;
+
+and this is what it outputs:
+
+ ORIGINAL
+ 0: zero
+ 1: one
+ 2: two
+ 3: three
+ 4: four
+
+ The last record was [four]
+ The first record was [zero]
+
+ REVERSE
+ 5: last
+ 4: three
+ 3: Newbie
+ 2: one
+ 1: New One
+ 0: first
+
+ REVERSE again
+ 5: last
+ 4: three
+ 3: Newbie
+ 2: one
+ 1: New One
+ 0: first
+
+Notes:
+
+=over 5
+
+=item 1.
+
+Rather than iterating through the array, C<@h> like this:
+
+ foreach $i (@h)
+
+it is necessary to use either this:
+
+ foreach $i (0 .. $H->length - 1)
+
+or this:
+
+ for ($a = $H->get($k, $v, R_FIRST) ;
+ $a == 0 ;
+ $a = $H->get($k, $v, R_NEXT) )
+
+=item 2.
+
+Notice that both times the C<put> method was used the record index was
+specified using a variable, C<$i>, rather than the literal value
+itself. This is because C<put> will return the record number of the
+inserted line via that parameter.
+
+=back
+
+=head1 THE API INTERFACE
As well as accessing Berkeley DB using a tied hash or array, it is also
possible to make direct use of most of the API functions defined in the
@@ -676,7 +1135,7 @@ as B<DB_File> methods directly like this:
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.
+destroyed.
use DB_File ;
$db = tie %hash, "DB_File", "filename"
@@ -755,7 +1214,7 @@ Below is a list of the methods available.
=over 5
-=item C<$status = $X-E<gt>get($key, $value [, $flags]) ;>
+=item B<$status = $X-E<gt>get($key, $value [, $flags]) ;>
Given a key (C<$key>) this method reads the value associated with it
from the database. The value read from the database is returned in the
@@ -765,7 +1224,7 @@ If the key does not exist the method returns 1.
No flags are currently defined for this method.
-=item C<$status = $X-E<gt>put($key, $value [, $flags]) ;>
+=item B<$status = $X-E<gt>put($key, $value [, $flags]) ;>
Stores the key/value pair in the database.
@@ -775,7 +1234,7 @@ will have the record number of the inserted key/value pair set.
Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and
R_SETCURSOR.
-=item C<$status = $X-E<gt>del($key [, $flags]) ;>
+=item B<$status = $X-E<gt>del($key [, $flags]) ;>
Removes all key/value pairs with key C<$key> from the database.
@@ -784,14 +1243,14 @@ database.
R_CURSOR is the only valid flag at present.
-=item C<$status = $X-E<gt>fd ;>
+=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
+See L<Locking Databases> for an example of how to make use of the
C<fd> method to lock your database.
-=item C<$status = $X-E<gt>seq($key, $value, $flags) ;>
+=item B<$status = $X-E<gt>seq($key, $value, $flags) ;>
This interface allows sequential retrieval from the database. See
L<dbopen> for full details.
@@ -802,7 +1261,7 @@ 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 C<$status = $X-E<gt>sync([$flags]) ;>
+=item B<$status = $X-E<gt>sync([$flags]) ;>
Flushes any cached buffers to disk.
@@ -810,95 +1269,8 @@ R_RECNOSYNC is the only valid flag at present.
=back
-=head1 EXAMPLES
-
-It is always a lot easier to understand something when you see a real
-example. So here are a few.
-
-=head2 Using HASH
-
- use DB_File ;
- use Fcntl ;
-
- tie %h, "DB_File", "hashed", O_RDWR|O_CREAT, 0640, $DB_HASH
- or die "Cannot open file 'hashed': $!\n";
-
- # 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 ;
-
-=head2 Using BTREE
-
-Here is a sample of code which uses BTREE. Just to make life more
-interesting the default comparison function will not be used. Instead
-a Perl sub, C<Compare()>, will be used to do a case insensitive
-comparison.
-
- 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
- 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
-
-
-=head2 Using RECNO
-
-Here is a simple example that uses RECNO.
-
- use DB_File ;
- use Fcntl ;
-
- $DB_RECNO->{'psize'} = 3000 ;
-
- tie @h, "DB_File", "text", O_RDWR|O_CREAT, 0640, $DB_RECNO
- or die "Cannot open file 'text': $!\n" ;
-
- # Add a key/value pair to the file
- $h[0] = "orange" ;
-
- # Check for existence of a key
- print "Exists\n" if $h[1] ;
+=head1 HINTS AND TIPS
- untie @h ;
=head2 Locking Databases
@@ -908,7 +1280,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;
@@ -951,7 +1322,7 @@ in the background to watch the locks granted in proper order.
print "$$: Write lock granted\n";
$db{$key} = $value;
- $db->sync;
+ $db->sync; # to flush
sleep 10;
flock(DB_FH, LOCK_UN);
@@ -960,6 +1331,135 @@ in the background to watch the locks granted in proper order.
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 ;
+
+
+=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
@@ -998,7 +1498,7 @@ an error.
=item 1.02
-Merged OS2 specific code into DB_File.xs
+Merged OS/2 specific code into DB_File.xs
Removed some redundant code in DB_File.xs.
@@ -1011,16 +1511,60 @@ 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.
-Added get_dups method.
+Added get_dup method.
+
+=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.
-=head1 WARNINGS
+=item 1.04
-If you happen to 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.
+Minor documentation changes.
-If you cannot find any, then either you didn't look very hard or the
-moment has passed and I have dropped them.
+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.
+
+=back
=head1 BUGS
@@ -1033,10 +1577,14 @@ suggest any enhancements, I would welcome your comments.
=head1 AVAILABILITY
+B<DB_File> comes with the standard Perl source distribution. Look in
+the directory F<ext/DB_File>.
+
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
@@ -1046,9 +1594,6 @@ compile properly on IRIX 5.3.
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
diff --git a/ext/DB_File/DB_File.xs b/ext/DB_File/DB_File.xs
index f344794c42..a13eaa6267 100644
--- a/ext/DB_File/DB_File.xs
+++ b/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 26th June 1996
- version 1.02
+ last modified 18th Dec 1996
+ version 1.09
All comments/suggestions/problems are welcome
+ Copyright (c) 1995, 1996 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.
@@ -22,6 +26,16 @@
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
+
*/
#include "EXTERN.h"
@@ -32,25 +46,40 @@
#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 ;
+ 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)
@@ -196,7 +225,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 ;
@@ -221,44 +255,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 = %d [%s]\n", recno.bfname, 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 = %d\n", 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
@@ -309,101 +344,108 @@ I32 value ;
}
static DB_File
-ParseOpenInfo(name, flags, mode, sv, string)
+ParseOpenInfo(name, flags, mode, sv)
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 ;
+ 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;
+
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"))
{
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"))
{
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) ;
@@ -411,44 +453,46 @@ char * string ;
else if (sv_isa(sv, "DB_File::RECNOINFO"))
{
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 = (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);
- if (svp) {
+ if (svp && SvOK(*svp)) {
char * ptr = SvPV(*svp,na) ;
- info.recno.bfname = (char*) na ? ptr : 0 ;
+ info->recno.bfname = (char*) na ? ptr : NULL ;
}
+ else
+ info->recno.bfname = NULL ;
PrintRecno(info) ;
}
@@ -725,11 +769,10 @@ constant(name,arg)
DB_File
-db_TIEHASH(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0640, type=DB_HASH)
+db_DoTie_(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0666, type=DB_HASH)
char * dbtype
int flags
int mode
- ALIAS: TIEARRAY = 1
CODE:
{
char * name = (char *) NULL ;
@@ -741,7 +784,7 @@ db_TIEHASH(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0640, type=DB_HASH)
if (items == 5)
sv = ST(4) ;
- RETVAL = ParseOpenInfo(name, flags, mode, sv, "new") ;
+ RETVAL = ParseOpenInfo(name, flags, mode, sv) ;
if (RETVAL->dbp == NULL)
RETVAL = NULL ;
}
@@ -771,6 +814,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
@@ -887,9 +945,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);
}
}
@@ -898,20 +958,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) ;
}
}
@@ -1018,3 +1080,4 @@ db_seq(db, key, value, flags)
OUTPUT:
key
value
+
diff --git a/ext/DynaLoader/DynaLoader.pm b/ext/DynaLoader/DynaLoader.pm
index 282d364372..b634aef051 100644
--- a/ext/DynaLoader/DynaLoader.pm
+++ b/ext/DynaLoader/DynaLoader.pm
@@ -273,7 +273,7 @@ sub dl_expandspec {
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_undef_symbols(), dl_install_xsub(), bootstrap() - routines used by DynaLoader modules
=head1 SYNOPSIS
@@ -523,7 +523,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:
diff --git a/ext/DynaLoader/Makefile.PL b/ext/DynaLoader/Makefile.PL
index 5ccdc68a0e..9323935880 100644
--- a/ext/DynaLoader/Makefile.PL
+++ b/ext/DynaLoader/Makefile.PL
@@ -3,7 +3,7 @@ use ExtUtils::MakeMaker;
WriteMakefile(
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?
diff --git a/ext/DynaLoader/dl_aix.xs b/ext/DynaLoader/dl_aix.xs
index f8bace1314..68831ed8b0 100644
--- a/ext/DynaLoader/dl_aix.xs
+++ b/ext/DynaLoader/dl_aix.xs
@@ -527,9 +527,9 @@ void *
dl_load_file(filename)
char * filename
CODE:
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", 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 +542,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 +567,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/ext/DynaLoader/dl_dld.xs b/ext/DynaLoader/dl_dld.xs
index a0028a1f7a..d2f2f7f53d 100644
--- a/ext/DynaLoader/dl_dld.xs
+++ b/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__
}
@@ -83,12 +83,12 @@ dl_load_file(filename)
int dlderr,x,max;
GV *gv;
RETVAL = filename;
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s)\n", filename));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s)\n", 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 +96,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 +105,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 +123,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 +157,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/ext/DynaLoader/dl_dlopen.xs b/ext/DynaLoader/dl_dlopen.xs
index a2a68162b2..5dfe5c160f 100644
--- a/ext/DynaLoader/dl_dlopen.xs
+++ b/ext/DynaLoader/dl_dlopen.xs
@@ -151,9 +151,9 @@ dl_load_file(filename)
if (dl_nonlazy)
mode = RTLD_NOW;
#endif
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", 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()) ;
@@ -170,10 +170,10 @@ dl_find_symbol(libhandle, symbolname)
char symbolname_buf[1024];
symbolname = dl_add_underscore(symbolname, symbolname_buf);
#endif
- 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()) ;
@@ -195,7 +195,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/ext/DynaLoader/dl_hpux.xs b/ext/DynaLoader/dl_hpux.xs
index 0e146830ef..3d6b2d32d4 100644
--- a/ext/DynaLoader/dl_hpux.xs
+++ b/ext/DynaLoader/dl_hpux.xs
@@ -48,21 +48,25 @@ dl_load_file(filename)
bind_type = BIND_IMMEDIATE;
else
bind_type = BIND_DEFERRED;
+#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)
@@ -83,17 +87,17 @@ dl_find_symbol(libhandle, symbolname)
char symbolname_buf[MAXPATHLEN];
symbolname = dl_add_underscore(symbolname, symbolname_buf);
#endif
- 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));
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 +121,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/ext/DynaLoader/dl_next.xs b/ext/DynaLoader/dl_next.xs
index 9e98d562e0..3e908ff02a 100644
--- a/ext/DynaLoader/dl_next.xs
+++ b/ext/DynaLoader/dl_next.xs
@@ -245,9 +245,9 @@ dl_load_file(filename)
char * filename
CODE:
int mode = 1;
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", 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()) ;
@@ -264,10 +264,10 @@ dl_find_symbol(libhandle, symbolname)
char symbolname_buf[1024];
symbolname = dl_add_underscore(symbolname, symbolname_buf);
#endif
- 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()) ;
@@ -289,7 +289,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/ext/DynaLoader/dl_os2.xs b/ext/DynaLoader/dl_os2.xs
index 2c72be23ed..3042a002b2 100644
--- a/ext/DynaLoader/dl_os2.xs
+++ b/ext/DynaLoader/dl_os2.xs
@@ -126,9 +126,9 @@ dl_load_file(filename)
#ifdef RTLD_LAZY
mode = RTLD_LAZY; /* Solaris 2 */
#endif
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n", 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()) ;
@@ -145,10 +145,10 @@ dl_find_symbol(libhandle, symbolname)
char symbolname_buf[1024];
symbolname = dl_add_underscore(symbolname, symbolname_buf);
#endif
- 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()) ;
@@ -173,7 +173,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/ext/DynaLoader/dl_vms.xs b/ext/DynaLoader/dl_vms.xs
index 3f46ffc940..a646e116ab 100644
--- a/ext/DynaLoader/dl_vms.xs
+++ b/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,14 +210,14 @@ 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));
}
}
@@ -242,16 +242,16 @@ dl_load_file(filespec)
vmssts sts, failed = 0;
void (*entry)();
- DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n",filespec));
+ DLDEBUG(1,PerlIO_printf(PerlIO_stderr(), "dl_load_file(%s):\n",filespec));
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);
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 +267,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 +311,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 +339,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/ext/DynaLoader/dlutils.c b/ext/DynaLoader/dlutils.c
index 07ea3325b6..e13427a353 100644
--- a/ext/DynaLoader/dlutils.c
+++ b/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 */
@@ -79,12 +79,12 @@ SaveError(pat, va_alist)
/* Copy message into LastError (including terminating null char) */
strncpy(LastError, message, len) ;
- DLDEBUG(2,fprintf(stderr,"DynaLoader: stored error msg '%s'\n",LastError));
+ DLDEBUG(2,PerlIO_printf(PerlIO_stderr(), "DynaLoader: stored error msg '%s'\n",LastError));
}
/* prepend underscore to s. write into buf. return buf. */
-char *
+static char *
dl_add_underscore(s, buf)
char *s;
char *buf;
diff --git a/ext/Fcntl/Fcntl.pm b/ext/Fcntl/Fcntl.pm
index 32a3194326..9d000a1e68 100644
--- a/ext/Fcntl/Fcntl.pm
+++ b/ext/Fcntl/Fcntl.pm
@@ -26,7 +26,6 @@ pack up your own arguments to pass as args for locking functions, etc.
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
require Exporter;
-use AutoLoader;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
$VERSION = "1.00";
@@ -66,8 +65,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/ext/FileHandle/FileHandle.pm b/ext/FileHandle/FileHandle.pm
deleted file mode 100644
index a6d1dda0fe..0000000000
--- a/ext/FileHandle/FileHandle.pm
+++ /dev/null
@@ -1,479 +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) = @_;
-
- # During global object destruction, this function may be called
- # on FILEHANDLEs as well as on the GLOBs that contains them.
- # Thus the following trickery. If only the CORE file operators
- # could deal with FILEHANDLEs, it wouldn't be necessary...
-
- if ($fh =~ /=FILEHANDLE\(/) {
- local *TMP = $fh;
- close(TMP) if fileno(TMP);
- }
- else {
- close($fh) if fileno($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/ext/FileHandle/FileHandle.xs b/ext/FileHandle/FileHandle.xs
deleted file mode 100644
index 8b1c60eb25..0000000000
--- a/ext/FileHandle/FileHandle.xs
+++ /dev/null
@@ -1,176 +0,0 @@
-#include "EXTERN.h"
-#include "perl.h"
-#include "XSUB.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/ext/FileHandle/Makefile.PL b/ext/FileHandle/Makefile.PL
deleted file mode 100644
index 7efd382043..0000000000
--- a/ext/FileHandle/Makefile.PL
+++ /dev/null
@@ -1,7 +0,0 @@
-use ExtUtils::MakeMaker;
-WriteMakefile(
- NAME => 'FileHandle',
- MAN3PODS => ' ', # Pods will be built by installman.
- XSPROTOARG => '-noprototypes', # XXX remove later?
- VERSION_FROM => 'FileHandle.pm',
-);
diff --git a/ext/IO/IO.pm b/ext/IO/IO.pm
index 645837bbf8..1ba05ca916 100644
--- a/ext/IO/IO.pm
+++ b/ext/IO/IO.pm
@@ -2,6 +2,30 @@
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;
diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs
index 9dc09b2e01..3cc3518e7e 100644
--- a/ext/IO/IO.xs
+++ b/ext/IO/IO.xs
@@ -1,13 +1,25 @@
#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)
@@ -62,12 +74,6 @@ IV *pval;
#else
return FALSE;
#endif
- if (strEQ(name, "SEEK_EOF"))
-#ifdef SEEK_EOF
- { *pval = SEEK_EOF; return TRUE; }
-#else
- return FALSE;
-#endif
break;
}
@@ -81,35 +87,35 @@ SV *
fgetpos(handle)
InputStream handle
CODE:
-#ifdef HAS_FGETPOS
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;
}
-#else
- ST(0) = (SV *) not_here("IO::Seekable::fgetpos");
-#endif
SysRet
fsetpos(handle, pos)
InputStream handle
SV * pos
CODE:
-#ifdef HAS_FSETPOS
if (handle)
+#ifdef PerlIO
+ RETVAL = PerlIO_setpos(handle, (Fpos_t*)SvPVX(pos));
+#else
RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos));
+#endif
else {
RETVAL = -1;
errno = EINVAL;
}
-#else
- RETVAL = (SysRet) not_here("IO::Seekable::fsetpos");
-#endif
OUTPUT:
RETVAL
@@ -119,7 +125,11 @@ OutputStream
new_tmpfile(packname = "IO::File")
char * packname
CODE:
+#ifdef PerlIO
+ RETVAL = PerlIO_tmpfile();
+#else
RETVAL = tmpfile();
+#endif
OUTPUT:
RETVAL
@@ -141,7 +151,11 @@ ungetc(handle, c)
int c
CODE:
if (handle)
+#ifdef PerlIO
+ RETVAL = PerlIO_ungetc(handle, c);
+#else
RETVAL = ungetc(c, handle);
+#endif
else {
RETVAL = -1;
errno = EINVAL;
@@ -154,7 +168,11 @@ ferror(handle)
InputStream handle
CODE:
if (handle)
+#ifdef PerlIO
+ RETVAL = PerlIO_error(handle);
+#else
RETVAL = ferror(handle);
+#endif
else {
RETVAL = -1;
errno = EINVAL;
@@ -162,12 +180,52 @@ ferror(handle)
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:
+ IO * io;
+ io = sv_2io(handle);
+ if (io) {
+ IoFLAGS(io) |= IOf_UNTAINT;
+ RETVAL = 0;
+ }
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+ 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;
@@ -181,9 +239,11 @@ setbuf(handle, buf)
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)
@@ -192,6 +252,7 @@ setvbuf(handle, buf, type, size)
int type
int size
CODE:
+#ifdef PERLIO_IS_STDIO
#ifdef _IOFBF /* Should be HAS_SETVBUF once Configure tests for that */
if (handle)
RETVAL = setvbuf(handle, buf, type, size);
@@ -202,6 +263,9 @@ setvbuf(handle, buf, type, size)
#else
RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
#endif /* _IOFBF */
+#else
+ not_here("IO::Handle::setvbuf");
+#endif
OUTPUT:
RETVAL
diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm
index c447dfa2a9..81d48b1c54 100644
--- a/ext/IO/lib/IO/File.pm
+++ b/ext/IO/lib/IO/File.pm
@@ -1,5 +1,3 @@
-#
-
package IO::File;
=head1 NAME
@@ -43,33 +41,59 @@ IO::File - supply object methods for filehandles
=head1 DESCRIPTION
-C<IO::File::new> creates a C<IO::File>, which is a reference to a
-newly created symbol (see the C<Symbol> package). If it receives any
-parameters, they are passed to C<IO::File::open>; if the open fails,
-the C<IO::File> object is destroyed. Otherwise, it is returned to
-the caller.
+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.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item open( FILENAME [,MODE [,PERMS]] )
-C<IO::File::open> accepts one parameter or two. With one parameter,
+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 in either Perl form (">", "+<", etc.) or POSIX form
-("w", "r+", etc.).
+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">
+L<IO::Handle>
+L<IO::Seekable>
=head1 HISTORY
-Derived from FileHandle.pm by Graham Barr <bodg@tiuk.ti.com>
+Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>.
=head1 REVISION
-$Revision: 1.3 $
+$Revision: 1.5 $
=cut
@@ -77,7 +101,6 @@ require 5.000;
use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD);
use Carp;
use Symbol;
-use English;
use SelectSaver;
use IO::Handle qw(_open_mode_string);
use IO::Seekable;
@@ -87,24 +110,24 @@ require DynaLoader;
@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/);
@EXPORT = @IO::Seekable::EXPORT;
-################################################
-## If the Fcntl extension is available,
-## export its constants.
-##
-
sub import {
my $pkg = shift;
my $callpkg = caller;
- Exporter::export $pkg, $callpkg;
+ Exporter::export $pkg, $callpkg, @_;
+
+ #
+ # If the Fcntl extension is available,
+ # export its constants for sysopen().
+ #
eval {
require Fcntl;
- Exporter::export 'Fcntl', $callpkg;
+ Exporter::export 'Fcntl', $callpkg, '/^O_/';
};
-};
+}
################################################
@@ -112,8 +135,10 @@ sub import {
##
sub new {
- @_ >= 1 && @_ <= 3 or croak 'usage: new IO::File [FILENAME [,MODE]]';
- my $class = shift;
+ 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(@_)
diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm
index aaba77c056..925b20806d 100644
--- a/ext/IO/lib/IO/Handle.pm
+++ b/ext/IO/lib/IO/Handle.pm
@@ -1,10 +1,8 @@
-#
-
package IO::Handle;
=head1 NAME
-IO::Handle - supply object methods for filehandles
+IO::Handle - supply object methods for I/O handles
=head1 SYNOPSIS
@@ -43,39 +41,27 @@ IO::Handle - supply object methods for filehandles
=head1 DESCRIPTION
-C<IO::Handle::new> creates a C<IO::Handle>, which is a reference to a
-newly created symbol (see the C<Symbol> package). If it receives any
-parameters, they are passed to C<IO::Handle::open>; if the open fails,
-the C<IO::Handle> object is destroyed. Otherwise, it is returned to
-the caller.
-
-C<IO::Handle::new_from_fd> creates a C<IO::Handle> like C<new> does.
-It requires two parameters, which are passed to C<IO::Handle::fdopen>;
-if the fdopen fails, the C<IO::Handle> object is destroyed.
-Otherwise, it is returned to the caller.
-
-C<IO::Handle::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<IO::Handle::fdopen> is like 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.
+C<IO::Handle> is the base class for all other IO handle classes.
+A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package)
-C<IO::Handle::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>.
+=head1 CONSTRUCTOR
+
+=over 4
-C<IO::Handle::opened> returns true if the object is currently a valid
-file descriptor.
+=item new ()
-If the C functions fgetpos() and fsetpos() are available, then
-C<IO::Handle::getpos> returns an opaque value that represents the
-current position of the IO::Handle, and C<IO::Handle::setpos> uses
-that value to return to a previously visited position.
+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
If the C function setvbuf() is available, then C<IO::Handle::setvbuf>
sets the buffering policy for the IO::Handle. The calling sequence
@@ -99,6 +85,10 @@ corresponding built-in functions:
read
truncate
stat
+ print
+ printf
+ sysread
+ syswrite
See L<perlvar> for complete descriptions of each of the following
supported C<IO::Handle> methods:
@@ -121,14 +111,6 @@ 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">
@@ -141,11 +123,40 @@ 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->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->write ( BUF, LEN [, OFFSET }\] )
+
+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->opened
+
+Returns true if the object is currently a valid file descriptor.
+
=back
-=head1
+Lastly, a special method for working under B<-T> and setuid/gid scripts:
+
+=over
-The reference returned from new is a GLOB reference. Some modules that
+=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
@@ -156,7 +167,7 @@ module keeps a C<timeout> variable in 'io_socket_timeout'.
L<perlfunc>,
L<perlop/"I/O Operators">,
-L<POSIX/"FileHandle">
+L<FileHandle>
=head1 BUGS
@@ -167,12 +178,12 @@ class from C<IO::Handle> and inherit those methods.
=head1 HISTORY
-Derived from FileHandle.pm by Graham Barr <bodg@tiuk.ti.com>
+Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
=cut
require 5.000;
-use vars qw($VERSION @EXPORT_OK $AUTOLOAD);
+use vars qw($RCS $VERSION @EXPORT_OK $AUTOLOAD);
use Carp;
use Symbol;
use SelectSaver;
@@ -180,13 +191,8 @@ use SelectSaver;
require Exporter;
@ISA = qw(Exporter);
-##
-## TEMPORARY workaround as perl expects handles to be <FileHandle> objects
-##
-@FileHandle::ISA = qw(IO::Handle);
-
-
-$VERSION = sprintf("%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "1.12";
+$RCS = sprintf("%s", q$Revision: 1.15 $ =~ /([\d\.]+)/);
@EXPORT_OK = qw(
autoflush
@@ -246,30 +252,33 @@ sub AUTOLOAD {
##
sub new {
- @_ == 1 or croak 'usage: new IO::Handle';
- my $class = ref($_[0]) || $_[0];
+ my $class = ref($_[0]) || $_[0] || "IO::Handle";
+ @_ == 1 or croak "usage: new $class";
my $fh = gensym;
bless $fh, $class;
}
sub new_from_fd {
- @_ == 3 or croak 'usage: new_from_fd IO::Handle FD, MODE';
- my $class = shift;
+ 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;
- $fh->_ref_fd;
- $fh;
}
-# FileHandle::DESTROY use to call close(). This creates a problem
-# if 2 Handle objects have the same fd. sv_clear will call io close
-# when the refcount in the xpvio becomes zero.
#
-# It is defined as empty to stop AUTOLOAD being called :-)
+# That an IO::Handle is being destroyed does not necessarily mean
+# that the associated filehandle should be closed. This is because
+# *FOO{FILEHANDLE} may by a synonym for *BAR{FILEHANDLE}.
+#
+# If this IO::Handle really does have the final reference to the
+# given FILEHANDLE, then Perl will close it for us automatically.
+#
-sub DESTROY { }
+sub DESTROY {
+}
################################################
## Open and close.
@@ -321,12 +330,8 @@ sub close {
## Normal I/O functions.
##
-# fcntl
# flock
-# ioctl
# select
-# sysread
-# syswrite
sub opened {
@_ == 1 or croak 'usage: $fh->opened()';
@@ -374,9 +379,9 @@ sub getline {
sub getlines {
@_ == 1 or croak 'usage: $fh->getline()';
- my $this = shift;
wantarray or
- croak "Can't call IO::Handle::getlines in a scalar context, use IO::Handle::getline";
+ croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline';
+ my $this = shift;
return <$this>;
}
@@ -390,12 +395,22 @@ sub read {
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]);
@@ -510,5 +525,18 @@ sub format_write {
}
}
+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/ext/IO/lib/IO/Pipe.pm b/ext/IO/lib/IO/Pipe.pm
index 33d7219aef..27fe7f1aa2 100644
--- a/ext/IO/lib/IO/Pipe.pm
+++ b/ext/IO/lib/IO/Pipe.pm
@@ -38,31 +38,44 @@ IO::pipe - supply object methods for pipes
=head1 DESCRIPTION
-C<IO::Pipe::new> creates a C<IO::Pipe>, which is a reference to a
+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 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 untill either
+These two handles are held in the array part of the GLOB until either
C<reader> or C<writer> is called.
-=over
+=back
+
+=head1 METHODS
+
+=over 4
-=item $fh->reader([ARGS])
+=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 $fh->writer([ARGS])
+=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 $fh->handles
+=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
@@ -76,11 +89,11 @@ L<IO::Handle>
=head1 AUTHOR
-Graham Barr <bodg@tiuk.ti.com>
+Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
=head1 REVISION
-$Revision: 1.4 $
+$Revision: 1.7 $
=head1 COPYRIGHT
@@ -96,12 +109,14 @@ use Carp;
use Symbol;
require IO::Handle;
-$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/);
sub new {
- @_ == 1 || @_ == 3 or croak 'usage: new IO::Pipe([$READFH, $WRITEFH])';
+ my $type = shift;
+ my $class = ref($type) || $type || "IO::Pipe";
+ @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]";
- my $me = bless gensym(), shift;
+ my $me = bless gensym(), $class;
my($readfh,$writefh) = @_ ? @_ : $me->handles;
@@ -152,6 +167,7 @@ sub reader {
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;
@@ -167,6 +183,7 @@ sub writer {
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;
diff --git a/ext/IO/lib/IO/Seekable.pm b/ext/IO/lib/IO/Seekable.pm
index bfa0b2aae3..8e0f87ac18 100644
--- a/ext/IO/lib/IO/Seekable.pm
+++ b/ext/IO/lib/IO/Seekable.pm
@@ -6,6 +6,12 @@ package IO::Seekable;
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
@@ -29,16 +35,16 @@ corresponding built-in functions:
L<perlfunc>,
L<perlop/"I/O Operators">,
-L<"IO::Handle">
-L<"IO::File">
+L<IO::Handle>
+L<IO::File>
=head1 HISTORY
-Derived from FileHandle.pm by Graham Barr <bodg@tiuk.ti.com>
+Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt>
=head1 REVISION
-$Revision: 1.4 $
+$Revision: 1.5 $
=cut
@@ -51,7 +57,7 @@ require Exporter;
@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
@ISA = qw(Exporter);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/);
sub clearerr {
@_ == 1 or croak 'usage: $fh->clearerr()';
diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm
index 208be0cf53..845d6b25a4 100644
--- a/ext/IO/lib/IO/Select.pm
+++ b/ext/IO/lib/IO/Select.pm
@@ -4,9 +4,9 @@ package IO::Select;
=head1 NAME
-IO::Select - OO interface to the system select call
+IO::Select - OO interface to the select system call
-=head1 SYNOPSYS
+=head1 SYNOPSIS
use IO::Select;
@@ -31,7 +31,7 @@ are ready for reading, writing or have an error condition pending.
=item new ( [ HANDLES ] )
-The constructor create a new object and optionally initialises it with a set
+The constructor creates a new object and optionally initialises it with a set
of handles.
=back
@@ -49,7 +49,9 @@ handle with the same C<fileno> is specified then only the last one is cached.
=item remove ( HANDLES )
-Remove all the given handles from the object.
+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 can_read ( [ TIMEOUT ] )
@@ -66,6 +68,12 @@ Same as C<can_read> except check for handles that can be written to.
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 select ( READ, WRITE, ERROR [, TIMEOUT ] )
C<select> is a static method, that is you call it with the package name
@@ -110,11 +118,11 @@ listening for more connections on a listen socket
=head1 AUTHOR
-Graham Barr <Graham.Barr@tiuk.ti.com>
+Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
=head1 REVISION
-$Revision: 1.2 $
+$Revision: 1.9 $
=head1 COPYRIGHT
@@ -128,16 +136,20 @@ use strict;
use vars qw($VERSION @ISA);
require Exporter;
-$VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/);
@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 [''], $type;
+ my $vec = bless [undef,0], $type;
$vec->add(@_)
if @_;
@@ -150,14 +162,19 @@ sub add
my $vec = shift;
my $f;
+ $vec->[VEC_BITS] = '' unless defined $vec->[VEC_BITS];
+
foreach $f (@_)
{
my $fn = $f =~ /^\d+$/ ? $f : fileno($f);
next
unless defined $fn;
- vec($vec->[0],$fn++,1) = 1;
- $vec->[$fn] = $f;
+ vec($vec->[VEC_BITS],$fn,1) = 1;
+ $vec->[FD_COUNT] += 1
+ unless defined $vec->[$fn+FIRST_FD];
+ $vec->[$fn+FIRST_FD] = $f;
}
+ $vec->[VEC_BITS] = undef unless $vec->count;
}
sub remove
@@ -170,19 +187,20 @@ sub remove
my $fn = $f =~ /^\d+$/ ? $f : fileno($f);
next
unless defined $fn;
- vec($vec->[0],$fn++,1) = 0;
- $vec->[$fn] = undef;
+ vec($vec->[VEC_BITS],$fn,1) = 0;
+ $vec->[$fn+FIRST_FD] = undef;
+ $vec->[FD_COUNT] -= 1;
}
+ $vec->[VEC_BITS] = undef unless $vec->count;
}
sub can_read
{
my $vec = shift;
my $timeout = shift;
+ my $r = $vec->[VEC_BITS];
- my $r = $vec->[0];
-
- select($r,undef,undef,$timeout) > 0
+ defined($r) && (select($r,undef,undef,$timeout) > 0)
? _handles($vec, $r)
: ();
}
@@ -191,10 +209,9 @@ sub can_write
{
my $vec = shift;
my $timeout = shift;
+ my $w = $vec->[VEC_BITS];
- my $w = $vec->[0];
-
- select(undef,$w,undef,$timeout) > 0
+ defined($w) && (select(undef,$w,undef,$timeout) > 0)
? _handles($vec, $w)
: ();
}
@@ -203,14 +220,19 @@ sub has_error
{
my $vec = shift;
my $timeout = shift;
+ my $e = $vec->[VEC_BITS];
- my $e = $vec->[0];
-
- select(undef,undef,$e,$timeout) > 0
+ defined($e) && (select(undef,undef,$e,$timeout) > 0)
? _handles($vec, $e)
: ();
}
+sub count
+{
+ my $vec = shift;
+ $vec->[FD_COUNT];
+}
+
sub _max
{
my($a,$b,$c) = @_;
@@ -231,28 +253,28 @@ sub select
my($r,$w,$e,$t) = @_;
my @result = ();
- my $rb = defined $r ? $r->[0] : undef;
- my $wb = defined $w ? $e->[0] : undef;
- my $eb = defined $e ? $w->[0] : undef;
+ my $rb = defined $r ? $r->[VEC_BITS] : undef;
+ my $wb = defined $w ? $e->[VEC_BITS] : undef;
+ my $eb = defined $e ? $w->[VEC_BITS] : undef;
if(select($rb,$wb,$eb,$t) > 0)
{
my @r = ();
my @w = ();
my @e = ();
- my $i = _max(defined $r ? scalar(@$r) : 0,
- defined $w ? scalar(@$w) : 0,
- defined $e ? scalar(@$e) : 0);
+ my $i = _max(defined $r ? scalar(@$r)-1 : 0,
+ defined $w ? scalar(@$w)-1 : 0,
+ defined $e ? scalar(@$e)-1 : 0);
- for( ; $i > 0 ; $i--)
+ for( ; $i >= FIRST_FD ; $i--)
{
- my $j = $i - 1;
+ my $j = $i - FIRST_FD;
push(@r, $r->[$i])
- if defined $r->[$i] && vec($rb, $j, 1);
+ if defined $rb && defined $r->[$i] && vec($rb, $j, 1);
push(@w, $w->[$i])
- if defined $w->[$i] && vec($wb, $j, 1);
+ if defined $wb && defined $w->[$i] && vec($wb, $j, 1);
push(@e, $e->[$i])
- if defined $e->[$i] && vec($eb, $j, 1);
+ if defined $eb && defined $e->[$i] && vec($eb, $j, 1);
}
@result = (\@r, \@w, \@e);
@@ -267,11 +289,11 @@ sub _handles
my @h = ();
my $i;
- for($i = scalar(@$vec) - 1 ; $i > 0 ; $i--)
+ for($i = scalar(@$vec) - 1 ; $i >= FIRST_FD ; $i--)
{
next unless defined $vec->[$i];
push(@h, $vec->[$i])
- if vec($bits,$i - 1,1);
+ if vec($bits,$i - FIRST_FD,1);
}
@h;
diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm
index be81d9a64e..94ae88a536 100644
--- a/ext/IO/lib/IO/Socket.pm
+++ b/ext/IO/lib/IO/Socket.pm
@@ -4,7 +4,7 @@ package IO::Socket;
=head1 NAME
-IO::Socket - supply object methods for sockets
+IO::Socket - Object interface to socket communications
=head1 SYNOPSIS
@@ -20,6 +20,23 @@ 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>
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ARGS] )
+
+Creates a C<IO::Pipe>, 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 it will be. All other arguments will be passed to the
+configuration method of the package for that domain, See below.
+
+=back
+
+=head1 METHODS
+
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:
@@ -37,6 +54,8 @@ corresponding built-in functions:
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
@@ -58,7 +77,25 @@ 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
+with one argument then getsockopt is called, otherwise setsockopt is called.
+
+=item sockdomain
+
+Returns the numerical number for the socket domain type. For example, fir
+a AF_INET socket the value of &AF_INET will be returned.
+
+=item socktype
+
+Returns the numerical number for the socket type. For example, fir
+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
@@ -76,7 +113,8 @@ use Exporter;
@ISA = qw(IO::Handle);
# This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ...
-$VERSION = do{my @r=(q$Revision: 1.8$=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
+
+$VERSION = do{my @r=(q$Revision: 1.13 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
sub import {
my $pkg = shift;
@@ -94,18 +132,53 @@ sub new {
: $fh;
}
+my @domain2pkg = ();
+
+sub register_domain {
+ my($p,$d) = @_;
+ $domain2pkg[$d] = bless \$d, $p;
+}
+
+sub _domain2pkg {
+ my $domain = shift;
+
+ croak "Unsupported socket domain"
+ unless defined $domain2pkg[$domain];
+
+ $domain2pkg[$domain]
+}
+
sub configure {
- croak 'IO::Socket: Cannot configure a generic socket';
+ my($fh,$arg) = @_;
+ my $domain = delete $arg->{Domain};
+
+ croak 'IO::Socket: Cannot configure a generic socket'
+ unless defined $domain;
+
+ my $sub = ref(_domain2pkg($domain)) . "::configure";
+
+ goto &{$sub}
+ if(defined &{$sub});
+
+ croak "IO::Socket: Cannot configure socket in domain '$domain' $sub";
}
sub socket {
@_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
my($fh,$domain,$type,$protocol) = @_;
+ if(!defined ${*$fh}{'io_socket_domain'}
+ || !ref(${*$fh}{'io_socket_domain'})
+ || ${${*$fh}{'io_socket_domain'}} != $domain) {
+ my $pkg =
+ ${*$fh}{'io_socket_domain'} = _domain2pkg($domain);
+ }
+
socket($fh,$domain,$type,$protocol) or
return undef;
- ${*$fh}{'io_socket_type'} = $type;
+ ${*$fh}{'io_socket_type'} = $type;
+ ${*$fh}{'io_socket_proto'} = $protocol;
$fh;
}
@@ -118,7 +191,8 @@ sub socketpair {
socketpair($fh1,$fh1,$domain,$type,$protocol) or
return ();
- ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type;
+ ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type;
+ ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol;
($fh1,$fh2);
}
@@ -131,7 +205,7 @@ sub connect {
local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
: $SIG{ALRM} || 'DEFAULT';
- eval {
+ eval {
croak 'connect: Bad address'
if(@_ == 2 && !defined $_[1]);
@@ -140,17 +214,17 @@ sub connect {
$timeout = 0;
}
- my $ok = eval { connect($fh, $addr) };
+ my $ok = connect($fh, $addr);
alarm(0)
if($timeout);
- croak "connect: timeout"
- unless defined $fh;
-
- undef $fh unless $ok;
+ croak "connect: timeout"
+ unless defined $fh;
+ undef $fh unless $ok;
};
+
$fh;
}
@@ -219,7 +293,9 @@ sub send {
croak 'send: Cannot determine peer address'
unless($peer);
- my $r = send($fh, $_[1], $flags, $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
@@ -272,11 +348,45 @@ sub timeout {
$r;
}
+sub sockdomain {
+ @_ == 1 or croak 'usage: $fh->sockdomain()';
+ my $fh = shift;
+ ${${*$fh}{'io_socket_domain'}}
+}
+
sub socktype {
- @_ == 1 or croak '$fh->socktype()';
- ${*{$_[0]}}{'io_socket_type'} || undef;
+ @_ == 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'};
+}
+
+sub _addmethod {
+ my $self = shift;
+ my $name;
+
+ foreach $name (@_) {
+ my $n = $name;
+
+ no strict qw(refs);
+
+ *{$n} = sub {
+ my $pkg = ref(${*{$_[0]}}{'io_socket_domain'});
+ my $sub = "${pkg}::${n}";
+ goto &{$sub} if defined &{$sub};
+ croak qq{Can't locate object method "$n" via package "$pkg"};
+ }
+ unless defined &{$n};
+ }
+
}
+
=head1 SUB-CLASSES
=cut
@@ -295,6 +405,9 @@ use Exporter;
@ISA = qw(IO::Socket);
+IO::Socket::INET->_addmethod( qw(sockaddr sockport sockhost peeraddr peerport peerhost));
+IO::Socket::INET->register_domain( AF_INET );
+
my %socket_type = ( tcp => SOCK_STREAM,
udp => SOCK_DGRAM,
);
@@ -313,32 +426,46 @@ and some related methods. The constructor can take the following options
Listen Queue size for listen
Timeout Timeout value for various operations
+
If Listen is defined then a listen socket is created, else if the socket
type, which is derived from the protocol, is SOCK_STREAM then a connect
-is called
+is called.
Only one of C<Type> or C<Proto> needs to be specified, one will be assumed
from the other.
=head2 METHODS
-=item sockaddr()
+=over 4
+
+=item sockaddr ()
Return the address part of the sockaddr structure for the socket
-=item sockport()
+=item sockport ()
Return the port number that the socket is using on the local host
-=item sockhost()
+=item sockhost ()
Return the address part of the sockaddr structure for the socket in a
text form xx.xx.xx.xx
-=item peeraddr(), peerport(), peerhost()
+=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.
-Same as for the sock* functions, but returns the data about the peer
-host instead of the local 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
@@ -379,6 +506,14 @@ sub _sock_info {
);
}
+sub _error {
+ my $fh = shift;
+ carp join("",ref($fh),": ",@_) if @_;
+ close($fh)
+ if(defined fileno($fh));
+ return undef;
+}
+
sub configure {
my($fh,$arg) = @_;
my($lport,$rport,$laddr,$raddr,$proto,$type);
@@ -391,38 +526,50 @@ sub configure {
$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);
}
- croak 'IO::Socket: Cannot determine protocol'
+ if(defined $raddr) {
+ $raddr = inet_aton($raddr);
+ return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'")
+ unless(defined $raddr);
+ }
+
+ return _error($fh,'Cannot determine protocol')
unless($proto);
my $pname = (getprotobynumber($proto))[0];
$type = $arg->{Type} || $socket_type{$pname};
+ my $domain = AF_INET;
+ ${*$fh}{'io_socket_domain'} = bless \$domain;
+
$fh->socket(AF_INET, $type, $proto) or
- return undef;
+ return _error($fh);
$fh->bind($lport || 0, $laddr) or
- return undef;
+ return _error($fh);
if(exists $arg->{Listen}) {
$fh->listen($arg->{Listen} || 5) or
- return undef;
+ return _error($fh);
}
else {
- croak "IO::Socket: Cannot determine remote port"
+ return _error($fh,'Cannot determine remote port')
unless($rport || $type == SOCK_DGRAM);
if($type == SOCK_STREAM || defined $raddr) {
- croak "IO::Socket: Bad peer address"
- unless defined $raddr;
+ return _error($fh,'Bad peer address')
+ unless(defined $raddr);
- $fh->connect($rport,inet_aton($raddr)) or
- return undef;
+ $fh->connect($rport,$raddr) or
+ return _error($fh);
}
}
@@ -479,6 +626,9 @@ use Exporter;
@ISA = qw(IO::Socket);
+IO::Socket::UNIX->_addmethod(qw(hostpath peerpath));
+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
@@ -491,13 +641,17 @@ and some related methods. The constructor can take the following options
=head2 METHODS
+=over 4
+
=item hostpath()
-Returns the pathname to the fifo at the local end
+Returns the pathname to the fifo at the local end.
=item peerpath()
-Returns the pathanme to the fifo at the peer end
+Returns the pathanme to the fifo at the peer end.
+
+=back
=cut
@@ -507,6 +661,9 @@ sub configure {
my $type = $arg->{Type} || SOCK_STREAM;
+ my $domain = AF_UNIX;
+ ${*$fh}{'io_socket_domain'} = bless \$domain;
+
$fh->socket(AF_UNIX, $type, 0) or
return undef;
@@ -530,28 +687,34 @@ sub configure {
sub hostpath {
@_ == 1 or croak 'usage: $fh->hostpath()';
- (sockaddr_un($_[0]->hostname))[0];
+ my $n = $_[0]->sockname || return undef;
+warn length($n);
+ (sockaddr_un($n))[0];
}
sub peerpath {
@_ == 1 or croak 'usage: $fh->peerpath()';
- (sockaddr_un($_[0]->peername))[0];
+ my $n = $_[0]->peername || return undef;
+warn length($n);
+my @n = sockaddr_un($n);
+warn join(",",@n);
+ (sockaddr_un($n))[0];
}
=head1 AUTHOR
-Graham Barr <Graham.Barr@tiuk.ti.com>
+Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
=head1 REVISION
-$Revision: 1.8 $
+$Revision: 1.13 $
The VERSION is derived from the revision turning each number after the
first dot into a 2 digit number so
- Revision 1.8 => VERSION 1.08
- Revision 1.2.3 => VERSION 1.0203
-
+ Revision 1.8 => VERSION 1.08
+ Revision 1.2.3 => VERSION 1.0203
+
=head1 COPYRIGHT
Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
diff --git a/ext/NDBM_File/hints/dynixptx.pl b/ext/NDBM_File/hints/dynixptx.pl
new file mode 100644
index 0000000000..d402c17901
--- /dev/null
+++ b/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/ext/ODBM_File/ODBM_File.xs b/ext/ODBM_File/ODBM_File.xs
index c1b405ff89..92b443ce99 100644
--- a/ext/ODBM_File/ODBM_File.xs
+++ b/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;
diff --git a/ext/ODBM_File/hints/hpux.pl b/ext/ODBM_File/hints/hpux.pl
new file mode 100644
index 0000000000..31f9d24bca
--- /dev/null
+++ b/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/ext/ODBM_File/hints/ultrix.pl b/ext/ODBM_File/hints/ultrix.pl
new file mode 100644
index 0000000000..31f9d24bca
--- /dev/null
+++ b/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/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index c2dd4143ad..1675d469b1 100644
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -53,6 +53,7 @@ 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
@@ -393,8 +394,6 @@ These are a hotchpotch of opcodes still waiting to be considered
bless -- could be used to change ownership of objects (reblessing)
- glob
-
pushre regcmaybe regcomp subst substcont
sprintf prtf -- can core dump
@@ -495,6 +494,8 @@ information about your system but not be able to change it.
wait waitpid
+ glob -- access to Cshell via <`rm *`>
+
=item :ownprocess
exec exit kill
@@ -558,7 +559,7 @@ 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 <Tim.Bunce@ig.co.uk>.
+changes added by Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>.
=cut
diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs
index 928f68020b..1fd2c6b891 100644
--- a/ext/Opcode/Opcode.xs
+++ b/ext/Opcode/Opcode.xs
@@ -46,7 +46,7 @@ op_names_init()
while(i-- > 0)
bitmap[i] = 0xFF;
/* Take care to set the right number of bits in the last byte */
- bitmap[len-1] = ~(~0 << (maxo & 0x07));
+ bitmap[len-1] = (maxo & 0x07) ? ~(~0 << (maxo & 0x07)) : 0xFF;
put_op_bitspec(":all",0, opset_all); /* don't mortalise */
}
@@ -233,7 +233,7 @@ PROTOTYPES: ENABLE
BOOT:
assert(maxo < OP_MASK_BUF_SIZE);
- opset_len = (maxo / 8) + 1;
+ opset_len = (maxo + 7) / 8;
if (opcode_debug >= 1)
warn("opset_len %d\n", opset_len);
op_names_init();
diff --git a/ext/Opcode/Safe.pm b/ext/Opcode/Safe.pm
index f15dbd55e8..22772796e2 100644
--- a/ext/Opcode/Safe.pm
+++ b/ext/Opcode/Safe.pm
@@ -1,14 +1,13 @@
package Safe;
-require 5.002;
-
+use 5.003_11;
use strict;
-use Carp;
-
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
@@ -287,8 +286,8 @@ 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 L<Opcode(3)> module documentation
-for more information. Especially for details definitions of opnames,
+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
@@ -454,7 +453,7 @@ 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 '$baz = 1' then,
+'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.
@@ -549,7 +548,7 @@ 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
-<Tim.Bunce@ig.co.uk>.
+E<lt>F<Tim.Bunce@ig.co.uk>E<gt>.
=cut
diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm
index 66b55c1565..22eed0283b 100644
--- a/ext/POSIX/POSIX.pm
+++ b/ext/POSIX/POSIX.pm
@@ -96,7 +96,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
@@ -628,18 +628,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/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod
index aa7a008836..7dee4a3652 100644
--- a/ext/POSIX/POSIX.pod
+++ b/ext/POSIX/POSIX.pod
@@ -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<perli18n>.
+
+ $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<perli18n> 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
diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs
index 3ba3c5b426..70527cd51d 100644
--- a/ext/POSIX/POSIX.xs
+++ b/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
@@ -190,6 +190,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 +229,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 +257,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")
@@ -2660,6 +2665,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 +2731,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 +3013,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 +3096,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
diff --git a/ext/POSIX/hints/next_3.pl b/ext/POSIX/hints/next_3.pl
new file mode 100644
index 0000000000..d90778398b
--- /dev/null
+++ b/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/ext/SDBM_File/sdbm/pair.c b/ext/SDBM_File/sdbm/pair.c
index a02c73f28f..23bbfe9a67 100644
--- a/ext/SDBM_File/sdbm/pair.c
+++ b/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/ext/SDBM_File/sdbm/pair.h b/ext/SDBM_File/sdbm/pair.h
index bd66d02fd2..8a675b9065 100644
--- a/ext/SDBM_File/sdbm/pair.h
+++ b/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/ext/SDBM_File/sdbm/sdbm.3 b/ext/SDBM_File/sdbm/sdbm.3
index f0f2d07c84..7e5c176404 100644
--- a/ext/SDBM_File/sdbm/sdbm.3
+++ b/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/ext/SDBM_File/sdbm/sdbm.c b/ext/SDBM_File/sdbm/sdbm.c
index d4836be671..a62334c45e 100644
--- a/ext/SDBM_File/sdbm/sdbm.c
+++ b/ext/SDBM_File/sdbm/sdbm.c
@@ -135,7 +135,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)
flags |= O_BINARY;
# endif
if ((db->pagf = open(pagname, flags, mode)) > -1) {
diff --git a/ext/SDBM_File/sdbm/sdbm.h b/ext/SDBM_File/sdbm/sdbm.h
index 4d6c844890..c9b28f5c66 100644
--- a/ext/SDBM_File/sdbm/sdbm.h
+++ b/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
@@ -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 _((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 /* MYMALLOC && (HIDEMYMALLOC || EMBEDMYMALLOC) */
+
#ifdef I_STRING
#include <string.h>
#else
@@ -171,10 +185,6 @@ 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
@@ -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));
# 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 _((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/ext/Socket/Socket.pm b/ext/Socket/Socket.pm
index 43c3c404bc..9872d03526 100644
--- a/ext/Socket/Socket.pm
+++ b/ext/Socket/Socket.pm
@@ -115,10 +115,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
@@ -139,7 +139,6 @@ have AF_UNIX in the right place.
use Carp;
require Exporter;
-use AutoLoader;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
@EXPORT = qw(
@@ -256,14 +255,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 +264,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/ext/util/make_ext b/ext/util/make_ext
index 8c1abbbc01..bfbcc8340e 100644
--- a/ext/util/make_ext
+++ b/ext/util/make_ext
@@ -34,9 +34,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 +50,6 @@ esac
mname=`echo "$pname" | sed -e 's!/!::!g'`
depth=`echo "$pname" | sed -e 's![^/][^/]*!..!g'`
-make=${altmake-make}
makefile=Makefile
makeargs=''
makeopts=''
diff --git a/global.sym b/global.sym
index 3db71f1417..3e9f9de234 100644
--- a/global.sym
+++ b/global.sym
@@ -3,6 +3,7 @@
# Variables
AMG_names
+Error
No
Sv
Xpv
@@ -15,6 +16,7 @@ amagic_generation
an
atan2_amg
band_amg
+block_type
bool__amg
bor_amg
buf
@@ -22,9 +24,14 @@ 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
@@ -36,18 +43,18 @@ cos_amg
cryptseen
cshlen
cshname
-curcop
-curcopdb
curinterp
curpad
+cv_const_sv
dc
+debug
dec_amg
di
div_amg
div_ass_amg
+do_undump
ds
egid
-envgv
eq_amg
error_count
euid
@@ -56,10 +63,8 @@ exp_amg
expect
expectterm
fallback_amg
-filter_add
-filter_del
-filter_read
fold
+fold_locale
freq
ge_amg
gid
@@ -74,22 +79,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
@@ -98,8 +103,8 @@ lt_amg
markstack
markstack_max
markstack_ptr
-maxo
max_intro_pending
+maxo
min_intro_pending
mod_amg
mod_ass_amg
@@ -111,27 +116,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
@@ -143,15 +154,17 @@ opargs
origalen
origenviron
osname
+pad_reset_pending
padix
+padix_floor
patleave
pow_amg
pow_ass_amg
ppaddr
profiledata
provide_ref
-psig_ptr
psig_name
+psig_ptr
qrt_amg
rcsid
reall_srchlen
@@ -161,7 +174,7 @@ regcode
regdummy
regendp
regeol
-regfold
+regflags
reginput
regkind
reglastparen
@@ -188,7 +201,6 @@ rsfp
rsfp_filters
rshift_amg
rshift_ass_amg
-save_pptr
savestack
savestack_ix
savestack_max
@@ -201,10 +213,9 @@ scrgv
seq_amg
sge_amg
sgt_amg
+sh_path
sig_name
sig_num
-siggv
-sighandler
simple
sin_amg
sle_amg
@@ -223,7 +234,6 @@ subtr_ass_amg
sv_no
sv_undef
sv_yes
-tainting
thisexpr
timesbuf
tokenbuf
@@ -234,13 +244,16 @@ vtbl_amagic
vtbl_amagicelem
vtbl_arylen
vtbl_bm
+vtbl_collxfrm
vtbl_dbline
vtbl_env
vtbl_envelem
+vtbl_fm
vtbl_glob
vtbl_isa
vtbl_isaelem
vtbl_mglob
+vtbl_nkeys
vtbl_pack
vtbl_packelem
vtbl_pos
@@ -254,6 +267,7 @@ vtbl_vec
warn_nl
warn_nosemi
warn_reserved
+warn_uninit
watchaddr
watchok
yychar
@@ -277,6 +291,10 @@ yyval
# Functions
Gv_AMupdate
+SvTRUE
+SvIV
+SvUV
+SvNV
amagic_call
append_elem
append_list
@@ -298,20 +316,22 @@ av_unshift
bind_match
block_end
block_start
+boot_core_UNIVERSAL
calllist
cando
cast_ulong
check_uni
checkcomma
ck_aelem
+ck_bitop
ck_concat
ck_delete
ck_eof
ck_eval
ck_exec
-ck_formline
ck_ftst
ck_fun
+ck_fun_locale
ck_glob
ck_grep
ck_gvconst
@@ -326,6 +346,7 @@ ck_require
ck_retarget
ck_rfun
ck_rvconst
+ck_scmp
ck_select
ck_shift
ck_sort
@@ -411,11 +432,13 @@ gv_HVadd
gv_IOadd
gv_check
gv_efullname
+gv_efullname3
gv_fetchfile
gv_fetchmeth
gv_fetchmethod
gv_fetchpv
gv_fullname
+gv_fullname3
gv_init
gv_stashpv
gv_stashpvn
@@ -437,14 +460,17 @@ 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
@@ -461,6 +487,7 @@ magic_clearenv
magic_clearpack
magic_clearsig
magic_existspack
+magic_freevivary
magic_get
magic_getarylen
magic_getglob
@@ -475,11 +502,14 @@ magic_set
magic_setamagic
magic_setarylen
magic_setbm
+magic_setcollxfrm
magic_setdbline
magic_setenv
+magic_setfm
magic_setglob
magic_setisa
magic_setmglob
+magic_setnkeys
magic_setpack
magic_setpos
magic_setsig
@@ -487,9 +517,11 @@ magic_setsubstr
magic_settaint
magic_setuvar
magic_setvec
+magic_setvivary
magic_wipepack
magicname
markstack_grow
+mem_collxfrm
mess
mg_clear
mg_copy
@@ -945,8 +977,21 @@ regnext
regprop
repeatcpy
rninstr
+rsignal
+rsignal_save
+rsignal_state
+rsignal_restore
runops
+safecalloc
+safemalloc
+safefree
+saferealloc
+safexcalloc
+safexmalloc
+safexfree
+safexrealloc
same_dirent
+save_I16
save_I32
save_aptr
save_ary
@@ -956,10 +1001,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
@@ -993,6 +1040,7 @@ scope
screaminstr
setdefout
setenv_getix
+share_hek
sharepvn
sighandler
skipspace
@@ -1007,6 +1055,7 @@ sv_2iv
sv_2mortal
sv_2nv
sv_2pv
+sv_2uv
sv_add_arena
sv_backoff
sv_bless
@@ -1018,7 +1067,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
@@ -1035,6 +1087,7 @@ sv_mortalcopy
sv_newmortal
sv_newref
sv_peek
+sv_pvn
sv_pvn_force
sv_ref
sv_reftype
@@ -1051,16 +1104,20 @@ 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
taint_env
-taint_not
taint_proper
too_few_arguments
too_many_arguments
unlnk
+unshare_hek
unsharepvn
utilize
wait4pid
@@ -1073,6 +1130,7 @@ xnv_root
xpv_root
xrv_root
yyerror
+yydestruct
yylex
yyparse
yywarn
diff --git a/gv.c b/gv.c
index c136fc5ed4..95efca8468 100644
--- a/gv.c
+++ b/gv.c
@@ -241,9 +241,10 @@ char* name;
/* Failed obvious case - look for SUPER as last element of stash's name */
char *packname = HvNAME(stash);
STRLEN len = strlen(packname);
- if ((len -= 7) >= 0 && strEQ(packname+len,"::SUPER")) {
+ if (len >= 7 && strEQ(packname+len-7,"::SUPER")) {
/* Now look for @.*::SUPER::ISA */
GV** gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
+ len -= 7;
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
@@ -275,7 +276,7 @@ char* name;
if (!gv) {
CV* cv;
- if (strEQ(name,"import") || strEQ(name,"unimport"))
+ if (strEQ(name,"import"))
gv = (GV*)&sv_yes;
else if (strNE(name, "AUTOLOAD")) {
gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0);
@@ -284,8 +285,7 @@ char* name;
sv_catpvn(tmpstr,"::", 2);
sv_catpvn(tmpstr, name, nend - name);
sv_setsv(GvSV(CvGV(cv)), tmpstr);
- if (tainting)
- sv_unmagic(GvSV(CvGV(cv)), 't');
+ SvTAINTED_off(GvSV(CvGV(cv)));
}
}
}
@@ -686,38 +686,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 *
@@ -922,7 +934,7 @@ HV* stash;
/* FALL THROUGH */
case SVt_PVHV:
case SVt_PVAV:
- die("Not a subroutine reference in %%OVERLOAD");
+ die("Not a subroutine reference in overload table");
return FALSE;
case SVt_PVCV:
cv = (CV*)sv;
@@ -1218,7 +1230,7 @@ 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;
}
diff --git a/handy.h b/handy.h
index 76d9a4f694..056bf2c8a1 100644
--- a/handy.h
+++ b/handy.h
@@ -20,7 +20,7 @@
#define Null(type) ((type)NULL)
#define Nullch Null(char*)
-#define Nullfp Null(FILE*)
+#define Nullfp Null(PerlIO*)
#define Nullsv Null(SV*)
#ifdef TRUE
@@ -32,6 +32,11 @@
#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
@@ -67,21 +72,48 @@
# endif
#endif
+/* XXX A note on the perl source internal type system. The
+ original intent was that I32 be *exactly* 32 bits.
+
+ Currently, we only guarantee that I32 is *at least* 32 bits.
+ Specifically, if int is 64 bits, then so is I32. (This is the case
+ for the Cray.) This has the advantage of meshing nicely with
+ standard library calls (where we pass an I32 and the library is
+ expecting an int), but the disadvantage that an I32 is not 32 bits.
+ Andy Dougherty August 1996
+*/
+
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 Ctl(ch) ((ch) & 037)
#define strNE(s1,s2) (strcmp(s1,s2))
#define strEQ(s1,s2) (!strcmp(s1,s2))
@@ -92,46 +124,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
@@ -140,64 +223,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 *));
-char *safecalloc _((MEM_SIZE, MEM_SIZE));
-#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();
-char *safexcalloc();
-#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 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 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))
+
+#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/hints/README.NeXT b/hints/README.NeXT
new file mode 100644
index 0000000000..3e1a461913
--- /dev/null
+++ b/hints/README.NeXT
@@ -0,0 +1,56 @@
+OPENSTEP
+--------
+
+Support for OPENSTEP was added. Perl will build with as shared library. To build and install it, use this sequence:
+
+cd <wherever your perl source is>
+sh Configure -des
+DYLD_LIBRARY_PATH=`pwd`; export DYLD_LIBRARY_PATH
+make
+make test
+make install
+
+
+Depending on your shell, you might have to use
+
+ setenv DYLD_LIBRARY_PATH `pwd`
+
+instead of
+
+ DYLD_LIBRARY_PATH=`pwd`; export DYLD_LIBRARY_PATH
+
+Note:
+During compilation/linking there are going to be some warnings, they do not seem to have any ill effects.
+
+Perl is going to be installed below the path /usr/local/OPENSTEP. This is done so that binaries for NEXTSTEP (3.2, 3.3 etc) will not be overwritten, since the OPENSTEP binaries will not work on those systems. Below is a part of my .zshrc file, that makes sure that the new OPENSTEP binaries are used on OPENSTEP:
+
+##############################
+if(fgrep -s 'OPENSTEP 4.' /usr/lib/NextStep/software_version )
+then
+path=(. /etc /usr/etc ~/Unix/bin /usr/local/OPENSTEP/bin /usr/local/bin /usr/local/netpbm/bin /usr/ucb /bin /usr/bin /usr/sybase/bin ~/Apps /LocalApps /NextApps /NextAdmin /NextDeveloper/Demos)
+else
+path=(. /etc /usr/etc ~/Unix/bin /usr/local/bin /usr/local/netpbm/bin /usr/ucb /bin /usr/bin /usr/sybase/bin ~/Apps /LocalApps /NextApps /NextAdmin /NextDeveloper/Demos)
+fi
+##############################
+
+You can change the installation path by changing 'prefix' in hints/next_4.sh before you run Configure.
+
+
+
+NEXTSTEP
+--------
+
+The hints file for NEXTSTEP (hints/next_3.sh) was changed:
+
+- Support for MAB was added
+- perl's malloc is used now; this should take care of some problems with NEXTSTEP 3.2
+
+perl should build and install fine with this sequence:
+
+cd <wherever your perl source is>
+sh Configure -des
+make
+make test
+make install
+
+
diff --git a/hints/README.hints b/hints/README.hints
index 6c67585561..2c27068e38 100644
--- a/hints/README.hints
+++ b/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/hints/aix.sh b/hints/aix.sh
index a9f277eed1..6377336089 100644
--- a/hints/aix.sh
+++ b/hints/aix.sh
@@ -32,7 +32,11 @@ case "$osvers" in
*) # 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
diff --git a/hints/amigaos.sh b/hints/amigaos.sh
new file mode 100644
index 0000000000..8328c8a3d3
--- /dev/null
+++ b/hints/amigaos.sh
@@ -0,0 +1,43 @@
+# 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'
+ccflags='-DAMIGAOS -mstackextend'
+optimize='-O2 -fomit-frame-pointer'
+
+cppminus=' '
+cpprun='cpp'
+cppstdin='cpp'
+
+usenm='y'
+usemymalloc='n'
+usevfork='true'
+useperlio='true'
+d_eofnblk='define'
+d_fork='undef'
+d_vfork='define'
+groupstype='int'
+
+# libs
+
+libpth="/local/lib $prefix/lib"
+glibpth="$libpth"
+xlibpth="$libpth"
+
+libswanted='dld m c gdbm'
+so=' '
+
+# dynamic loading
+
+dlext='o'
+cccdlflags='none'
+ccdlflags='none'
+lddlflags='-oformat a.out-amiga -r'
+
+# 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"'
diff --git a/hints/convexos.sh b/hints/convexos.sh
index 5d6eafbf0b..9f6d702b06 100644
--- a/hints/convexos.sh
+++ b/hints/convexos.sh
@@ -10,12 +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
-#
-if [ "$osvers" -ge 10.2 ]
-then
- d_getpgrp='undef' ;;
-fi
diff --git a/hints/dgux.sh b/hints/dgux.sh
index bc54c945bd..0b9dd11766 100644
--- a/hints/dgux.sh
+++ b/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),
@@ -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
+
+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/hints/dnix.sh b/hints/dnix.sh
deleted file mode 100644
index 5b67dab8f2..0000000000
--- a/hints/dnix.sh
+++ /dev/null
@@ -1 +0,0 @@
-optimize='-g'
diff --git a/hints/dynixptx.sh b/hints/dynixptx.sh
index d44f6b82cd..55824f6013 100644
--- a/hints/dynixptx.sh
+++ b/hints/dynixptx.sh
@@ -8,32 +8,10 @@ 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
diff --git a/hints/epix.sh b/hints/epix.sh
index 25e357328f..b91537a202 100644
--- a/hints/epix.sh
+++ b/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/hints/freebsd.sh b/hints/freebsd.sh
index 1e92053cf5..f1ab871831 100644
--- a/hints/freebsd.sh
+++ b/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,48 @@ 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'
+ d_dosuid='define'
+ d_setregid='define'
+ d_setreuid='define'
+ d_setegid='undef'
+ d_seteuid='undef'
+ cat <<EOF
+
+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
+ ;;
+#
+# 2.2 and above have phkmalloc(3).
+2.2*)
+ usevfork='true'
+ usemymalloc='n'
+ d_dosuid='define'
+ 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'
;;
esac
diff --git a/hints/hpux.sh b/hints/hpux.sh
index 8eaf272d70..3ac43ffc5b 100644
--- a/hints/hpux.sh
+++ b/hints/hpux.sh
@@ -1,14 +1,14 @@
# hints/hpux.sh
-# Perl Configure hints file for Hewlett Packard HP/UX 9.x and 10.x
+# 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
+# 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
# 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
+
+# This version: December 4, 1996
# Use Configure -Dcc=gcc to use gcc.
# Use Configure -Dprefix=/usr/local to install in /usr/local.
@@ -18,7 +18,10 @@
# Turn on the _HPUX_SOURCE flag to get many of the HP add-ons
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
@@ -48,7 +51,8 @@ xxuname=`uname -r`
if echo $xxuname | $contains '10'
then
# This system is running 10.0
- xxcontext=`grep $(printf %#x $(getconf CPU_VERSION)) /usr/include/sys/unistd.h`
+ xxcpu=`printf %#x \`getconf CPU_VERSION\``
+ xxcontext=`grep "$xxcpu" /usr/include/sys/unistd.h`
if echo "$xxcontext" | $contains 'PA-RISC1.1'
then
archname='PA-RISC1.1'
@@ -107,12 +111,6 @@ usemymalloc='y'
alignbytes=8
selecttype='int *'
-# 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'
-
# If your compile complains about FLT_MIN, uncomment the next line
# POSIX_cflags='ccflags="$ccflags -DFLT_MIN=1.17549435E-38"'
@@ -121,3 +119,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/hints/irix_6_2.sh b/hints/irix_6_2.sh
index e3488cc984..11fd52eb7e 100644
--- a/hints/irix_6_2.sh
+++ b/hints/irix_6_2.sh
@@ -1,17 +1,54 @@
-# irix_6_2.sh
+# hints/irix_6_2.sh
+#
# original from Krishna Sethuraman, krishna@sgi.com
-# Configure has been made smarter, so this is shorter than it once was.
+#
+# Updated 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.
-ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -Olimit 3000"
+# Use sh Configure -Dcc='cc -n32' to try compiling with -n32.
+
+case "$cc" in
+*"cc -n32"*)
+ ld=ld
+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -woff 1009,1110,1184 -OPT:fprop_limit=1500"
+ optimize='none' # Miniperl core dumps with -O
+ pp_sys_cflags='ccflags="$ccflags -DHAS_TELLDIR_PROTOTYPE"'
+ lddlflags="-n32 -shared"
+ ldflags=' -L/usr/local/lib -L/usr/lib32 -L/lib32'
+ libc='/usr/lib32/libc.so'
+ plibpth='/usr/lib32 /lib32 /usr/ccs/lib'
+
+ nm_opt='-p'
+ nm_so_opt='-p'
+ cccdlflags=' '
+ ;;
+*)
+ ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -Olimit 3000"
+ ;;
+esac
# 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)
+#
+# 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.
+#
set `echo X "$libswanted "|sed -e 's/ sun / /' -e 's/ crypt / /' -e 's/ bsd / /' -e 's/ PW / /'`
shift
libswanted="$*"
+
diff --git a/hints/linux.sh b/hints/linux.sh
index b76ee89e51..86b0241c99 100644
--- a/hints/linux.sh
+++ b/hints/linux.sh
@@ -15,6 +15,10 @@
# 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'
+d_dosuid='define'
+
# 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.
@@ -148,16 +152,4 @@ 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.
-#
-# The next version of Configure will check for this automatically.
-d_Gconvert='sprintf((b),"%.*g",(n),(x))'
diff --git a/hints/lynxos.sh b/hints/lynxos.sh
new file mode 100644
index 0000000000..5f8991bc45
--- /dev/null
+++ b/hints/lynxos.sh
@@ -0,0 +1,12 @@
+#
+# LynxOS hints
+#
+# These hints were submitted by:
+# Greg Seibert
+# seibert@Lynx.COM
+#
+
+cc='gcc'
+ccflags='-D_filbuf=_fillbuf'
+so='none'
+usemymalloc='n'
diff --git a/hints/machten.sh b/hints/machten.sh
index c86707c182..f6f75d6616 100644
--- a/hints/machten.sh
+++ b/hints/machten.sh
@@ -13,8 +13,9 @@
# 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
+# 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!
#
@@ -22,11 +23,20 @@
# know how to use it yet.
#
# Updated by Dominic Dunlop <domo@tcp.ip.lu>
-# Tue May 28 11:20:08 WET DST 1996
+# Wed Nov 13 11:47:09 WET 1996
+
+
+# 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'
# Configure doesn't know how to parse the nm output.
usenm=undef
+# 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.
diff --git a/hints/machten_2.sh b/hints/machten_2.sh
index e9fe41df13..aae73f592d 100644
--- a/hints/machten_2.sh
+++ b/hints/machten_2.sh
@@ -3,13 +3,18 @@
# 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
# I don't know why this is needed. It might be similar to NeXT's
# problem. See hints/next_3.sh.
diff --git a/hints/mips.sh b/hints/mips.sh
index 39cadb4b66..7ed058e4ad 100644
--- a/hints/mips.sh
+++ b/hints/mips.sh
@@ -2,7 +2,7 @@ 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
diff --git a/hints/mpeix.sh b/hints/mpeix.sh
index 9fc2737893..e952f0e002 100644
--- a/hints/mpeix.sh
+++ b/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/hints/next_3.sh b/hints/next_3.sh
index e9f616a3f3..d667ca2868 100644
--- a/hints/next_3.sh
+++ b/hints/next_3.sh
@@ -1,12 +1,12 @@
-# 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.
+#
-ccflags='-DUSE_NEXT_CTYPE'
-POSIX_cflags='ccflags="-posix $ccflags"'
+ccflags='-DUSE_NEXT_CTYPE -DUSE_PERL_SBRK -DHIDEMYMALLOC'
ldflags='-u libsys_s'
libswanted='dbm gdbm db'
@@ -15,7 +15,17 @@ lddlflags='-nostdlib -r'
# using GNU cc and try to specify -fpic for cccdlflags.
cccdlflags=' '
-mab='-arch m68k -arch i386 -arch hppa -arch sparc'
+#
+# Change the line below if you do not want to build 'quad-fat'
+# binaries
+#
+archs=`/bin/lipo -info /usr/lib/libm.a | sed 's/^[^:]*:[^:]*: //'`
+for d in $archs
+do
+ mab="$mab -arch $d"
+done
+
+
archname='next-fat'
ld='cc'
@@ -23,21 +33,56 @@ i_utime='undef'
groupstype='int'
direntrytype='struct direct'
d_strcoll='undef'
+
+######################################################################
+# 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()
-usemymalloc='n'
+#
+# setting usemymalloc='n' was the solution back then. Later came
+# reports that perl would run unstable on 3.2:
+#
+# 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!!
+# andreas koenig, 1996-06-16
+#
+# So, this hintsfile is using perl's malloc. If you want to turn perl's
+# malloc off, you need to change remove '-DUSE_PERL_SBRK' and
+# '-DHIDEMYMALLOC' from the ccflags above and set usemymalloc below
+# to 'n'.
+#
+######################################################################
+usemymalloc='y'
+
d_uname='define'
-d_setpgid='define'
+# 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.
-pp_cflags='optimize="-g"'
+# 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/hints/next_3_2.sh b/hints/next_3_2.sh
deleted file mode 100644
index 37bbf1694b..0000000000
--- a/hints/next_3_2.sh
+++ /dev/null
@@ -1,64 +0,0 @@
-# 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!
-#
-# These hints are intended for NeXT 3.2.
-
-# 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!!
-# andreas koenig, 1996-06-16
-
-ccflags='-DUSE_NEXT_CTYPE -DUSE_PERL_SBRK -DHIDEMYMALLOC'
-POSIX_cflags='ccflags="-posix $ccflags"'
-ldflags='-u libsys_s'
-libswanted='dbm gdbm db'
-
-lddlflags='-r'
-# Give cccdlflags an empty value since Configure will detect we are
-# using GNU cc and try to specify -fpic for cccdlflags.
-cccdlflags=' '
-
-i_utime='undef'
-groupstype='int'
-direntrytype='struct direct'
-d_strcoll='undef'
-
-# the simple program `for ($i=1;$i<38771;$i++){$t{$i}=123}' fails
-# with Larry's malloc on NS 3.2 due to broken sbrk()
-######################################################################
-# above comment should stay here, but is not longer of importance #
-# with -DUSE_PERL_SBRK and -DHIDEMYMALLOC we can now say 'yes' to #
-# usemymalloc. We call this hintsfile next_3_2.sh, so folks with 3.3 #
-# can decide what they prefer. Actually folks with 3.3 "user" version#
-# will also need this hintsfile, but how can I discern which 3.3 it #
-# is? #
-######################################################################
-usemymalloc='y'
-
-d_uname='define'
-d_setpgid='define'
-d_setsid='define'
-d_tcgetpgrp='define'
-d_tcsetpgrp='define'
-
-#
-# On some NeXT machines, the timestamp put by ranlib is not correct, and
-# this may cause useless recompiles. Fix that by adding a sleep before
-# running ranlib. The '5' is an empirical number that's "long enough."
-#
-ranlib='sleep 5; /bin/ranlib'
-
-
-#
-# There where reports that the compiler on HPPA machines
-# fails with the -O flag on pp.c.
-#
-if [ `arch` = "hppa" ]; then
-pp_cflags='optimize="-g"'
-fi
diff --git a/hints/next_3_3.sh b/hints/next_3_3.sh
deleted file mode 100644
index e5dc1fd308..0000000000
--- a/hints/next_3_3.sh
+++ /dev/null
@@ -1,69 +0,0 @@
-# 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!
-#
-
-# These hints are intended for NeXT 3.3. If you're running the 3.3
-# "user" version of the NeXT OS, you should not change the malloc
-# related hints (USE_PERL_SBRK, HIDEMYMALLOC, usemymalloc). If you're
-# running the 3.3 "dev" version of the OS, I do not know what to
-# recommend (I have no 3.3 dev).
-
-# 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!!
-# andreas koenig, 1996-06-16
-
-ccflags='-DUSE_NEXT_CTYPE -DUSE_PERL_SBRK -DHIDEMYMALLOC'
-POSIX_cflags='ccflags="-posix $ccflags"'
-ldflags='-u libsys_s'
-libswanted='dbm gdbm db'
-
-lddlflags='-r'
-# Give cccdlflags an empty value since Configure will detect we are
-# using GNU cc and try to specify -fpic for cccdlflags.
-cccdlflags=' '
-
-i_utime='undef'
-groupstype='int'
-direntrytype='struct direct'
-d_strcoll='undef'
-
-# the simple program `for ($i=1;$i<38771;$i++){$t{$i}=123}' fails
-# with Larry's malloc on NS 3.2 due to broken sbrk()
-######################################################################
-# above comment should stay here, but is not longer of importance #
-# with -DUSE_PERL_SBRK and -DHIDEMYMALLOC we can now say 'yes' to #
-# usemymalloc. We call this hintsfile next_3_2.sh, so folks with 3.3 #
-# can decide what they prefer. Actually folks with 3.3 "user" version#
-# will also need this hintsfile, but how can I discern which 3.3 it #
-# is? #
-######################################################################
-usemymalloc='y'
-
-d_uname='define'
-d_setpgid='define'
-d_setsid='define'
-d_tcgetpgrp='define'
-d_tcsetpgrp='define'
-
-#
-# On some NeXT machines, the timestamp put by ranlib is not correct, and
-# this may cause useless recompiles. Fix that by adding a sleep before
-# running ranlib. The '5' is an empirical number that's "long enough."
-#
-ranlib='sleep 5; /bin/ranlib'
-
-
-#
-# There where reports that the compiler on HPPA machines
-# fails with the -O flag on pp.c.
-#
-if [ `arch` = "hppa" ]; then
-pp_cflags='optimize="-g"'
-fi
diff --git a/hints/next_4.sh b/hints/next_4.sh
index 0e6b7e0271..bd6a38734c 100644
--- a/hints/next_4.sh
+++ b/hints/next_4.sh
@@ -1,4 +1,4 @@
-# Posix support has been removed from NextStep, expect test/POSIX to fail
+######################################################################
#
# IMPORTANT: before you run 'make', you need to enter one of these two
# lines (depending on your shell):
@@ -6,27 +6,51 @@
# or
# setenv DYLD_LIBRARY_PATH `pwd`
#
+######################################################################
+
+# Posix support has been removed from NextStep
+#
useposix='undef'
-altmake='gnumake'
libpth='/lib /usr/lib'
libswanted=' '
libc='/NextLibrary/Frameworks/System.framework/System'
-isnext_4='define'
-mab='-arch m68k -arch i386 -arch sparc'
ldflags='-dynamic -prebind'
lddlflags='-dynamic -bundle -undefined suppress'
-ccflags='-dynamic -fno-common -DUSE_NEXT_CTYPE'
+ccflags='-dynamic -fno-common -DUSE_NEXT_CTYPE -DUSE_PERL_SBRK -DHIDEMYMALLOC'
cccdlflags='none'
ld='cc'
-optimize='-g -O'
+#optimize='-g -O'
-d_shrplib='define'
+#
+# Change the lines below if you do not want to build 'quad-fat'
+# binaries
+#
+archs=`/bin/lipo -info /usr/lib/libm.a | sed 's/^[^:]*:[^:]*: //'`
+for d in $archs
+do
+ mab="$mab -arch $d"
+done
+
+ccflags="$ccflags $mab"
+ccdlflags="$mab"
+# Can we also set ld='libtool -xxx' ?
+
+useshprlib='true'
dlext='bundle'
so='dylib'
-prefix='/usr/local/OPENSTEP'
+#
+# 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.
+# Allow a Configure -Dprefix=/foo/bar override.
+#
+case "$prefix" in
+'') prefix='/usr/local/OPENSTEP' ;;
+esac
+
#archlib='/usr/lib/perl5'
#archlibexp='/usr/lib/perl5'
archname='OPENSTEP-Mach'
@@ -37,9 +61,33 @@ i_utime='undef'
groupstype='int'
direntrytype='struct direct'
+######################################################################
+# 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()
-usemymalloc='n'
+#
+# setting usemymalloc='n' was the solution back then. Later came
+# reports that perl would run unstable on 3.2:
+#
+# 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!!
+# andreas koenig, 1996-06-16
+#
+# So, this hintsfile is using perl's malloc. If you want to turn perl's
+# malloc off, you need to change remove '-DUSE_PERL_SBRK' and
+# '-DHIDEMYMALLOC' from the ccflags above and set usemymalloc below
+# to 'n'.
+#
+######################################################################
+usemymalloc='y'
clocktype='int'
#
diff --git a/hints/os2.sh b/hints/os2.sh
index 1652cb7b2e..59087e3888 100644
--- a/hints/os2.sh
+++ b/hints/os2.sh
@@ -14,10 +14,17 @@
# Note that during the .obj compile you need to move the perl.dll file
# to LIBPATH :-(
-bin_sh=`../UU/loc sh.exe /bin c:/bin d:/bin e:/bin f:/bin g:/bin h:/bin /bin`
-echo "####### Shell found at $bin_sh #############" >&4
+# Optimization (GNU make 3.74 cannot be loaded :-():
+emxload -m 30 sh.exe ls.exe tr.exe id.exe sed.exe # make.exe
+emxload -m 30 grep.exe egrep.exe fgrep.exe cat.exe rm.exe mv.exe cp.exe
+emxload -m 30 uniq.exe basename.exe sort.exe awk.exe echo.exe
+
+path_sep=\;
+
+if test -f $sh.exe; then sh=$sh.exe; fi
+
+startsh="#!$sh"
-#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`
cc='gcc'
usrinc='/emx/include'
@@ -25,7 +32,10 @@ libemx="`../UU/loc . X c:/emx/lib d:/emx/lib e:/emx/lib f:/emx/lib g:/emx/lib h:
if test "$libemx" = "X"; then echo "Cannot find C library!"; fi
-libpth="$libemx/st $libemx"
+libpth="$libemx/mt $libemx"
+
+set `emxrev -f emxlibcm`
+emxcrtrev=$5
so='dll'
@@ -38,29 +48,41 @@ exe_ext='.exe'
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_d_fork='define'
aout_lddlflags='-Zdll'
-aout_ldflags='-Zexe'
-aout_ccflags='-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS'
-aout_cppflags='-DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. -DPACK_MALLOC =DDEBUGGING_MSTATS'
+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 -DDEBUGGING_MSTATS -DTWO_POT_OPTIMIZE -DPERL_EMERGENCY_SBRK'
+aout_cppflags='-DPERL_CORE -DDOSISH -DPERL_IS_AOUT -DOS2=2 -DEMBED -I. -DPACK_MALLOC -DDEBUGGING_MSTATS -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 plibext lib_ext obj_ext ar plibext d_fork lddlflags ldflags ccflags use_clib usedl archobjs cppflags'
+used_aout='d_shrplib useshrplib plibext lib_ext obj_ext ar plibext d_fork lddlflags ldflags ccflags use_clib usedl archobjs cppflags'
if [ "$emxaout" != "" ]; then
d_shrplib="$aout_d_shrplib"
+ useshrplib="$aout_useshrplib"
obj_ext="$aout_obj_ext"
lib_ext="$aout_lib_ext"
ar="$aout_ar"
plibext="$aout_plibext"
- d_fork="$aout_d_fork"
+ if [ $emxcrtrev -lt 50 ]; then
+ d_fork="$aout_d_fork"
+ fi
lddlflags="$aout_lddlflags"
ldflags="$aout_ldflags"
ccflags="$aout_ccflags"
@@ -69,15 +91,24 @@ if [ "$emxaout" != "" ]; then
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 -DDEBUGGING_MSTATS'
+ 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
@@ -85,9 +116,11 @@ 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"
@@ -99,10 +132,7 @@ fi
libs='-lsocket -lm'
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'
@@ -142,6 +172,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'
@@ -162,3 +193,39 @@ d_setprior='define'
# 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/hints/qnx.sh b/hints/qnx.sh
new file mode 100644
index 0000000000..e0ce55c249
--- /dev/null
+++ b/hints/qnx.sh
@@ -0,0 +1,176 @@
+#----------------------------------------------------------------
+# QNX hints
+#
+# As of perl5.003_09, perl5 will compile without errors
+# and pass almost all the tests in the test suite. The remaining
+# failures have been identified as bugs in the Watcom libraries
+# which I hope will be fixed in the near future.
+#
+# 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.
+# Watcom promises to fix this in next release.
+# 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 getpwd().
+# There is currently no support for dynamically linked
+# libraries.
+#----------------------------------------------------------------
+# 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.
+#----------------------------------------------------------------
+
+#----------------------------------------------------------------
+# 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=''
+
+#----------------------------------------------------------------
+# 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'
+
+#----------------------------------------------------------------
+# The following exist in the libraries, but there are no
+# prototypes available:
+#----------------------------------------------------------------
+d_setregid='undef'
+d_setreuid='undef'
+d_setlinebuf='undef'
+d_truncate='undef'
+d_getpgid='undef'
+
+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"
+
+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'
+ 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
+ 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
+ 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
+
+ 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/hints/sco.sh b/hints/sco.sh
index 4cd15e4590..72c3d1c75c 100644
--- a/hints/sco.sh
+++ b/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,13 +50,37 @@ 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
+ 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" ;;
@@ -88,3 +132,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/hints/solaris_2.sh b/hints/solaris_2.sh
index 4e12dbb8cb..d563e53d7b 100644
--- a/hints/solaris_2.sh
+++ b/hints/solaris_2.sh
@@ -35,17 +35,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.
@@ -193,17 +182,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*)
+ *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
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/hints/sunos_4_0.sh b/hints/sunos_4_0.sh
index 99fce3f44b..56a87bf5be 100644
--- a/hints/sunos_4_0.sh
+++ b/hints/sunos_4_0.sh
@@ -1 +1,2 @@
ccflags="$ccflags -DFPUTS_BOTCH"
+i_unistd=$undef
diff --git a/hints/sunos_4_1.sh b/hints/sunos_4_1.sh
index ee42e2c448..16ea47aa0c 100644
--- a/hints/sunos_4_1.sh
+++ b/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,6 +15,26 @@ 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.
+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"'
@@ -24,4 +46,12 @@ then # bsd
else # sys5
groupstype='gid_t'
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/hints/svr4.sh b/hints/svr4.sh
index 5569274753..c91e13e052 100644
--- a/hints/svr4.sh
+++ b/hints/svr4.sh
@@ -32,6 +32,15 @@ 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
+uw_ver=`uname -v`
+uw_isuw=`uname -X 2>&1 | grep Release`
+if [ "$uw_isuw" = "Release = 4.2MP" -a \
+ \( "$uw_ver" = "2.1" -o "$uw_ver" = "2.1.1" \) ]; then
+ d_csh='undef'
+fi
+
cat <<'EOM' >&4
If you wish to use dynamic linking, you must use
diff --git a/hints/titanos.sh b/hints/titanos.sh
index 0f382ac0ff..5147af09fd 100644
--- a/hints/titanos.sh
+++ b/hints/titanos.sh
@@ -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/hints/ultrix_4.sh b/hints/ultrix_4.sh
index e00450792d..76b0768f8d 100644
--- a/hints/ultrix_4.sh
+++ b/hints/ultrix_4.sh
@@ -4,9 +4,9 @@
#
# 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 ;;
+'') optimize='none' ;;
esac
# Some users have reported Configure runs *much* faster if you
diff --git a/hints/umips.sh b/hints/umips.sh
new file mode 100644
index 0000000000..17d5ff4623
--- /dev/null
+++ b/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/hv.c b/hv.c
index a2ddf7b61b..ecbd548bcb 100644
--- a/hv.c
+++ b/hv.c
@@ -55,6 +55,31 @@ more_he()
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* */
@@ -102,7 +127,7 @@ I32 lval;
continue;
if (HeKLEN(entry) != klen)
continue;
- if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
return &HeVAL(entry);
}
@@ -142,28 +167,24 @@ register U32 hash;
if (!hv)
return 0;
- xhv = (XPVHV*)SvANY(hv);
-
if (SvRMAGICAL(hv) && mg_find((SV*)hv,'P')) {
- if (!(entry = xhv->xhv_eiter)) {
- xhv->xhv_eiter = entry = new_he(); /* only one HE per MAGICAL hash */
- Zero(entry, 1, HE);
- HeKLEN(entry) = HEf_SVKEY; /* hent_key is holding an SV* */
- }
- else if ((sv = HeSVKEY(entry)))
- SvREFCNT_dec(sv);
+ static HE mh;
+
sv = sv_newmortal();
+ keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
- HeVAL(entry) = sv;
- HeKEY(entry) = (char*)SvREFCNT_inc(keysv);
- return entry;
+ if (!HeKEY_hek(&mh)) {
+ char *k;
+ New(54, k, HEK_BASESIZE + sizeof(SV*), char);
+ HeKEY_hek(&mh) = (HEK*)k;
+ HeKLEN(&mh) = HEf_SVKEY; /* key will always hold an SV* */
+ }
+ HeSVKEY_set(&mh, keysv);
+ HeVAL(&mh) = sv;
+ return &mh;
}
- key = SvPV(keysv, klen);
-
- if (!hash)
- PERL_HASH(hash, key, klen);
-
+ 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 */
@@ -175,13 +196,18 @@ register U32 hash;
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 (bcmp(HeKEY(entry),key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
return entry;
}
@@ -222,14 +248,14 @@ 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);
@@ -245,7 +271,7 @@ register U32 hash;
continue;
if (HeKLEN(entry) != klen)
continue;
- if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = val;
@@ -253,13 +279,11 @@ register U32 hash;
}
entry = new_he();
- HeKLEN(entry) = klen;
if (HvSHAREKEYS(hv))
- HeKEY(entry) = sharepvn(key, klen, hash);
+ HeKEY_hek(entry) = share_hek(key, klen, hash);
else /* gotta do the real thing */
- HeKEY(entry) = savepvn(key,klen);
+ HeKEY_hek(entry) = save_hek(key, klen, hash);
HeVAL(entry) = val;
- HeHASH(entry) = hash;
HeNEXT(entry) = *oentry;
*oentry = entry;
@@ -292,15 +316,16 @@ register U32 hash;
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(hv)) {
+ keysv = sv_2mortal(newSVsv(keysv));
mg_copy((SV*)hv, val, (char*)keysv, HEf_SVKEY);
-#ifndef OVERLOAD
- if (!xhv->xhv_array)
- return Nullhe;
-#else
- if (!xhv->xhv_array && (SvMAGIC(hv)->mg_type != 'A'
- || SvMAGIC(hv)->mg_moremagic))
- return Nullhe;
+ 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);
@@ -319,7 +344,7 @@ register U32 hash;
continue;
if (HeKLEN(entry) != klen)
continue;
- if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
SvREFCNT_dec(HeVAL(entry));
HeVAL(entry) = val;
@@ -327,13 +352,11 @@ register U32 hash;
}
entry = new_he();
- HeKLEN(entry) = klen;
if (HvSHAREKEYS(hv))
- HeKEY(entry) = sharepvn(key, klen, hash);
+ HeKEY_hek(entry) = share_hek(key, klen, hash);
else /* gotta do the real thing */
- HeKEY(entry) = savepvn(key,klen);
+ HeKEY_hek(entry) = save_hek(key, klen, hash);
HeVAL(entry) = val;
- HeHASH(entry) = hash;
HeNEXT(entry) = *oentry;
*oentry = entry;
@@ -388,7 +411,7 @@ I32 flags;
continue;
if (HeKLEN(entry) != klen)
continue;
- if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
*oentry = HeNEXT(entry);
if (i && !*oentry)
@@ -398,7 +421,7 @@ I32 flags;
else
sv = sv_mortalcopy(HeVAL(entry));
if (entry == xhv->xhv_eiter)
- HeKLEN(entry) = HEf_LAZYDEL;
+ HvLAZYDEL_on(hv);
else
he_free(entry, HvSHAREKEYS(hv));
--xhv->xhv_keys;
@@ -450,7 +473,7 @@ U32 hash;
continue;
if (HeKLEN(entry) != klen)
continue;
- if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
*oentry = HeNEXT(entry);
if (i && !*oentry)
@@ -460,7 +483,7 @@ U32 hash;
else
sv = sv_mortalcopy(HeVAL(entry));
if (entry == xhv->xhv_eiter)
- HeKLEN(entry) = HEf_LAZYDEL;
+ HvLAZYDEL_on(hv);
else
he_free(entry, HvSHAREKEYS(hv));
--xhv->xhv_keys;
@@ -504,7 +527,7 @@ U32 klen;
continue;
if (HeKLEN(entry) != klen)
continue;
- if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
return TRUE;
}
@@ -530,6 +553,7 @@ U32 hash;
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);
@@ -550,7 +574,7 @@ U32 hash;
continue;
if (HeKLEN(entry) != klen)
continue;
- if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
+ if (memNE(HeKEY(entry),key,klen)) /* is this it? */
continue;
return TRUE;
}
@@ -622,6 +646,84 @@ HV *hv;
}
}
+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--;
+ }
+}
+
HV *
newHV()
{
@@ -651,12 +753,13 @@ I32 shared;
if (!hent)
return;
SvREFCNT_dec(HeVAL(hent));
- if (HeKLEN(hent) == HEf_SVKEY)
- SvREFCNT_dec((SV*)HeKEY(hent));
- else if (shared)
- unsharepvn(HeKEY(hent), HeKLEN(hent), HeHASH(hent));
+ if (HeKLEN(hent) == HEf_SVKEY) {
+ SvREFCNT_dec(HeKEY_sv(hent));
+ Safefree(HeKEY_hek(hent));
+ } else if (shared)
+ unshare_hek(HeKEY_hek(hent));
else
- Safefree(HeKEY(hent));
+ Safefree(HeKEY_hek(hent));
del_he(hent);
}
@@ -668,12 +771,13 @@ I32 shared;
if (!hent)
return;
sv_2mortal(HeVAL(hent)); /* free between statements */
- if (HeKLEN(hent) == HEf_SVKEY)
- sv_2mortal((SV*)HeKEY(hent));
- else if (shared)
- unsharepvn(HeKEY(hent), HeKLEN(hent), HeHASH(hent));
+ if (HeKLEN(hent) == HEf_SVKEY) {
+ sv_2mortal(HeKEY_sv(hent));
+ Safefree(HeKEY_hek(hent));
+ } else if (shared)
+ unshare_hek(HeKEY_hek(hent));
else
- Safefree(HeKEY(hent));
+ Safefree(HeKEY_hek(hent));
del_he(hent);
}
@@ -760,8 +864,13 @@ HV *hv;
{
register XPVHV* xhv = (XPVHV*)SvANY(hv);
HE *entry = xhv->xhv_eiter;
- if (entry && HeKLEN(entry) == HEf_LAZYDEL) /* was deleted earlier? */
+#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);
he_free(entry, HvSHAREKEYS(hv));
+ }
xhv->xhv_riter = -1;
xhv->xhv_eiter = Null(HE*);
return xhv->xhv_fill;
@@ -783,21 +892,30 @@ HV *hv;
if (SvRMAGICAL(hv) && (mg = mg_find((SV*)hv,'P'))) {
SV *key = sv_newmortal();
- if (entry)
+ if (entry) {
sv_setsv(key, HeSVKEY_force(entry));
+ SvREFCNT_dec(HeSVKEY(entry)); /* get rid of previous key */
+ }
else {
- xhv->xhv_eiter = entry = new_he(); /* only one HE per MAGICAL hash */
+ 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)) {
- SvREFCNT_dec(HeSVKEY(entry));
- HeKEY(entry) = (char*)SvREFCNT_inc(key);
- return entry; /* beware, hent_val is not set */
+ /* force key to stay around until next time */
+ HeSVKEY_set(entry, SvREFCNT_inc(key));
+ return entry; /* beware, hent_val is not set */
}
if (HeVAL(entry))
SvREFCNT_dec(HeVAL(entry));
+ Safefree(HeKEY_hek(entry));
del_he(entry);
xhv->xhv_eiter = Null(HE*);
return Null(HE*);
@@ -816,8 +934,10 @@ HV *hv;
entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
}
- if (oldentry && HeKLEN(oldentry) == HEf_LAZYDEL) /* was deleted earlier? */
+ if (oldentry && HvLAZYDEL(hv)) { /* was deleted earlier? */
+ HvLAZYDEL_off(hv);
he_free(oldentry, HvSHAREKEYS(hv));
+ }
xhv->xhv_eiter = entry;
return entry;
@@ -829,7 +949,7 @@ register HE *entry;
I32 *retlen;
{
if (HeKLEN(entry) == HEf_SVKEY) {
- return SvPV((SV*)HeKEY(entry), *(STRLEN*)retlen);
+ return SvPV(HeKEY_sv(entry), *(STRLEN*)retlen);
}
else {
*retlen = HeKLEN(entry);
@@ -843,7 +963,7 @@ hv_iterkeysv(entry)
register HE *entry;
{
if (HeKLEN(entry) == HEf_SVKEY)
- return sv_mortalcopy((SV*)HeKEY(entry));
+ return sv_mortalcopy(HeKEY_sv(entry));
else
return sv_2mortal(newSVpv((HeKLEN(entry) ? HeKEY(entry) : ""),
HeKLEN(entry)));
@@ -857,7 +977,9 @@ register HE *entry;
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv,'P')) {
SV* sv = sv_newmortal();
- mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
+ 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;
}
}
@@ -886,65 +1008,67 @@ int how;
sv_magic((SV*)hv, (SV*)gv, how, Nullch, 0);
}
-/* get a (constant) string ptr from the global string table
- * string will get added if it is not already there.
+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.
*/
-char *
-sharepvn(str, len, hash)
-char *str;
+void
+unsharepvn(str, len, hash)
+char* str;
I32 len;
-register U32 hash;
+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);
- */
+ 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, entry = HeNEXT(entry)) {
+ 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 (bcmp(HeKEY(entry),str,len)) /* is this it? */
+ if (memNE(HeKEY(entry),str,len)) /* is this it? */
continue;
found = 1;
- break;
- }
- if (!found) {
- entry = new_he();
- HeKLEN(entry) = len;
- HeKEY(entry) = savepvn(str,len);
- HeVAL(entry) = Nullsv;
- HeHASH(entry) = hash;
- HeNEXT(entry) = *oentry;
- *oentry = entry;
- xhv->xhv_keys++;
- if (i) { /* initial entry? */
- ++xhv->xhv_fill;
- if (xhv->xhv_keys > xhv->xhv_max)
- hsplit(strtab);
+ if (--HeVAL(entry) == Nullsv) {
+ *oentry = HeNEXT(entry);
+ if (i && !*oentry)
+ xhv->xhv_fill--;
+ Safefree(HeKEY_hek(entry));
+ del_he(entry);
+ --xhv->xhv_keys;
}
+ break;
}
-
- ++HeVAL(entry); /* use value slot as REFCNT */
- return HeKEY(entry);
+
+ if (!found)
+ warn("Attempt to free non-existent shared string");
}
-/* possibly free a shared string if no one has access to it
+/* 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.
*/
-void
-unsharepvn(str, len, hash)
+HEK *
+share_hek(str, len, hash)
char *str;
I32 len;
register U32 hash;
@@ -954,35 +1078,41 @@ register U32 hash;
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);
- } */
+
+ 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, oentry = &HeNEXT(entry), entry = *oentry) {
+ 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 (bcmp(HeKEY(entry),str,len)) /* is this it? */
+ 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(entry));
- del_he(entry);
- --xhv->xhv_keys;
- }
break;
}
-
- if (!found)
- warn("Attempt to free non-existent shared string");
+ 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/hv.h b/hv.h
index a9de8caef1..5256eac8ed 100644
--- a/hv.h
+++ b/hv.h
@@ -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 {
@@ -43,10 +48,8 @@ struct xpvhv {
} STMT_END
-/* these hash entry flags ride on hent_klen */
-
-#define HEf_LAZYDEL -1 /* entry must be deleted during next iter step */
-#define HEf_SVKEY -2 /* hent_key is a SV* (only for magic/tied HVs) */
+/* 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*)
@@ -63,6 +66,10 @@ struct xpvhv {
#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: */
@@ -82,20 +89,29 @@ struct xpvhv {
#define Nullhe Null(HE*)
#define HeNEXT(he) (he)->hent_next
-#define HeKEY(he) (he)->hent_key
-#define HeKLEN(he) (he)->hent_klen
+#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) (he)->hent_hash
-#define HePV(he) ((he)->hent_klen == HEf_SVKEY) ? \
- SvPV((SV*)((he)->hent_key),na) : \
- (he)->hent_key))
-#define HeSVKEY(he) (((he)->hent_key && \
- (he)->hent_klen == HEf_SVKEY) ? \
- (SV*)((he)->hent_key) : Nullsv)
-
-#define HeSVKEY_force(he) ((he)->hent_key ? \
- (((he)->hent_klen == HEf_SVKEY) ? \
- (SV*)((he)->hent_key) : \
- sv_2mortal(newSVpv((he)->hent_key, \
- (he)->hent_klen))) : \
+#define HeHASH(he) HEK_HASH(HeKEY_hek(he))
+#define HePV(he) ((HeKLEN(he) == HEf_SVKEY) ? \
+ SvPV(HeKEY_sv(he),na) : \
+ HeKEY(he))
+#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) (HeKEY_sv(he) = sv)
+
+#define Nullhek Null(HEK*)
+#define HEK_BASESIZE OFFSETOF(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/installman b/installman
index 38bd0af10e..c5663dd562 100755
--- a/installman
+++ b/installman
@@ -56,36 +56,66 @@ 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, 'pl2pm');
+runpod2man('x2p', $man1dir, $man1ext, 's2p');
+runpod2man('x2p', $man1dir, $man1ext, 'a2p.pod');
+runpod2man('pod', $man1dir, $man1ext, 'pod2man');
+
+# 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 +126,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 +141,7 @@ sub runpod2man {
}
}
chdir "$builddir" || die "Unable to cd back to $builddir directory!\n$!\n";
+ print STDERR "chdir $builddir\n";
}
sub lsmodpods {
diff --git a/installperl b/installperl
index b79ca58483..ddbe5956e8 100755
--- a/installperl
+++ b/installperl
@@ -1,10 +1,17 @@
#!./perl
BEGIN { @INC=('./lib', '../lib') }
use File::Find;
-use File::Path qw(mkpath);
+use File::Compare;
+use File::Path ();
use Config;
use subs qw(unlink rename link chmod);
+# override the ones in the rest of the script
+sub mkpath
+{
+ File::Path::mkpath(@_) unless $nonono;
+}
+
$mainperldir = "/usr/bin";
$exe_ext = $Config{exe_ext};
@@ -16,15 +23,11 @@ while (@ARGV) {
umask 022;
-@scripts = qw( 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>);
$ver = $];
@@ -43,9 +46,7 @@ $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};
@@ -59,8 +60,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";
@@ -69,21 +70,11 @@ 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.
&safe_unlink("$installbin/perl$ver$exe_ext");
&cmd("cp perl$exe_ext $installbin/perl$ver$exe_ext");
+&chmod(0755, "$installbin/perl$ver$exe_ext");
&safe_unlink("$installbin/sperl$ver$exe_ext");
if ($d_dosuid) {
@@ -127,6 +118,11 @@ for (@scripts) {
s#.*/##; &chmod(0755, "$installscript/$_");
}
+# pstruct should be a link to c2ph
+
+&safe_unlink("$installscript/pstruct");
+&link("$installscript/c2ph","$installscript/pstruct");
+
# Install pod pages. Where? I guess in $installprivlib/pod.
mkpath("${installprivlib}/pod", 1, 0777);
foreach $file (@pods) {
@@ -134,30 +130,6 @@ foreach $file (@pods) {
cp_if_diff($file, "${installprivlib}/${file}");
}
-# 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;
@@ -197,27 +169,30 @@ foreach $file (@corefiles) {
$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") {
+ 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) ||
(($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 } ||
+ cmd("cp $instperl $usrbinperl");
$mainperl_is_instperl = 1;
}
}
@@ -321,16 +296,18 @@ 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++ : 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;
+ system( $cp, $from, $to )==0 ? $success++ :
+ warn "Couldn't copy $from to $to: $!\n" unless $nonono;
}
+ $success;
}
sub chmod {
@@ -358,6 +335,7 @@ sub samepath {
sub installlib {
my $dir = $File::Find::dir;
$dir =~ s#^\.(?![^/])/?##;
+ local($depth) = $dir ? "lib/$dir" : "lib";
my $name = $_;
@@ -366,8 +344,11 @@ sub installlib {
$name = "$dir/$name" if $dir ne '';
+ # ignore Chip-style patch backups.
+ return if grep(/^P\d+$/, split(m{/+}, $name));
+
my $installlib = $installprivlib;
- if ((substr($dir, 0, 4) eq 'auto') || ($name eq 'Config.pm')) {
+ if ($dir =~ /^auto/ || $name =~ /^(Config|FileHandle|Safe)\.pm$/) {
$installlib = $installarchlib;
return unless $do_installarchlib;
} else {
@@ -383,8 +364,7 @@ sub installlib {
#This might not work because $archname might have changed.
&unlink("$installarchlib/$name");
}
- system "cmp", "-s", $_, "$installlib/$name";
- if ($?) {
+ if (compare($_, "$installlib/$name") || $nonono) {
&unlink("$installlib/$name");
mkpath("$installlib/$dir", 1, 0777);
cp_if_diff($_, "$installlib/$name");
@@ -413,13 +393,15 @@ sub installlib {
sub cp_if_diff {
my($from,$to)=@_;
-f $from || die "$0: $from not found";
- system "cmp", "-s", $from, $to;
- if ($?) {
+ if (compare($from, $to) || $nonono) {
my ($atime, $mtime);
unlink($to); # In case we don't have write permissions.
+ if ($nonono) {
+ $from = $depth . "/" . $from if $depth;
+ }
cmd("cp $from $to");
# Restore timestamps if it's a .a library.
- if ($to =~ /\.a$/) {
+ if ($to =~ /\.a$/ or $^O eq 'os2') { # For binary install
($atime, $mtime) = (stat $from)[8,9];
utime $atime, $mtime, $to;
}
diff --git a/interp.sym b/interp.sym
index a2f04c706d..55b53389af 100644
--- a/interp.sym
+++ b/interp.sym
@@ -31,7 +31,6 @@ dbargs
debdelim
debname
debstash
-debug
defgv
defoutgv
defstash
@@ -40,7 +39,6 @@ diehook
dirty
dlevel
dlmax
-do_undump
doextract
doswitches
dowarn
@@ -117,7 +115,6 @@ rightgv
rs
runlevel
sawampersand
-sawi
sawstudy
sawvec
screamfirst
diff --git a/keywords.pl b/keywords.pl
index 086a10956a..595e875bc4 100755
--- a/keywords.pl
+++ b/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;
diff --git a/lib/AnyDBM_File.pm b/lib/AnyDBM_File.pm
index c985e7ed25..e6a15033c3 100644
--- a/lib/AnyDBM_File.pm
+++ b/lib/AnyDBM_File.pm
@@ -1,12 +1,15 @@
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) {
+ return 1 if eval "require $mod"
+}
+
+die "No DBM package was successfully found or installed";
+#return 0;
=head1 NAME
diff --git a/lib/AutoLoader.pm b/lib/AutoLoader.pm
index e24e13922b..be6429e6e8 100644
--- a/lib/AutoLoader.pm
+++ b/lib/AutoLoader.pm
@@ -11,7 +11,7 @@ AutoLoader - load functions only on demand
package FOOBAR;
use Exporter;
use AutoLoader;
- @ISA = (Exporter, AutoLoader);
+ @ISA = qw(Exporter AutoLoader);
=head1 DESCRIPTION
@@ -35,6 +35,31 @@ F</usr/local/lib/perl5/POSIX.pm>. The autoloader will look for perl
subroutines for this package in F</usr/local/lib/perl5/auto/POSIX/*.al>.
The C<.al> file is named using the subroutine name, sans package.
+=head2 Loading Stubs
+
+The B<AutoLoader> module provide a special import() method that will
+load the stubs (from F<autosplit.ix> file) of the calling module.
+These stubs are needed to make inheritance work correctly for class
+modules.
+
+Modules that inherit from B<AutoLoader> should always ensure that they
+override the AutoLoader->import() method. If the module inherit from
+B<Exporter> like shown in the I<synopis> section this is already taken
+care of. For class methods an empty import() would do nicely:
+
+ package MyClass;
+ use AutoLoader; # load stubs
+ @ISA=qw(AutoLoader);
+ sub import {} # hide AutoLoader::import
+
+You can also set up autoloading by importing the AUTOLOAD function
+instead of inheriting from B<AutoLoader>:
+
+ package MyClass;
+ use AutoLoader; # load stubs
+ *AUTOLOAD = \&AutoLoader::AUTOLOAD;
+
+
=head2 Package Lexicals
Package lexicals declared with C<my> in the main block of a package using
@@ -60,7 +85,8 @@ 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.
+individual files. The B<ExtUtils::MakeMaker> will invoke B<AutoSplit>
+automatically if the B<AutoLoader> is used in a module source file.
=head1 CAVEAT
@@ -72,27 +98,43 @@ conflicts when used to split a module.
=cut
AUTOLOAD {
- my $name = "auto/$AUTOLOAD.al";
- $name =~ s#::#/#g;
+ 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 {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 {require $name};
+ }
+ if ($@){
+ $@ =~ s/ at .*\n//;
+ croak $@;
+ }
}
}
+ $@ = $save;
$DB::sub = $AUTOLOAD; # Now debugger know where we are.
goto &$AUTOLOAD;
}
diff --git a/lib/AutoSplit.pm b/lib/AutoSplit.pm
index b1d797a0b3..d9bd17a7f7 100644
--- a/lib/AutoSplit.pm
+++ b/lib/AutoSplit.pm
@@ -21,7 +21,7 @@ AutoSplit - split a package for autoloading
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
@@ -195,6 +195,7 @@ sub autosplit_file{
die "Package $package does not match filename $filename"
unless ($filename =~ m/$modpname.pm$/ or
+ ($^O eq "msdos") or
$Is_VMS && $filename =~ m/$modpname.pm/i);
if ($check_mod_time){
diff --git a/lib/Benchmark.pm b/lib/Benchmark.pm
index 9929e6e0be..c382fcb1c4 100644
--- a/lib/Benchmark.pm
+++ b/lib/Benchmark.pm
@@ -40,7 +40,7 @@ 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
@@ -146,14 +146,14 @@ than a short test; try:
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.
+code and therefore the difference might end up being E<lt> 0.
More documentation is needed :-( especially for styles and formats.
=head1 AUTHORS
-Jarkko Hietaniemi <Jarkko.Hietaniemi@hut.fi>,
-Tim Bunce <Tim.Bunce@ig.co.uk>
+Jarkko Hietaniemi E<lt>F<Jarkko.Hietaniemi@hut.fi>E<gt>,
+Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>
=head1 MODIFICATION HISTORY
diff --git a/lib/CPAN.pm b/lib/CPAN.pm
new file mode 100644
index 0000000000..c755aa1ac0
--- /dev/null
+++ b/lib/CPAN.pm
@@ -0,0 +1,2350 @@
+package CPAN;
+use vars qw{$META $Signal $Cwd $End $Suppress_readline};
+
+$VERSION = '1.02';
+
+# $Id: CPAN.pm,v 1.77 1996/12/11 01:26:43 k Exp $
+
+# my $version = substr q$Revision: 1.77 $, 10; # only used during development
+
+BEGIN {require 5.003;}
+require UNIVERSAL if $] == 5.003;
+
+use Carp ();
+use Config ();
+use Cwd ();
+use DirHandle;
+use Exporter ();
+use ExtUtils::MakeMaker ();
+use File::Basename ();
+use File::Find;
+use File::Path ();
+use IO::File ();
+use Safe ();
+
+$Cwd = Cwd::cwd();
+
+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;
+
+package CPAN;
+use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DEBUG $META);
+use strict qw(vars);
+
+@ISA = qw(CPAN::Debug Exporter MY); # the MY class from MakeMaker, gives us catfile and catdir
+
+$META ||= new CPAN; # In case we reeval ourselves we need a ||
+
+CPAN::Config->load;
+
+@EXPORT = qw(autobundle bundle expand force install make recompile shell test clean);
+
+sub autobundle;
+sub bundle;
+sub bundles;
+sub expand;
+sub force;
+sub install;
+sub make;
+sub shell;
+sub clean;
+sub test;
+
+sub AUTOLOAD {
+ my($l) = $AUTOLOAD;
+ $l =~ s/.*:://;
+ my(%EXPORT);
+ @EXPORT{@EXPORT} = '';
+ if (exists $EXPORT{$l}){
+ CPAN::Shell->$l(@_);
+ } else {
+ warn "CPAN doesn't know how to autoload $AUTOLOAD :-(
+Nothing Done.
+";
+ CPAN::Shell->h;
+ }
+}
+
+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 checklock {
+ my($self) = @_;
+ my $lockfile = CPAN->catfile($CPAN::Config->{cpan_home},".lock");
+ if (-f $lockfile && -M _ > 0) {
+ my $fh = IO::File->new($lockfile);
+ my $other = <$fh>;
+ $fh->close;
+ if (defined $other && $other) {
+ chomp $other;
+ return if $$==$other; # should never happen
+ print qq{There seems to be running another CPAN process ($other). Trying to contact...\n};
+ if (kill 0, $other) {
+ Carp::croak qq{Other job is running.\n}.
+ qq{You may want to kill it and delete the lockfile, maybe. On UNIX try:\n}.
+ qq{ kill $other\n}.
+ qq{ rm $lockfile\n};
+ } elsif (-w $lockfile) {
+ my($ans)=
+ ExtUtils::MakeMaker::prompt
+ (qq{Other job not responding. Shall I overwrite the lockfile? (Y/N)},"y");
+ print("Ok, bye\n"), exit unless $ans =~ /^y/i;
+ } else {
+ Carp::croak(
+ qq{Lockfile $lockfile not writeable by you. 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 = IO::File->new(">$lockfile")) {
+ if ($! =~ /Permission/) {
+ my $incc = $INC{'CPAN/Config.pm'};
+ my $myincc = MY->catfile($ENV{HOME},'.cpan','CPAN','MyConfig.pm');
+ print 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
+
+};
+ }
+ Carp::croak "Could not open >$lockfile: $!";
+ }
+ print $fh $$, "\n";
+ $self->{LOCK} = $lockfile;
+ $fh->close;
+ $SIG{'TERM'} = sub { &cleanup; die "Got SIGTERM, leaving"; };
+ $SIG{'INT'} = sub { &cleanup, die "Got a second SIGINT" if $Signal; $Signal = 1; };
+ $SIG{'__DIE__'} = \&cleanup;
+ print STDERR "Signal handler set.\n" unless $CPAN::Config->{'inhibit_startup_message'};
+}
+
+sub DESTROY {
+ &cleanup; # need an eval?
+}
+
+sub exists {
+ my($mgr,$class,$id) = @_;
+ CPAN::Index->reload;
+ Carp::croak "exists called without class argument" unless $class;
+ $id ||= "";
+ exists $META->{$class}{$id};
+}
+
+sub hasFTP {
+ my($self,$arg) = @_;
+ if (defined $arg) {
+ return $self->{'hasFTP'} = $arg;
+ } elsif (not defined $self->{'hasFTP'}) {
+ eval {require Net::FTP;};
+ $self->{'hasFTP'} = $@ ? 0 : 1;
+ }
+ return $self->{'hasFTP'};
+}
+
+sub hasLWP {
+ my($self,$arg) = @_;
+ if (defined $arg) {
+ return $self->{'hasLWP'} = $arg;
+ } elsif (not defined $self->{'hasLWP'}) {
+ eval {require LWP;};
+ $LWP::VERSION ||= 0;
+ $self->{'hasLWP'} = $LWP::VERSION >= 4.98;
+ }
+ return $self->{'hasLWP'};
+}
+
+sub hasMD5 {
+ my($self,$arg) = @_;
+ if (defined $arg) {
+ $self->{'hasMD5'} = $arg;
+ } elsif (not defined $self->{'hasMD5'}) {
+ eval {require MD5;};
+ if ($@) {
+ print "MD5 security checks disabled because MD5 not installed. Please consider installing MD5\n";
+ $self->{'hasMD5'} = 0;
+ } else {
+ $self->{'hasMD5'}++;
+ }
+ }
+ return $self->{'hasMD5'};
+}
+
+sub instance {
+ my($mgr,$class,$id) = @_;
+ CPAN::Index->reload;
+ Carp::croak "instance called without class argument" unless $class;
+ $id ||= "";
+ $META->{$class}{$id} ||= $class->new(ID => $id );
+}
+
+sub new {
+ bless {}, shift;
+}
+
+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'};
+ print STDERR "Lockfile removed.\n";
+# my $mess = Carp::longmess(@_);
+# die @_;
+}
+
+sub shell {
+ $Suppress_readline ||= ! -t STDIN;
+
+ my $prompt = "cpan> ";
+ local($^W) = 1;
+ my $term;
+ unless ($Suppress_readline) {
+ require Term::ReadLine;
+ import Term::ReadLine;
+ $term = new Term::ReadLine 'CPAN Monitor';
+ $readline::rl_completion_function =
+ $readline::rl_completion_function = 'CPAN::Complete::complete';
+ }
+
+ no strict;
+ $META->checklock();
+ my $cwd = Cwd::cwd();
+ # How should we determine if we have more than stub ReadLine enabled?
+ my $rl_avail = $Suppress_readline ? "suppressed" :
+ defined &Term::ReadLine::Perl::readline ? "enabled" :
+ "available (get Term::ReadKey and Term::ReadLine::Perl)";
+
+ print qq{
+cpan shell -- CPAN exploration and modules installation (v$CPAN::VERSION)
+Readline support $rl_avail
+
+} unless $CPAN::Config->{'inhibit_startup_message'} ;
+ while () {
+ if ($Suppress_readline) {
+ print $prompt;
+ last unless defined (chomp($_ = <>));
+ } else {
+ last unless defined ($_ = $term->readline($prompt));
+ }
+ s/^\s//;
+ next if /^$/;
+ $_ = 'h' if $_ eq '?';
+ if (/^\!/) {
+ 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 $@;
+ } elsif (/^q(?:uit)?$/i) {
+ last;
+ } elsif (/./) {
+ my @line = split;
+ my $command = shift @line;
+ eval { CPAN::Shell->$command(@line) };
+ warn $@ if $@;
+ }
+ } continue {
+ &cleanup, die if $Signal;
+ chdir $cwd;
+ print "\n";
+ }
+}
+
+package CPAN::Shell;
+use vars qw(@ISA $AUTOLOAD);
+@ISA = qw(CPAN::Debug);
+
+# private function ro re-eval this module (handy during development)
+sub AUTOLOAD {
+ warn "CPAN::Shell doesn't know how to autoload $AUTOLOAD :-(
+Nothing Done.
+";
+ CPAN::Shell->h;
+}
+
+sub h {
+ my($class,$about) = @_;
+ if (defined $about) {
+ print "Detailed help not yet implemented\n";
+ } else {
+ print 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() and recompile()
+
+make modules, make
+test dists, bundles, make test (implies make)
+install "r" or "u" make install (implies test)
+clean make clean
+
+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 a { print shift->format_result('Author',@_);}
+sub b {
+ my($self,@which) = @_;
+ my($bdir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
+ my($dh) = DirHandle->new($bdir); # may fail!
+ my($entry);
+ for $entry ($dh->read) {
+ next if -d $CPAN::META->catdir($bdir,$entry);
+ next unless $entry =~ s/\.pm$//;
+ $CPAN::META->instance('CPAN::Bundle',"Bundle::$entry");
+ }
+ print $self->format_result('Bundle',@which);
+}
+sub d { print shift->format_result('Distribution',@_);}
+sub m { print shift->format_result('Module',@_);}
+
+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";
+ print $result;
+}
+
+sub o {
+ my($self,$o_type,@o_what) = @_;
+ $o_type ||= "";
+ CPAN->debug("o_type[$o_type] o_what[@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);
+ print "CPAN::Config options:\n";
+ for $k (sort keys %CPAN::Config::can) {
+ $v = $CPAN::Config::can{$k};
+ printf " %-18s %s\n", $k, $v;
+ }
+ print "\n";
+ for $k (sort keys %$CPAN::Config) {
+ $v = $CPAN::Config->{$k};
+ if (ref $v) {
+ printf " %-18s\n", $k;
+ print map {"\t$_\n"} @{$v};
+ } else {
+ printf " %-18s %s\n", $k, $v;
+ }
+ }
+ print "\n";
+ } elsif (!CPAN::Config->edit(@o_what)) {
+ print 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 {
+ for (keys %CPAN::DEBUG) {
+ next unless lc($_) eq lc($what);
+ $CPAN::DEBUG |= $CPAN::DEBUG{$_};
+ }
+ print "unknown argument $what\n";
+ }
+ }
+ } else {
+ print "Valid options for debug are ".join(", ",sort(keys %CPAN::DEBUG), 'all').
+ " or a number. Completion works on the options. Case is ignored.\n\n";
+ }
+ if ($CPAN::DEBUG) {
+ print "Options set for debugging:\n";
+ my($k,$v);
+ for $k (sort {$CPAN::DEBUG{$a} <=> $CPAN::DEBUG{$b}} keys %CPAN::DEBUG) {
+ $v = $CPAN::DEBUG{$k};
+ printf " %-14s(%s)\n", $k, $v if $v & $CPAN::DEBUG;
+ }
+ } else {
+ print "Debugging turned off completely.\n";
+ }
+ } else {
+ print qq{
+Known options:
+ conf set or get configuration variables
+ debug set or get debugging options
+};
+ }
+}
+
+sub reload {
+ if ($_[1] =~ /cpan/i) {
+ CPAN->debug("reloading the whole CPAN.pm") if $CPAN::DEBUG;
+ my $fh = IO::File->new($INC{'CPAN.pm'});
+ local $/;
+ undef $/;
+ eval <$fh>;
+ warn $@ if $@;
+ } elsif ($_[1] =~ /index/) {
+ CPAN::Index->force_reload;
+ }
+}
+
+sub _binary_extensions {
+ my($self) = shift @_;
+ my(@result,$module,%seen,%need,$headerdone);
+ for $module ($self->expand('Module','/./')) {
+ my $file = $module->cpan_file;
+ next if $file eq "N/A";
+ next if $file =~ /^Contact Author/;
+ next if $file =~ /perl5[._-]\d{3}(?:[\d_]+)?\.tar[._-]gz$/;
+ next unless $module->xs_file;
+ push @result, $module;
+ }
+# print join " | ", @result;
+# print "\n";
+ return @result;
+}
+
+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) {
+ print " 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 _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_zeroes);
+ $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 || 0;
+ 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;
+ $version_zeroes++ unless $have;
+ next if $have >= $latest;
+ } elsif ($what eq "u") {
+ next;
+ }
+ } else {
+ if ($what eq "a") {
+ next;
+ } elsif ($what eq "r") {
+ next;
+ } elsif ($what eq "u") {
+ $have = "-";
+ }
+ }
+ $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++){
+ print "\n";
+ printf $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;
+ printf $sprintf, $module->id, $have, $latest, $file;
+ $need{$module->id}++;
+ return if $CPAN::Signal; # this is sometimes lengthy
+ }
+ unless (%need) {
+ if ($what eq "u") {
+ print "No modules found for @args\n";
+ } elsif ($what eq "r") {
+ print "All modules are up to date for @args\n";
+ }
+ }
+ if ($what eq "r" && $version_zeroes) {
+ my $s = $version_zeroes>1 ? "s have" : " has";
+ print qq{$version_zeroes installed module$s no version number to compare\n};
+ }
+ @result;
+}
+
+sub r {
+ shift->_u_r_common("r",@_);
+}
+
+sub u {
+ shift->_u_r_common("u",@_);
+}
+
+sub autobundle {
+ my($self) = shift;
+ my(@bundle) = $self->_u_r_common("a",@_);
+ my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
+ File::Path::mkpath($todir);
+ unless (-d $todir) {
+ print "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) = $CPAN::META->catfile($todir,"$me.pm");
+ while (-f $to) {
+ $me = sprintf "Snapshot_%04d_%02d_%02d_%02d", $y, $m, $d, ++$c;
+ $to = $CPAN::META->catfile($todir,"$me.pm");
+ }
+ my($fh) = IO::File->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;
+ print "\nWrote bundle file
+ $to\n\n";
+}
+
+sub bundle {
+ shift;
+ my(@bundles) = @_;
+ my $bundle;
+ my @pack = ();
+ foreach $bundle (@bundles) {
+ my $pack = $bundle;
+ $pack =~ s/^(Bundle::)?(.*)/Bundle::$2/;
+ push @pack, $CPAN::META->instance('CPAN::Bundle',$pack)->contains;
+ }
+ @pack;
+}
+
+sub bundles {
+ my($self) = @_;
+ CPAN->debug("self[$self]") if $CPAN::DEBUG;
+ sort grep $_->id() =~ /^Bundle::/, $CPAN::META->all('CPAN::Bundle');
+}
+
+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 $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 ($obj = $CPAN::META->exists($class,$arg)) {
+ $obj = $CPAN::META->instance($class,$arg);
+ } else {
+ next;
+ }
+ push @m, $obj;
+ }
+ }
+ return @m;
+}
+
+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;
+}
+
+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 && $obj->can($pragma);
+ $obj->$meth();
+ } else {
+ print "Warning: Cannot $meth $s, don't know what it is\n";
+ }
+ }
+}
+
+sub force { shift->rematein('force',@_); }
+sub readme { shift->rematein('readme',@_); }
+sub make { shift->rematein('make',@_); }
+sub clean { shift->rematein('clean',@_); }
+sub test { shift->rematein('test',@_); }
+sub install { shift->rematein('install',@_); }
+
+package CPAN::FTP;
+use vars qw($Ua @ISA);
+@ISA = qw(CPAN::Debug);
+
+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);
+ $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;
+ }
+ # print qq[Going to ->cwd("$dir")\n];
+ unless ( $ftp->cwd($dir) ){
+ warn "Couldn't cwd $dir";
+ return;
+ }
+ $ftp->binary;
+ print qq[Going to ->get("$file","$target")\n] if $CPAN::DEBUG;
+ unless ( $ftp->get($file,$target) ){
+ warn "Couldn't fetch $file from $host";
+ return;
+ }
+ $ftp->quit;
+}
+
+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]") if $CPAN::DEBUG;
+
+ return $aslocal if -f $aslocal && -r _ && ! $force;
+
+ my($aslocal_dir) = File::Basename::dirname($aslocal);
+ File::Path::mkpath($aslocal_dir);
+ print STDERR qq{Warning: You are not allowed to write into directory "$aslocal_dir".
+ I\'ll continue, but if you face any 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->hasLWP) {
+ require LWP::UserAgent;
+ unless ($Ua) {
+ $Ua = new LWP::UserAgent;
+ $Ua->proxy('ftp', $ENV{'ftp_proxy'}) if defined $ENV{'ftp_proxy'};
+ $Ua->proxy('http', $ENV{'http_proxy'}) if defined $ENV{'http_proxy'};
+ $Ua->no_proxy($ENV{'no_proxy'}) if defined $ENV{'no_proxy'};
+ }
+ }
+
+ # Try the list of urls for each single object. We keep a record
+ # where we did get a file from
+ for (0..$#{$CPAN::Config->{urllist}}) {
+ my $url = $CPAN::Config->{urllist}[$_];
+ $url .= "/" unless substr($url,-1) eq "/";
+ $url .= $file;
+ $self->debug("localizing[$url]") if $CPAN::DEBUG;
+ if ($url =~ /^file:/) {
+ my $l;
+ if ($CPAN::META->hasLWP) {
+ require URI::URL;
+ my $u = new URI::URL $url;
+ $l = $u->path;
+ } else { # works only on Unix
+ ($l = $url) =~ s/^file://;
+ }
+ return $l if -f $l && -r _;
+ }
+
+ if ($CPAN::META->hasLWP) {
+ print "Fetching $url\n";
+ my $res = $Ua->mirror($url, $aslocal);
+ if ($res->is_success) {
+ return $aslocal;
+ }
+ } elsif ($url =~ m|^ftp://(.*?)/(.*)/(.*)|) {
+ unless ($CPAN::META->hasFTP) {
+ warn "Can't access URL $url without module Net::FTP";
+ next;
+ }
+ my($host,$dir,$getfile) = ($1,$2,$3);
+ $dir =~ s|/+|/|g;
+ print "Going to fetch file [$getfile] from dir [$dir] on host [$host] as local [$aslocal]\n";
+
+ #### This was the bug where I contacted Graham and got so strange error messages
+ #### ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal;
+ CPAN::FTP->ftp_get($host,$dir,$getfile,$aslocal) && return $aslocal;
+ }
+ }
+ Carp::croak("Cannot fetch $file from anywhere");
+}
+
+package CPAN::Complete;
+use vars qw(@ISA);
+@ISA = qw(CPAN::Debug);
+
+sub complete {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ $line ||= "";
+ $pos ||= 0;
+ CPAN->debug("word [$word] line[$line] pos[$pos]") if $CPAN::DEBUG;
+ $line =~ s/^\s*//;
+ 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 reload));
+ } elsif ( $line !~ /^[\!abdhimorut]/ ) {
+ @return = ();
+ } elsif ($line =~ /^a\s/) {
+ @return = completex('CPAN::Author',$word);
+ } elsif ($line =~ /^b\s/) {
+ @return = completex('CPAN::Bundle',$word);
+ } elsif ($line =~ /^d\s/) {
+ @return = completex('CPAN::Distribution',$word);
+ } elsif ($line =~ /^([mru]\s|(make|clean|test|install)\s)/ ) {
+ @return = (completex('CPAN::Module',$word),completex('CPAN::Bundle',$word));
+ } elsif ($line =~ /^i\s/) {
+ @return = complete_any($word);
+ } elsif ($line =~ /^reload\s/) {
+ @return = complete_reload($word,$line,$pos);
+ } elsif ($line =~ /^o\s/) {
+ @return = complete_option($word,$line,$pos);
+ } else {
+ @return = ();
+ }
+ return @return;
+}
+
+sub completex {
+ my($class, $word) = @_;
+ grep /^\Q$word\E/, map { $_->id } $CPAN::META->all($class);
+}
+
+sub complete_any {
+ my($word) = shift;
+ return (
+ completex('CPAN::Author',$word),
+ completex('CPAN::Bundle',$word),
+ completex('CPAN::Distribution',$word),
+ completex('CPAN::Module',$word),
+ );
+}
+
+sub complete_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 complete_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 && $word;
+ if (0) {
+ } elsif ($words[1] eq 'index') {
+ return ();
+ } elsif ($words[1] eq 'conf') {
+ return CPAN::Config::complete(@_);
+ } elsif ($words[1] eq 'debug') {
+ return sort grep /^\Q$word\E/, sort keys %CPAN::DEBUG, 'all';
+ }
+}
+
+package CPAN::Index;
+use vars qw($last_time @ISA);
+@ISA = qw(CPAN::Debug);
+$last_time ||= 0;
+
+sub force_reload {
+ my($class) = @_;
+ $CPAN::Index::last_time = 0;
+ $class->reload(1);
+}
+
+sub reload {
+ my($cl,$force) = @_;
+ my $time = time;
+
+ # XXX check if a newer one is available. (We currently read it from time to time)
+ return if $last_time + $CPAN::Config->{index_expire}*86400 > $time;
+ $last_time = $time;
+
+ $cl->read_authindex($cl->reload_x("authors/01mailrc.txt.gz","01mailrc.gz",$force));
+ return if $CPAN::Signal; # this is sometimes lengthy
+ $cl->read_modpacks($cl->reload_x("modules/02packages.details.txt.gz","02packag.gz",$force));
+ return if $CPAN::Signal; # this is sometimes lengthy
+ $cl->read_modlist($cl->reload_x("modules/03modlist.data.gz","03mlist.gz",$force));
+}
+
+sub reload_x {
+ my($cl,$wanted,$localname,$force) = @_;
+ $force ||= 0;
+ my $abs_wanted = CPAN->catfile($CPAN::Config->{'keep_source_where'},$localname);
+ if (-f $abs_wanted && -M $abs_wanted < $CPAN::Config->{'index_expire'} && !$force) {
+ my($s) = $CPAN::Config->{'index_expire'} != 1;
+ $cl->debug(qq{$abs_wanted younger than $CPAN::Config->{'index_expire'} day$s. I\'ll use that.\n});
+ return $abs_wanted;
+ } else {
+ $force ||= 1;
+ }
+ return CPAN::FTP->localize($wanted,$abs_wanted,$force);
+}
+
+sub read_authindex {
+ my($cl,$index_target) = @_;
+ my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
+ warn "Going to read $index_target\n";
+ my $fh = IO::File->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 read_modpacks {
+ my($cl,$index_target) = @_;
+ my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
+ warn "Going to read $index_target\n";
+ my $fh = IO::File->new("$pipe|");
+ while (<$fh>) {
+ next if 1../^\s*$/;
+ chomp;
+ my($mod,$version,$dist) = split;
+ $version =~ s/^\+//;
+
+ # if it as a bundle, instatiate a bundle object
+ my($bundle) = $mod =~ /^Bundle::(.*)/;
+ $version = "n/a" if $mod =~ s/(.+::.+::).+/$1*/; # replace the third level with a star
+
+ if ($mod eq 'CPAN') {
+ local($^W)=0;
+ if ($version > $CPAN::VERSION){
+ print qq{
+ Hey, you know what? There\'s a new CPAN.pm version (v$version)
+ available! I\'d suggest--provided you have time--you try
+ install CPAN
+ reload cpan
+ without quitting the current session. It should be a seemless upgrade
+ while we are running...
+};
+ sleep 2;
+ print qq{\n};
+ }
+ }
+
+ my($id);
+ if ($bundle){
+ $id = $CPAN::META->instance('CPAN::Bundle',$mod);
+ $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
+# 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);
+ $id->set('CPAN_VERSION' => $version, 'CPAN_FILE' => $dist);
+ }
+
+ # determine the author
+ my($userid) = $dist =~ /([^\/]+)/;
+ $id->set('CPAN_USERID' => $userid) if $userid =~ /\w/;
+
+ # instantiate a distribution object
+ unless ($CPAN::META->exists('CPAN::Distribution',$dist)) {
+ $CPAN::META->instance(
+ 'CPAN::Distribution' => $dist
+ )->set(
+ 'CPAN_USERID' => $userid
+ )
+ if $userid =~ /\w/;
+ }
+
+ return if $CPAN::Signal;
+ }
+ $fh->close;
+ $? and Carp::croak "FAILED $pipe: exit status [$?]";
+}
+
+sub read_modlist {
+ my($cl,$index_target) = @_;
+ my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $index_target";
+ warn "Going to read $index_target\n";
+ my $fh = IO::File->new("$pipe|");
+ my $eval = "";
+ while (<$fh>) {
+ next if 1../^\s*$/;
+ next if /use vars/; # will go away in 03...
+ $eval .= $_;
+ return if $CPAN::Signal;
+ }
+ $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;
+use vars qw(@ISA);
+@ISA = qw(CPAN::Debug);
+
+sub new { my $this = bless {}, shift; %$this = @_; $this }
+
+sub set {
+ my($self,%att) = @_;
+ my(%oldatt) = %$self;
+ %$self = (%oldatt, %att);
+}
+
+sub id { shift->{'ID'} }
+
+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 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->{$_}) { # 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 author {
+ my($self) = @_;
+ $CPAN::META->instance(CPAN::Author,$self->{CPAN_USERID})->fullname;
+}
+
+package CPAN::Author;
+use vars qw(@ISA);
+@ISA = qw(CPAN::Debug CPAN::InfoObj);
+
+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;
+}
+
+sub fullname { shift->{'FULLNAME'} }
+*name = \&fullname;
+sub email { shift->{'EMAIL'} }
+
+package CPAN::Distribution;
+use vars qw(@ISA);
+@ISA = qw(CPAN::Debug CPAN::InfoObj);
+
+sub called_for {
+ my($self,$id) = @_;
+ $self->{'CALLED_FOR'} = $id if defined $id;
+ return $self->{'CALLED_FOR'};
+}
+
+sub get {
+ my($self) = @_;
+ EXCUSE: {
+ my @e;
+ exists $self->{'build_dir'} and push @e, "Unwrapped into directory $self->{'build_dir'}";
+ print join "", map {" $_\n"} @e and return if @e;
+ }
+ my($local_file);
+ my($local_wanted) =
+ CPAN->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);
+ $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 ($local_file =~ /(\.tar\.(gz|Z)|\.tgz|\.zip)$/i){
+ $self->debug("Removing tmp") if $CPAN::DEBUG;
+ File::Path::rmtree("tmp");
+ mkdir "tmp", 0777 or Carp::croak "Couldn't mkdir tmp: $!";
+ chdir "tmp";
+ $self->debug("Changed directory to tmp") if $CPAN::DEBUG;
+ if ($local_file =~ /z$/i){
+ $self->{archived} = "tar";
+ if (system("$CPAN::Config->{gzip} --decompress --stdout $local_file | $CPAN::Config->{tar} xvf -")==0) {
+ $self->{unwrapped} = "YES";
+ } else {
+ $self->{unwrapped} = "NO";
+ }
+ } elsif ($local_file =~ /zip$/i) {
+ $self->{archived} = "zip";
+ if (system("$CPAN::Config->{unzip} $local_file")==0) {
+ $self->{unwrapped} = "YES";
+ } else {
+ $self->{unwrapped} = "NO";
+ }
+ }
+ # Let's check if the package has its own directory.
+ opendir DIR, "." or Carp::croak("Weird: couldn't opendir .: $!");
+ my @readdir = grep $_ !~ /^\.\.?$/, readdir DIR; ### MAC??
+ closedir DIR;
+ my ($distdir,$packagedir);
+ if (@readdir == 1 && -d $readdir[0]) {
+ $distdir = $readdir[0];
+ $packagedir = $CPAN::META->catdir($builddir,$distdir);
+ -d $packagedir and print "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 = $CPAN::META->catdir($builddir,$pragmatic_dir);
+ File::Path::mkpath($packagedir);
+ my($f);
+ for $f (@readdir) { # is already without "." and ".."
+ my $to = $CPAN::META->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 ){
+ print "Going to unlink $local_file\n";
+ unlink $local_file or Carp::carp "Couldn't unlink $local_file";
+ }
+ my($makefilepl) = $CPAN::META->catfile($packagedir,"Makefile.PL");
+ unless (-f $makefilepl) {
+ my($configure) = $CPAN::META->catfile($packagedir,"Configure");
+ if (-f $configure) {
+ # do we have anything to do?
+ $self->{'configure'} = $configure;
+ } else {
+ my $fh = IO::File->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
+# Autogenerated on: }.scalar localtime().qq{
+ use ExtUtils::MakeMaker;
+ WriteMakefile(NAME => q[$cf]);
+});
+ print qq{Package comes without Makefile.PL.\n}.
+ qq{ Writing one on our own (calling it $cf)\n};
+ }
+ }
+ } else {
+ $self->{archived} = "NO";
+ }
+ return $self;
+}
+
+sub new {
+ my($class,%att) = @_;
+
+ $CPAN::META->{cachemgr} ||= CPAN::CacheMgr->new();
+
+ my $this = { %att };
+ return bless $this, $class;
+}
+
+sub readme {
+ my($self) = @_;
+ print "Readme not yet implemented (says ".$self->id.")\n";
+}
+
+sub verifyMD5 {
+ my($self) = @_;
+ EXCUSE: {
+ my @e;
+ $self->{MD5_STATUS} and push @e, "MD5 Checksum was ok";
+ print join "", map {" $_\n"} @e and return if @e;
+ }
+ my($local_file);
+ my(@local) = split("/",$self->{ID});
+ my($basename) = pop @local;
+ push @local, "CHECKSUMS";
+ my($local_wanted) =
+ CPAN->catfile(
+ $CPAN::Config->{keep_source_where},
+ "authors",
+ "id",
+ @local
+ );
+ local($") = "/";
+ if (
+ -f $local_wanted
+ &&
+ $self->MD5_check_file($local_wanted,$basename)
+ ) {
+ return $self->{MD5_STATUS}="OK";
+ }
+ $local_file = CPAN::FTP->localize("authors/id/@local", $local_wanted, 'force>:-{');
+ my($checksum_pipe);
+ if ($local_file) {
+ # fine
+ } else {
+ $local[-1] .= ".gz";
+ $local_file = CPAN::FTP->localize(
+ "authors/id/@local",
+ "$local_wanted.gz",
+ 'force>:-{'
+ );
+ my $system = "$CPAN::Config->{gzip} --decompress $local_file";
+ system($system)==0 or die "Could not uncompress $local_file";
+ $local_file =~ s/\.gz$//;
+ }
+ $self->MD5_check_file($local_file,$basename);
+}
+
+sub MD5_check_file {
+ my($self,$lfile,$basename) = @_;
+ my($cksum);
+ my $fh = new IO::File;
+ local($/)=undef;
+ if (open $fh, $lfile){
+ my $eval = <$fh>;
+ close $fh;
+ my($comp) = Safe->new();
+ $cksum = $comp->reval($eval);
+ Carp::confess($@) if $@;
+ if ($cksum->{$basename}->{md5}) {
+ $self->debug("Found checksum for $basename: $cksum->{$basename}->{md5}\n") if $CPAN::DEBUG;
+ my $file = $self->{localfile};
+ my $pipe = "$CPAN::Config->{gzip} --decompress --stdout $self->{localfile}|";
+ if (
+ open($fh, $file) && $self->eq_MD5($fh,$cksum->{$basename}->{md5})
+ or
+ open($fh, $pipe) && $self->eq_MD5($fh,$cksum->{$basename}->{'md5-ungz'})
+ ){
+ print "Checksum for $file ok\n";
+ return $self->{MD5_STATUS}="OK";
+ } else {
+ die join(
+ "",
+ "\nChecksum mismatch for distribution file. Please investigate.\n\n",
+ $self->as_string,
+ $CPAN::META->instance('CPAN::Author',$self->{CPAN_USERID})->as_string,
+ "Please contact the author or your CPAN site admin"
+ );
+ }
+ close $fh if fileno($fh);
+ } else {
+ print "No md5 checksum for $basename in local $lfile\n";
+ return;
+ }
+ } else {
+ Carp::carp "Could not open $lfile for reading";
+ }
+}
+
+sub eq_MD5 {
+ my($self,$fh,$expectMD5) = @_;
+ my $md5 = new MD5;
+ $md5->addfile($fh);
+ my $hexdigest = $md5->hexdigest;
+ $hexdigest eq $expectMD5;
+}
+
+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 make {
+ my($self) = @_;
+ $self->debug($self->id) if $CPAN::DEBUG;
+ print "Running make\n";
+ $self->get;
+ if ($CPAN::META->hasMD5) {
+ $self->verifyMD5;
+ }
+ 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";
+ print join "", map {" $_\n"} @e and return if @e;
+ }
+ print "\n CPAN: 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) = $^X =~ /^\.\// ? "$CPAN::Cwd/$^X" : $^X; # XXX subclassing folks, forgive me!
+ $system = "$perl Makefile.PL $CPAN::Config->{makepl_arg}";
+ }
+ if (system($system)!=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) {
+ print " $system -- OK\n";
+ $self->{'make'} = "YES";
+ } else {
+ $self->{writemakefile} = "YES";
+ $self->{'make'} = "NO";
+ print " $system -- NOT OK\n";
+ }
+}
+
+sub test {
+ my($self) = @_;
+ $self->make;
+ return if $CPAN::Signal;
+ print "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";
+ print 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) {
+ print " $system -- OK\n";
+ $self->{'make_test'} = "YES";
+ } else {
+ $self->{'make_test'} = "NO";
+ print " $system -- NOT OK\n";
+ }
+}
+
+sub clean {
+ my($self) = @_;
+ print "Running make clean\n";
+ EXCUSE: {
+ my @e;
+ exists $self->{'build_dir'} or push @e, "Has no own directory";
+ print 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) {
+ print " $system -- OK\n";
+ $self->force;
+ } else {
+ # Hmmm, what to do if make clean failed?
+ }
+}
+
+sub install {
+ my($self) = @_;
+ $self->test;
+ return if $CPAN::Signal;
+ print "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";
+ exists $self->{'install'} and push @e, $self->{'install'} eq "YES" ? "Already done" : "Already tried without success";
+ print 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) = IO::File->new("$system 2>&1 |");
+ my($makeout) = "";
+ while (<$pipe>){
+ print;
+ $makeout .= $_;
+ }
+ $pipe->close;
+ if ($?==0) {
+ print " $system -- OK\n";
+ $self->{'install'} = "YES";
+ } else {
+ $self->{'install'} = "NO";
+ print " $system -- NOT OK\n";
+ if ($makeout =~ /permission/s && $> > 0) {
+ print " You may have to su to root to install the package\n";
+ }
+ }
+}
+
+sub dir {
+ shift->{'build_dir'};
+}
+
+package CPAN::Bundle;
+use vars qw(@ISA);
+@ISA = qw(CPAN::Debug CPAN::InfoObj CPAN::Module);
+
+sub as_string {
+ my($self) = @_;
+ $self->contains;
+ return $self->SUPER::as_string;
+}
+
+sub contains {
+ my($self) = @_;
+ my($parsefile) = $self->inst_file;
+ unless ($parsefile) {
+ # Try to get at it in the cpan directory
+ $self->debug("no parsefile") if $CPAN::DEBUG;
+ my $dist = $CPAN::META->instance('CPAN::Distribution',$self->{'CPAN_FILE'});
+ $self->debug($dist->as_string) if $CPAN::DEBUG;
+ $dist->get;
+ $self->debug($dist->as_string) if $CPAN::DEBUG;
+ my($todir) = $CPAN::META->catdir($CPAN::Config->{'cpan_home'},"Bundle");
+ File::Path::mkpath($todir);
+ my($me,$from,$to);
+ ($me = $self->id) =~ s/.*://;
+ $from = $CPAN::META->catfile($dist->{'build_dir'},"$me.pm");
+ $to = $CPAN::META->catfile($todir,"$me.pm");
+ rename($from, $to) or Carp::croak("Couldn't rename $from to $to: $!");
+ $parsefile = $to;
+ }
+ my @result;
+ my $fh = new IO::File;
+ local $/ = "\n";
+ open($fh,$parsefile) or die "Could not open '$parsefile': $!";
+ my $inpod = 0;
+ 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} = [@result];
+ @result;
+}
+
+sub inst_file {
+ my($self) = @_;
+ my($me,$inst_file);
+ ($me = $self->id) =~ s/.*://;
+ $inst_file = $CPAN::META->catfile($CPAN::Config->{'cpan_home'},"Bundle", "$me.pm");
+ 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 rematein {
+ my($self,$meth) = @_;
+ $self->debug("self[$self] meth[$meth]") if $CPAN::DEBUG;
+ my($s);
+ for $s ($self->contains) {
+ $CPAN::META->instance('CPAN::Module',$s)->$meth();
+ }
+}
+
+sub install { shift->rematein('install',@_); }
+sub clean { shift->rematein('clean',@_); }
+sub test { shift->rematein('test',@_); }
+sub make { shift->rematein('make',@_); }
+
+# XXX not yet implemented!
+sub readme {
+ my($self) = @_;
+ my($file) = $self->cpan_file or print("No File found for bundle ", $self->id, "\n"), return;
+ $self->debug("self[$self] file[$file]") if $CPAN::DEBUG;
+ $CPAN::META->instance('CPAN::Distribution',$file)->readme;
+# CPAN::FTP->localize("authors/id/$file",$index_wanted); # XXX
+}
+
+package CPAN::Module;
+use vars qw(@ISA);
+@ISA = qw(CPAN::Debug CPAN::InfoObj);
+
+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 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'}){
+ push @m, sprintf(
+ $sprintf2,
+ 'CPAN_USERID',
+ $userid,
+ $CPAN::META->instance(CPAN::Author,$userid)->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 = IO::File->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;
+ }
+ push @m, sprintf $sprintf, 'MANPAGE', $self->{MANPAGE} if $self->{MANPAGE};
+ 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_file {
+ my $self = shift;
+ CPAN->debug($self->id) if $CPAN::DEBUG;
+ unless (defined $self->{'CPAN_FILE'}) {
+ CPAN::Index->reload;
+ }
+ if (defined $self->{'CPAN_FILE'}){
+ return $self->{'CPAN_FILE'};
+ } elsif (defined $self->{'userid'}) {
+ return "Contact Author ".$self->{'userid'}."=".$CPAN::META->instance(CPAN::Author,$self->{'userid'})->fullname
+ } else {
+ return "N/A";
+ }
+}
+
+*name = \&cpan_file;
+
+sub cpan_version { shift->{'CPAN_VERSION'} }
+
+sub force {
+ my($self) = @_;
+ $self->{'force_update'}++;
+}
+
+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 readme { shift->rematein('readme') }
+sub make { shift->rematein('make') }
+sub clean { shift->rematein('clean') }
+sub test { shift->rematein('test') }
+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 ($inst_file && $have >= $latest && not exists $self->{'force_update'}) {
+ print $self->id, " is up to date.\n";
+ } else {
+ $doit = 1;
+ }
+ $self->rematein('install') if $doit;
+}
+
+sub inst_file {
+ my($self) = @_;
+ my($dir,@packpath);
+ @packpath = split /::/, $self->{ID};
+ $packpath[-1] .= ".pm";
+ foreach $dir (@INC) {
+ my $pmfile = CPAN->catfile($dir,@packpath);
+ if (-f $pmfile){
+ return $pmfile;
+ }
+ }
+}
+
+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 = CPAN->catfile($dir,'auto',@packpath);
+ if (-f $xsfile){
+ return $xsfile;
+ }
+ }
+}
+
+sub inst_version {
+ my($self) = @_;
+ my $parsefile = $self->inst_file or return 0;
+ my $have = MY->parse_version($parsefile);
+ $have ||= 0;
+ $have =~ s/\s+//g;
+ $have ||= 0;
+ $have;
+}
+
+package CPAN::CacheMgr;
+use vars qw($Du @ISA);
+@ISA=qw(CPAN::Debug CPAN::InfoObj);
+use File::Find;
+
+sub as_string {
+ eval { require Data::Dumper };
+ if ($@) {
+ return shift->SUPER::as_string;
+ } else {
+ return Data::Dumper::Dumper(shift);
+ }
+}
+
+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 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 dir {
+ shift->{ID};
+}
+
+sub entries {
+ my($self,$dir) = @_;
+ $dir ||= $self->{ID};
+ my($cwd) = Cwd::cwd();
+ 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, $CPAN::META->catfile($dir,$_);
+ } elsif (-d _) {
+ push @entries, $CPAN::META->catdir($dir,$_);
+ } else {
+ print STDERR "Warning: weird direntry in $dir: $_\n";
+ }
+ }
+ chdir $cwd or Carp::croak("Can't chdir to $cwd: $!");
+ sort {-M $b <=> -M $a} @entries;
+}
+
+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 defined $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'} ) {
+ printf "...Hold on a sec... CPAN's cleaning the cache: %.2f MB > %.2f MB\n",
+ $self->{DU}, $self->{'MAX'};
+ $self->clean_cache;
+ } else {
+ $self->debug("NOT have to clean the cache: $self->{DU} <= $self->{'MAX'}") if $CPAN::DEBUG;
+ $self->debug($self->as_string) if $CPAN::DEBUG;
+ }
+ $self->{DU};
+}
+
+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 new {
+ my $class = shift;
+ 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->debug("Have to check size $e") if $CPAN::DEBUG;
+ $self->disk_usage($e);
+ }
+ $self;
+}
+
+package CPAN::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/.*:://;
+# print "caller[$caller]func[$func]line[$line]rest[@rest]\n";
+# print "CPAN::DEBUG{caller}[$CPAN::DEBUG{$caller}]CPAN::DEBUG[$CPAN::DEBUG]\n";
+ if ($CPAN::DEBUG{$caller} & $CPAN::DEBUG){
+ if (ref $arg) {
+ eval { require Data::Dumper };
+ if ($@) {
+ print $arg->as_string;
+ } else {
+ print Data::Dumper::Dumper($arg);
+ }
+ } else {
+ print "Debug($caller:$func,$line,@rest): $arg\n"
+ }
+ }
+}
+
+package CPAN::Config;
+import ExtUtils::MakeMaker 'neatvalue';
+use vars qw(%can);
+
+%can = (
+ 'commit' => "Commit changes to disk",
+ 'defaults' => "Reload defaults from disk",
+);
+
+sub edit {
+ my($class,@args) = @_;
+ return unless @args;
+ CPAN->debug("class[$class]args[@args]");
+ my($o,$str,$func,$args,$key_exists);
+ $o = shift @args;
+ if($can{$o}) {
+ $class->$o(@args);
+ return 1;
+ }
+ return unless exists $CPAN::Config->{$o};
+
+ if (ref($CPAN::Config->{$o}) eq ARRAY) {
+ if (@args) {
+ $func = shift @args;
+ # 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;
+ } else {
+ $CPAN::Config->{$o} = [@args];
+ }
+ } else {
+ print qq{ $o }, neatvalue($CPAN::Config->{$o}), qq{
+Usage:
+ o conf $o [shift|pop]
+or
+ o conf $o [unshift|push|splice] <list>
+};
+ }
+ } else {
+ if (@args) {
+ $CPAN::Config->{$o} = $args[0];
+ }
+ print " $o ";
+ print defined $CPAN::Config->{$o} ? $CPAN::Config->{$o} : "UNDEFINED";
+ }
+}
+
+sub commit {
+ my($self, $configpm) = @_;
+ my $mode;
+ # mkpath!?
+
+ my($fh) = IO::File->new;
+ $configpm ||= cfile();
+ if (-f $configpm) {
+ $mode = (stat $configpm)[2];
+ if ($mode && ! -w _) {
+ print "$configpm is not writable\n" and return;
+ }
+ #chmod 0644, $configpm; #?
+ }
+
+ 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";
+ open $fh, ">$configpm" or warn "Couldn't open >$configpm: $!";
+ print $fh qq[$msg\$CPAN::Config = \{\n];
+ foreach (sort keys %$CPAN::Config) {
+ print $fh " '$_' => ", ExtUtils::MakeMaker::neatvalue($CPAN::Config->{$_}), ",\n";
+ }
+
+ print $fh "};\n1;\n__END__\n";
+ close $fh;
+
+ #$mode = 0444 | ( $mode & 0111 ? 0111 : 0 );
+ #chmod $mode, $configpm;
+ $self->defaults;
+ print "commit: wrote $configpm\n";
+ 1;
+}
+
+*default = \&defaults;
+sub defaults {
+ my($self) = @_;
+ $self->unload;
+ $self->load;
+ 1;
+}
+
+my $dot_cpan;
+sub load {
+ my($self) = @_;
+ eval {require CPAN::Config;}; # We eval, because of some MakeMaker problems
+ unshift @INC, $CPAN::META->catdir($ENV{HOME},".cpan") unless $dot_cpan++;
+ eval {require CPAN::MyConfig;}; # where you can override system wide settings
+ unless ( $self->load_succeeded ) {
+ require CPAN::FirstTime;
+ my($configpm,$fh);
+ if (defined $INC{"CPAN/Config.pm"} && -w $INC{"CPAN/Config.pm"}) {
+ $configpm = $INC{"CPAN/Config.pm"};
+ } elsif (defined $INC{"CPAN/MyConfig.pm"} && -w $INC{"CPAN/MyConfig.pm"}) {
+ $configpm = $INC{"CPAN/MyConfig.pm"};
+ } else {
+ my($path_to_cpan) = File::Basename::dirname($INC{"CPAN.pm"});
+ my($configpmdir) = MY->catdir($path_to_cpan,"CPAN");
+ my($configpmtest) = MY->catfile($configpmdir,"Config.pm");
+ if (-d $configpmdir || File::Path::mkpath($configpmdir)) {
+#_#_# following code dumped core on me with 5.003_11, a.k.
+#_#_# $fh = IO::File->new;
+#_#_# if ($fh->open(">$configpmtest")) {
+#_#_# $fh->print("1;\n");
+#_#_# $configpm = $configpmtest;
+#_#_# }
+ if (-w $configpmtest or -w $configpmdir) {
+ $configpm = $configpmtest;
+ }
+ }
+ unless ($configpm) {
+ $configpmdir = MY->catdir($ENV{HOME},".cpan","CPAN");
+ File::Path::mkpath($configpmdir);
+ $configpmtest = MY->catfile($configpmdir,"MyConfig.pm");
+ if (-w $configpmtest or -w $configpmdir) {
+ $configpm = $configpmtest;
+ } else {
+ warn "WARNING: CPAN.pm is unable to create a configuration file.\n";
+ }
+ }
+ }
+ warn "Calling CPAN::FirstTime::init($configpm)";
+ CPAN::FirstTime::init($configpm);
+ }
+}
+
+sub load_succeeded {
+ my($miss) = 0;
+ 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
+ )) {
+ $miss++ unless defined $CPAN::Config->{$_}; # we want them all
+ }
+ return !$miss;
+}
+
+sub unload {
+ delete $INC{'CPAN/MyConfig.pm'};
+ delete $INC{'CPAN/Config.pm'};
+}
+
+sub cfile {
+ $INC{'CPAN/MyConfig.pm'} || $INC{'CPAN/Config.pm'};
+}
+
+*h = \&help;
+sub help {
+ print <<EOF;
+Known options:
+ defaults reload default config values from disk
+ commit commit session changes to disk
+
+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/
+
+EOF
+ undef; #don't reprint CPAN::Config
+}
+
+sub complete {
+ my($word,$line,$pos) = @_;
+ $word ||= "";
+ my(@words) = split " ", $line;
+ my(@o_conf) = (sort keys %CPAN::Config::can, sort keys %$CPAN::Config);
+ return (@o_conf) unless @words>2;
+ if($words[2] =~ /->(.*)/) {
+ my $meth = $1;
+ my(@methods) = qw(shift unshift push pop splice);
+ return @methods unless $meth;
+ return sort grep /^\Q$meth\E/, @methods;
+ }
+ return sort grep /^\Q$word\E/, @o_conf;
+}
+
+1;
+
+=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, bundle, clean, expand, install, make, recompile, test
+
+=head1 DESCRIPTION
+
+The CPAN module is designed to automate the building and installing of
+perl modules and extensions including the searching and fetching 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 in a simple FIFO 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.
+
+=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 on whitespace, 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.
+
+If you do not enter the shell, most of the available shell commands
+are both available as methods (C<CPAN::Shell-E<gt>install(...)>) and as
+functions in the calling package (C<install(...)>).
+
+=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 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.
+
+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 one 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. The bundle() function in the CPAN module simply
+parses the module that defines the bundle and returns the module names
+that are listed in the described CONTENTS section.
+
+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 autobundle
+
+autobundle() writes a bundle file into the directory
+$CPAN::Config->{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 Pragma: force
+
+Normally CPAN keeps track of what it has done within the current
+session and doesn't try to build a package a second time regardless if
+it succeeded or not. The 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
+ [...]
+
+=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 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.
+
+=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
+ 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. Whitespace is used to
+determine the arguments.
+
+=back
+
+=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 stong 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 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 Prerequisites
+
+If you have a local mirror of CPAN and can access all files with
+"file:" URLs, then you only need perl5.003 to run this
+module. Otherwise you need Net::FTP intalled. LWP may be required for
+non-UNIX systems or if your nearest CPAN site is associated with an
+URL that is not C<ftp:>.
+
+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
+
+=head1 AUTHOR
+
+Andreas König E<lt>a.koenig@mind.deE<gt>
+
+=head1 SEE ALSO
+
+perl(1), CPAN::Nox(3)
+
+=cut
+
diff --git a/lib/CPAN/FirstTime.pm b/lib/CPAN/FirstTime.pm
new file mode 100644
index 0000000000..9cac32d0ac
--- /dev/null
+++ b/lib/CPAN/FirstTime.pm
@@ -0,0 +1,284 @@
+package CPAN::Mirrored::By;
+
+sub new {
+ my($self,@arg) = @_;
+ bless [@arg], $self;
+}
+sub con { shift->[0] }
+sub cou { shift->[1] }
+sub url { shift->[2] }
+
+package CPAN::FirstTime;
+
+use strict;
+use ExtUtils::MakeMaker qw(prompt);
+require File::Path;
+use vars qw($VERSION);
+$VERSION = "1.00";
+
+=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 ||= {};
+
+ my($ans,$default,$local,$cont,$url,$expected_size);
+
+ 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;
+ $ans = prompt("CPAN build and cache directory?",$default);
+ File::Path::mkpath($ans); # dies if it can't
+ $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");
+
+ 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;
+
+ 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.
+
+};
+
+ my(@path) = split($Config{path_sep},$ENV{PATH});
+ my $prog;
+ for $prog (qw/gzip tar unzip make/){
+ my $path = $CPAN::Config->{$prog} || find_exe($prog,[@path]) || $prog;
+ $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) || $path;
+ $CPAN::Config->{'pager'} = $ans;
+ print qq{
+
+Every Makefile.PL is run by perl in a seperate 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.
+
+};
+
+ $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);
+
+ $local = 'MIRRORED.BY';
+ 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' command.
+
+}
+ } elsif (-f $local) { # if they really have a MIRRORED.BY in the
+ # current directory, we can't help
+ read_mirrored_by($local);
+ } else {
+ $CPAN::Config->{urllist} ||= [];
+ while (! @{$CPAN::Config->{urllist}}) {
+ print qq{
+We need to know the URL of your favorite CPAN site.
+Please enter it here: };
+ chop($_ = <>);
+ s/\s//g;
+ push @{$CPAN::Config->{urllist}}, $_ if $_;
+ }
+ }
+
+ # We don't ask that now, it will be noticed in time....
+ $CPAN::Config->{'inhibit_startup_message'} = 0;
+
+ print "\n\n";
+ CPAN::Config->commit($configpm);
+}
+
+sub find_exe {
+ my($exe,$path) = @_;
+ my($dir,$MY);
+ $MY = {};
+ bless $MY, 'MY';
+ for $dir (@$path) {
+ my $abs = $MY->catfile($dir,$exe);
+ if ($MY->maybe_command($abs)) {
+ return $abs;
+ }
+ }
+}
+
+sub read_mirrored_by {
+ my($local) = @_;
+ my(%all,$url,$expected_size,$default,$ans,$host,$dst,$country,$continent,@location);
+ open FH, $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="";
+ }
+ $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);
+
+ while () {
+ my $pipe = -t *STDIN ? "| $CPAN::Config->{'pager'}" : ">/dev/null";
+ my(@valid,$previous_best);
+ open FH, $pipe;
+ {
+ my($cont,$country,$url,$item);
+ my(@cont) = sort keys %all;
+ for $cont (@cont) {
+ print FH " $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};
+ print FH $t;
+ }
+ }
+ }
+ }
+ close FH;
+ $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->con,$this->cou,$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/lib/CPAN/Nox.pm b/lib/CPAN/Nox.pm
new file mode 100644
index 0000000000..b0b70fec04
--- /dev/null
+++ b/lib/CPAN/Nox.pm
@@ -0,0 +1,33 @@
+BEGIN{$CPAN::Suppress_readline++;}
+
+use CPAN;
+
+$CPAN::META->hasMD5(0);
+$CPAN::META->hasLWP(0);
+@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/lib/Carp.pm b/lib/Carp.pm
index 5de8f83d14..1a1b79ea3f 100644
--- a/lib/Carp.pm
+++ b/lib/Carp.pm
@@ -29,6 +29,8 @@ not where carp() was called.
$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;
@@ -38,8 +40,10 @@ sub longmess {
my $error = shift;
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 {
@@ -56,6 +60,21 @@ 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) {
+ s/'/\\'/g;
+ substr($_,$MaxArgLen) = '...' if $MaxArgLen and $MaxArgLen < length;
+ s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+ }
+ $sub .= '(' . join(', ', @a) . ')';
+ }
$mess .= "\t$sub " if $error eq "called";
$mess .= "$error at $file line $line\n";
}
diff --git a/lib/Class/Template.pm b/lib/Class/Template.pm
new file mode 100644
index 0000000000..e45a5d3f17
--- /dev/null
+++ b/lib/Class/Template.pm
@@ -0,0 +1,241 @@
+package Class::Template;
+require 5.000;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT = qw(members struct);
+use strict;
+
+# 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.
+
+=head1 NAME
+
+Class::Template - struct/member template builder
+
+=head1 EXAMPLES
+
+=item * Example 1
+
+ use Class::Template;
+
+ struct( rusage => {
+ ru_utime => timeval,
+ ru_stime => timeval,
+ });
+
+ struct( timeval => [
+ tv_secs => '$',
+ tv_usecs => '$',
+ ]);
+
+ my $s = new rusage;
+
+=item * Example 2
+
+ package OBJ;
+ use Class::Template;
+
+ members OBJ {
+ 'a' => '$',
+ 'b' => '$',
+ };
+
+ members OBJ2 {
+ 'd' => '@',
+ 'c' => '$',
+ };
+
+ package OBJ2; @ISA = (OBJ);
+
+ sub new {
+ my $r = InitMembers( &OBJ::InitMembers() );
+ bless $r;
+ }
+
+=head1 NOTES
+
+Use '%' if the member should point to an anonymous hash. Use '@' if the
+member should point to an anonymous array.
+
+When using % and @ the method requires one argument for the key or index
+into the hash or array.
+
+Prefix the %, @, or $ with '*' to indicate you want to retrieve pointers to
+the values rather than the values themselves.
+
+=cut
+
+Var: {
+ $Class::Template::print = 0;
+ sub printem { $Class::Template::print++ }
+}
+
+
+sub struct {
+ my( $struct, $ref ) = @_;
+ my @methods = ();
+ my %refs = ();
+ my %arrays = ();
+ my %hashes = ();
+ my $out = '';
+
+ $out = "{\n package $struct;\n sub new {\n";
+ parse_fields( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes, 0 );
+ $out .= " bless \$r;\n }\n";
+ build_methods( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes );
+ $out .= "}\n1;\n";
+
+ ( $Class::Template::print ) ? print( $out ) : eval $out;
+}
+
+sub members {
+ my( $pkg, $ref ) = @_;
+ my @methods = ();
+ my %refs = ();
+ my %arrays = ();
+ my %hashes = ();
+ my $out = '';
+
+ $out = "{\n package $pkg;\n sub InitMembers {\n";
+ parse_fields( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes, 1 );
+ $out .= " bless \$r;\n }\n";
+ build_methods( $ref, \$out, \@methods, \%refs, \%arrays, \%hashes );
+ $out .= "}\n1;\n";
+
+ ( $Class::Template::print ) ? print( $out ) : eval $out;
+}
+
+
+sub parse_fields {
+ my( $ref, $out, $methods, $refs, $arrays, $hashes, $member ) = @_;
+ my $type = ref $ref;
+ my @keys;
+ my $val;
+ my $cnt = 0;
+ my $idx = 0;
+ my( $cmt, $n );
+
+ if( $type eq 'HASH' ){
+ if( $member ){
+ $$out .= " my(\$r) = \@_ ? shift : {};\n";
+ }
+ else{
+ $$out .= " my(\$r) = {};\n";
+ }
+ @keys = keys %$ref;
+ foreach (@keys){
+ $val = $ref->{$_};
+ if( $val =~ /^\*(.)/ ){
+ $refs->{$_}++;
+ $val = $1;
+ }
+ if( $val eq '@' ){
+ $$out .= " \$r->{'$_'} = [];\n";
+ $arrays->{$_}++;
+ }
+ elsif( $val eq '%' ){
+ $$out .= " \$r->{'$_'} = {};\n";
+ $hashes->{$_}++;
+ }
+ elsif( $val ne '$' ){
+ $$out .= " \$r->{'$_'} = \&${val}::new();\n";
+ }
+ else{
+ $$out .= " \$r->{'$_'} = undef;\n";
+ }
+ push( @$methods, $_ );
+ }
+ }
+ elsif( $type eq 'ARRAY' ){
+ if( $member ){
+ $$out .= " my(\$r) = \@_ ? shift : [];\n";
+ }
+ else{
+ $$out .= " my(\$r) = [];\n";
+ }
+ while( $idx < @$ref ){
+ $n = $ref->[$idx];
+ push( @$methods, $n );
+ $val = $ref->[$idx+1];
+ $cmt = "# $n";
+ if( $val =~ /^\*(.)/ ){
+ $refs->{$n}++;
+ $val = $1;
+ }
+ if( $val eq '@' ){
+ $$out .= " \$r->[$cnt] = []; $cmt\n";
+ $arrays->{$n}++;
+ }
+ elsif( $val eq '%' ){
+ $$out .= " \$r->[$cnt] = {}; $cmt\n";
+ $hashes->{$n}++;
+ }
+ elsif( $val ne '$' ){
+ $$out .= " \$r->[$cnt] = \&${val}::new();\n";
+ }
+ else{
+ $$out .= " \$r->[$cnt] = undef; $cmt\n";
+ }
+ ++$cnt;
+ $idx += 2;
+ }
+ }
+}
+
+
+sub build_methods {
+ my( $ref, $out, $methods, $refs, $arrays, $hashes ) = @_;
+ my $type = ref $ref;
+ my $elem = '';
+ my $cnt = 0;
+ my( $pre, $pst, $cmt, $idx );
+
+ foreach (@$methods){
+ $pre = $pst = $cmt = $idx = '';
+ if( defined $refs->{$_} ){
+ $pre = "\\(";
+ $pst = ")";
+ $cmt = " # returns ref";
+ }
+ $$out .= " sub $_ {$cmt\n my \$r = shift;\n";
+ if( $type eq 'ARRAY' ){
+ $elem = "[$cnt]";
+ ++$cnt;
+ }
+ elsif( $type eq 'HASH' ){
+ $elem = "{'$_'}";
+ }
+ if( defined $arrays->{$_} ){
+ $$out .= " my \$i;\n";
+ $$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
+ $idx = "->[\$i]";
+ }
+ elsif( defined $hashes->{$_} ){
+ $$out .= " my \$i;\n";
+ $$out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n";
+ $idx = "->{\$i}";
+ }
+ $$out .= " \@_ ? (\$r->$elem$idx = shift) : $pre\$r->$elem$idx$pst;\n";
+ $$out .= " }\n";
+ }
+}
+
+1;
diff --git a/lib/Cwd.pm b/lib/Cwd.pm
index 1512d7f212..d7a4875574 100644
--- a/lib/Cwd.pm
+++ b/lib/Cwd.pm
@@ -38,8 +38,8 @@ the trailing line terminator). It is recommended that cwd (or another
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
@@ -108,7 +108,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);
@@ -172,7 +172,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) {
@@ -237,6 +237,13 @@ sub _os2_cwd {
return $ENV{'PWD'};
}
+sub _msdos_cwd {
+ $ENV{'PWD'} = `command /c cd`;
+ chop $ENV{'PWD'};
+ $ENV{'PWD'} =~ s:\\:/:g ;
+ return $ENV{'PWD'};
+}
+
my($oldw) = $^W;
$^W = 0; # assignments trigger 'subroutine redefined' warning
if ($^O eq 'VMS') {
@@ -254,11 +261,17 @@ elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
*fastgetcwd = \&_NT_cwd;
}
elsif ($^O eq 'os2') {
-
- *cwd = \&_os2_cwd;
- *getcwd = \&_os2_cwd;
- *fastgetcwd = \&_os2_cwd;
- *fastcwd = \&_os2_cwd;
+ # sys_cwd may keep the builtin command
+ *cwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *getcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *fastgetcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+ *fastcwd = defined &sys_cwd ? \&sys_cwd : \&_os2_cwd;
+}
+elsif ($^O eq 'msdos') {
+ *cwd = \&_msdos_cwd;
+ *getcwd = \&_msdos_cwd;
+ *fastgetcwd = \&_msdos_cwd;
+ *fastcwd = \&_msdos_cwd;
}
$^W = $oldw;
diff --git a/lib/Devel/SelfStubber.pm b/lib/Devel/SelfStubber.pm
index fc7ee4b511..7bb38f6957 100644
--- a/lib/Devel/SelfStubber.pm
+++ b/lib/Devel/SelfStubber.pm
@@ -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/lib/Env.pm b/lib/Env.pm
index 0e790754a8..63beb07508 100644
--- a/lib/Env.pm
+++ b/lib/Env.pm
@@ -39,7 +39,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
diff --git a/lib/Exporter.pm b/lib/Exporter.pm
index e374414505..fd95a7efef 100644
--- a/lib/Exporter.pm
+++ b/lib/Exporter.pm
@@ -264,7 +264,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.
@@ -328,7 +328,7 @@ into modules.
=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.
diff --git a/lib/ExtUtils/Embed.pm b/lib/ExtUtils/Embed.pm
index 45ccbe6a11..fb2664c86f 100644
--- a/lib/ExtUtils/Embed.pm
+++ b/lib/ExtUtils/Embed.pm
@@ -1,4 +1,4 @@
-# $Id: Embed.pm,v 1.17 1996/07/02 13:48:17 dougm Exp $
+# $Id: Embed.pm,v 1.21 1996/11/29 17:26:23 dougm Exp $
require 5.002;
package ExtUtils::Embed;
@@ -17,7 +17,7 @@ use vars qw(@ISA @EXPORT $VERSION
);
use strict;
-$VERSION = sprintf("%d.%02d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", q$Revision: 1.21 $ =~ /(\d+)\.(\d+)/);
#for the namespace change
$Devel::embed::VERSION = "99.99";
@@ -201,7 +201,7 @@ sub ldopts {
my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) =
$MM->ext(join ' ',
- $MM->catdir("-L$Config{archlib}", "CORE"), " -lperl",
+ $MM->catdir("-L$Config{archlibexp}", "CORE"), " -lperl",
@potential_libs);
my $ld_or_bs = $bsloadlibs || $ldloadlibs;
@@ -222,7 +222,7 @@ sub ccdlflags {
}
sub perl_inc {
- print " -I $Config{archlib}/CORE ";
+ print " -I$Config{archlibexp}/CORE ";
}
sub ccopts {
@@ -266,19 +266,19 @@ functions while building your application.
ExtUtils::Embed exports the following functions:
-L<xsinit()>, L<ldopts()>, L<ccopts()>, L<perl_inc()>, L<ccflags()>,
-L<ccdlflags()>, L<xsi_header()>, L<xsi_protos()>, L<xsi_body()>
+xsinit(), ldopts(), ccopts(), perl_inc(), ccflags(),
+ccdlflags(), xsi_header(), xsi_protos(), xsi_body()
=head1 FUNCTIONS
=item xsinit()
-Generate C/C++ code for the XS intializer function.
+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> <output filename> (Defaults to B<perlxsi.c>)
+B<-o> E<lt>output filenameE<gt> (Defaults to B<perlxsi.c>)
B<-o STDOUT> will print to STDOUT.
@@ -340,7 +340,7 @@ B<-std>
Output arguments for linking the Perl library and any extensions linked
with the current Perl.
-B<-I> <path1:path2>
+B<-I> E<lt>path1:path2E<gt>
Search path for ModuleName.a archives.
Default path is B<@INC>.
@@ -355,7 +355,7 @@ 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<--> <list of linker args>
+B<--> E<lt>list of linker argsE<gt>
Additional linker arguments to be considered.
@@ -419,11 +419,11 @@ conflict, the additional arguments will be part of the output.
For including perl header files this function simply prints:
- -I $Config{archlib}/CORE
+ -I$Config{archlibexp}/CORE
So, rather than having to say:
- perl -MConfig -e 'print "-I $Config{archlib}/CORE"'
+ perl -MConfig -e 'print "-I$Config{archlibexp}/CORE"'
Just say:
@@ -456,18 +456,18 @@ B<xsinit()> uses the xsi_* functions to generate most of it's code.
=head1 EXAMPLES
For examples on how to use B<ExtUtils::Embed> for building C/C++ applications
-with embedded perl, see the eg/ directory and the I<perlembed> man page.
+with embedded perl, see the eg/ directory and L<perlembed>.
=head1 SEE ALSO
-the I<perlembed> man page
+L<perlembed>
=head1 AUTHOR
-Doug MacEachern <dougm@osf.org>
+Doug MacEachern E<lt>F<dougm@osf.org>E<gt>
-Based on ideas from Tim Bunce <Tim.Bunce@ig.co.uk> and
-B<minimod.pl> by Andreas Koenig <k@anna.in-berlin.de> and Tim Bunce.
+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/lib/ExtUtils/Install.pm b/lib/ExtUtils/Install.pm
index 45bd2d7b0e..dda132565f 100644
--- a/lib/ExtUtils/Install.pm
+++ b/lib/ExtUtils/Install.pm
@@ -1,7 +1,7 @@
package ExtUtils::Install;
-$VERSION = substr q$Revision: 1.12 $, 10;
-# $Id: Install.pm,v 1.12 1996/06/23 20:46:07 k Exp $
+$VERSION = substr q$Revision: 1.15 $, 10;
+# $Date: 1996/09/03 21:58:58 $
use Exporter;
use Carp ();
@@ -34,16 +34,9 @@ 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.
my(%hash) = %$hash;
- my(%pack, %write, $dir);
+ my(%pack, %write, $dir, $warn_permissions);
local(*DIR, *P);
for (qw/read write/) {
$pack{$_}=$hash{$_};
@@ -59,7 +52,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;
@@ -253,7 +247,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,8 +314,8 @@ 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.
@@ -334,4 +330,3 @@ the extension pm are autosplit. Second argument is the autosplit
directory.
=cut
-
diff --git a/lib/ExtUtils/Liblist.pm b/lib/ExtUtils/Liblist.pm
index 097203e188..eac7c13ad5 100644
--- a/lib/ExtUtils/Liblist.pm
+++ b/lib/ExtUtils/Liblist.pm
@@ -1,16 +1,19 @@
package ExtUtils::Liblist;
-
+use vars qw($VERSION);
# Broken out of MakeMaker from version 4.11
-$ExtUtils::Liblist::VERSION = substr q$Revision: 1.20 $, 10;
+$VERSION = substr q$Revision: 1.20 $, 10;
use Config;
use Cwd 'cwd';
use File::Basename;
-my $Config_libext = $Config{lib_ext} || ".a";
-
sub ext {
+ if ($^O eq 'VMS') { return &_vms_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
@@ -24,6 +27,8 @@ sub ext {
my($so) = $Config{'so'};
my($libs) = $Config{'libs'};
+ my $Config_libext = $Config{lib_ext} || ".a";
+
# compute $extralibs, $bsloadlibs and $ldloadlibs from
# $potential_libs
@@ -174,6 +179,136 @@ sub ext {
("@extralibs", "@bsloadlibs", "@ldloadlibs",join(":",@ld_run_path));
}
+
+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'; }
+
+ print STDOUT "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) {
+ print STDOUT "Skipping nonexistent Directory $dir\n" if $verbose > 1;
+ $dir = '';
+ next;
+ }
+ print STDOUT "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);
+ print STDOUT "Looking for $lib\n" if $verbose;
+ foreach $variant (@variants) {
+ foreach $dir (@dirs) {
+ my($type);
+
+ $name = "$dir$variant";
+ print "\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) {
+ print STDOUT "Warning (will try anyway): Plain object file $test found in library list\n";
+ $type = 'obj';
+ }
+ else {
+ print STDOUT "Warning (will try anyway): 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')))) {
+ print STDOUT "Warning (will try anyway): 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 $@;
+ print STDOUT "\tFound as $name (really $test), type $type\n" if $verbose > 1;
+ next LIB;
+ }
+ }
+ print STDOUT "Warning (will try anyway): 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);
+ print "Result: $lib\n" if $verbose;
+ wantarray ? ($lib, '', $lib, '') : $lib;
+}
+
1;
__END__
@@ -247,11 +382,55 @@ 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.
+
=head1 SEE ALSO
L<ExtUtils::MakeMaker>
=cut
-
-
diff --git a/lib/ExtUtils/MM_Unix.pm b/lib/ExtUtils/MM_Unix.pm
index 341786da91..ea4741f23d 100644
--- a/lib/ExtUtils/MM_Unix.pm
+++ b/lib/ExtUtils/MM_Unix.pm
@@ -1,12 +1,15 @@
package ExtUtils::MM_Unix;
-$VERSION = substr q$Revision: 1.105 $, 10;
-# $Id: MM_Unix.pm,v 1.105 1996/07/08 20:51:18 k Exp k $
-
-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
+ $Verbose %pm %static $Xsubpp_Version);
+
+$VERSION = substr q$Revision: 1.107 $, 10;
+# $Id: MM_Unix.pm,v 1.107 1996/09/03 20:53:39 k Exp $
Exporter::import('ExtUtils::MakeMaker',
qw( $Verbose &neatvalue));
@@ -40,8 +43,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
@@ -58,7 +61,7 @@ sections and complain loudly to the makemaker mailing list.
Not all of the methods below are overridable in a
Makefile.PL. Overridable methods are marked as (o). All methods are
overridable by a platform specific MM_*.pm file (See
-L<ExtUtils::MM_VMS>) and L<ExtUtils::MM_OS2>).
+L<ExtUtils::MM_VMS> and L<ExtUtils::MM_OS2>).
=head2 Preloaded methods
@@ -250,11 +253,13 @@ sub c_o {
my(@m);
push @m, '
.c$(OBJ_EXT):
- $(CCCMD) $(MAB) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
-
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
+';
+ push @m, '
.C$(OBJ_EXT):
$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.C
-
+' if $^O ne 'os2'; # Case-specific
+ push @m, '
.cpp$(OBJ_EXT):
$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.cpp
@@ -565,13 +570,16 @@ makemakerdflt: all
# 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->{INST_LIBDIR}
-INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR}
+INST_LIBDIR = }. $self->catdir('$(INST_LIB)',@parentdir) .q{
+INST_ARCHLIBDIR = }. $self->catdir('$(INST_ARCHLIB)',@parentdir) .q{
-INST_AUTODIR = $self->{INST_AUTODIR}
-INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR}
+INST_AUTODIR = }. $self->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{
+INST_ARCHAUTODIR = }. $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{
};
if ($self->has_link_code()) {
@@ -989,7 +997,7 @@ $(INST_DYNAMIC): $(OBJECT) $(MYEXTLIB) $(BOOTSTRAP) $(INST_ARCHAUTODIR)/.exists
}
$ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf');
push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ $(LDDLFLAGS) '.$ldfrom.
- ' $(OTHERLDFLAGS) $(MAB) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)');
+ ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)');
push @m, '
$(CHMOD) 755 $@
';
@@ -1024,7 +1032,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
@@ -1052,7 +1060,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
@@ -1063,9 +1071,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";
}
}
}
@@ -1147,8 +1158,8 @@ sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc)
foreach $name ($self->lsdir($self->curdir)){
next if $name eq $self->curdir or $name eq $self->updir or $ignore{$name};
next unless $self->libscan($name);
- next if -l $name; # We do not support symlinks at all
if (-d $name){
+ next if -l $name; # We do not support symlinks at all
$dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL"));
} elsif ($name =~ /\.xs$/){
my($c); ($c = $name) =~ s/\.xs$/.c/;
@@ -1365,14 +1376,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 {
@@ -1657,7 +1665,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}} ){
@@ -1693,7 +1701,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";
@@ -1767,7 +1775,7 @@ pure_site_install ::
doc_perl_install ::
}.$self->{NOECHO}.q{$(DOC_INSTALL) \
- "$(NAME)" \
+ "Module" "$(NAME)" \
"installed into" "$(INSTALLPRIVLIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
@@ -1776,7 +1784,7 @@ doc_perl_install ::
doc_site_install ::
}.$self->{NOECHO}.q{$(DOC_INSTALL) \
- "Module $(NAME)" \
+ "Module" "$(NAME)" \
"installed into" "$(INSTALLSITELIB)" \
LINKTYPE "$(LINKTYPE)" \
VERSION "$(VERSION)" \
@@ -1915,6 +1923,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 {
@@ -1963,7 +1975,8 @@ $(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...
@@ -1978,6 +1991,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;
@@ -2098,7 +2113,7 @@ $tmp/perlmain\$(OBJ_EXT): $tmp/perlmain.c
$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 $@
+ writemain(grep s#.*/auto/##, qw|$(MAP_STATIC)|)' > $@t && mv $@t $@
};
@@ -2106,7 +2121,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)" \
@@ -2325,13 +2340,17 @@ sub parse_version {
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;
+ my $eval = qq{
+ package ExtUtils::MakeMaker::_version;
+ no strict;
+
+ \$$1=undef; do {
+ $_
+ }; \$$1
+ };
+ local($^W) = 0;
+ $result = eval($eval) || 0;
die "Could not eval '$eval' in $parsefile: $@" if $@;
- $result = $ {$ExtUtils::MakeMaker::module_version_variable} || 0;
last;
}
close FH;
@@ -2351,12 +2370,14 @@ sub pasthru {
my(@m,$key);
my(@pasthru);
+ my($sep) = $Is_VMS ? ',' : '';
+ $sep .= "\\\n\t";
foreach $key (qw(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;
}
@@ -2438,7 +2459,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
@@ -2468,7 +2489,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
@@ -2609,14 +2630,14 @@ sub static_lib {
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{ $(RM_RF) $@
- $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@
+q{ $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@
}.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld
$(CHMOD) 755 $@
};
@@ -2868,7 +2889,8 @@ 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";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";'
@@ -3110,7 +3132,7 @@ sub xs_o { # many makes are too dumb to use xs_c then c_o
'
.xs$(OBJ_EXT):
$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && mv xstmp.c $*.c
- $(CCCMD) $(MAB) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
+ $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
';
}
diff --git a/lib/ExtUtils/MM_VMS.pm b/lib/ExtUtils/MM_VMS.pm
index ad5e2ce0d9..13383e9411 100644
--- a/lib/ExtUtils/MM_VMS.pm
+++ b/lib/ExtUtils/MM_VMS.pm
@@ -6,7 +6,7 @@
# Author: Charles Bailey bailey@genetics.upenn.edu
package ExtUtils::MM_VMS;
-$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.36 (10-Jul-1996)';
+$ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.38 (19-Nov-1996)';
unshift @MM::ISA, 'ExtUtils::MM_VMS';
use Config;
@@ -102,6 +102,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;
}
@@ -160,6 +162,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.
@@ -192,6 +218,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;
@@ -202,7 +229,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;
@@ -266,6 +292,16 @@ 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(@_);
+}
+
+
=head2 SelfLoaded methods
Those methods which override default MM_Unix methods are marked
@@ -287,12 +323,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) {
@@ -323,10 +371,11 @@ invoke Perl images.
sub find_perl {
my($self, $ver, $names, $dirs, $trace) = @_;
my($name,$dir,$vmsfile,@sdirs,@snames,@cand);
+ my($inabs) = 0;
# Check in relative directories first, so we pick up the current
# version of Perl if we're running MakeMaker as part of the main build.
- @sdirs = sort { my($absa) = 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;
@@ -335,8 +384,15 @@ 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;
+ 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";
@@ -345,6 +401,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)); }
@@ -352,12 +416,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";
@@ -382,7 +452,7 @@ 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
+for DCL procedure. If this fails, checks F<Sys$System:> for an
executable file having the name specified. Finally, appends F<.Exe>
and checks again.
@@ -394,7 +464,7 @@ sub maybe_command {
return "$file.exe" if -x "$file.exe";
return "$file.com" if -x "$file.com";
if ($file !~ m![/:>\]]!) {
- my($shrfile) = 'Sys$Share:' . $file;
+ my($shrfile) = 'Sys$System:' . $file;
return $file if -x $shrfile && ! -d _;
return "$file.exe" if -x "$shrfile.exe";
}
@@ -427,7 +497,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
@@ -459,8 +529,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
@@ -525,7 +597,7 @@ sub constants {
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})));
@@ -619,12 +691,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}}),'
';
@@ -668,65 +740,14 @@ PERL_ARCHIVE = ',($ENV{'PERLSHR'} ? $ENV{'PERLSHR'} : 'Sys$Share:PerlShr.Exe'),'
$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
@@ -794,7 +815,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
@@ -948,8 +969,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
@@ -1042,7 +1063,7 @@ EQUALIZE_TIMESTAMP = \$(PERL) -we "open F,qq{>\$ARGV[1]};close F;utime(0,(stat(\
!. ($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]"
+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);"
!);
}
@@ -1247,7 +1268,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)
@@ -1390,8 +1425,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;
@@ -1408,9 +1442,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}}) {
@@ -1436,12 +1468,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}
+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;
@@ -1460,16 +1494,17 @@ 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
\$(NOECHO) \$(NOOP)
@@ -1737,11 +1772,11 @@ 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[
@@ -1761,7 +1796,7 @@ pure_install :: pure_$(INSTALLDIRS)_install
$(NOECHO) $(NOOP)
doc_install :: doc_$(INSTALLDIRS)_install
- $(NOECHO) Write Sys$Output "Appending installation info to $(INST_ARCHLIB)perllocal.pod"
+ $(NOECHO) Write Sys$Output "Appending installation info to $(INSTALLARCHLIB)perllocal.pod"
pure__install : pure_site_install
$(NOECHO) Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
@@ -1803,11 +1838,11 @@ doc_perl_install ::
$(NOECHO) $(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.MM_tmp
$(NOECHO) $(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|'" >>.MM_tmp
],@docfiles,
-q[ $(NOECHO) $(PERL) -e "print q[@ARGV=split('|',<STDIN>);]" >.MM2_tmp
- $(NOECHO) $(PERL) -e "print q[print '=head3',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];]" >>.MM2_tmp
+q% $(NOECHO) $(PERL) -e "print q[@ARGV=split(/\\|/,<STDIN>);]" >.MM2_tmp
+ $(NOECHO) $(PERL) -e "print q[print '=head3 ',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) $(PERL) .MM2_tmp <.MM_tmp >>%.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
$(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;,.MM2_tmp;
# And again
@@ -1816,11 +1851,11 @@ doc_site_install ::
$(NOECHO) $(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.MM_tmp
$(NOECHO) $(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|'" >>.MM_tmp
],@docfiles,
-q[ $(NOECHO) $(PERL) -e "print q[@ARGV=split('|',<STDIN>);]" >.MM2_tmp
- $(NOECHO) $(PERL) -e "print q[print '=head3',scalar(localtime),': C<',shift,qq[>\\n\\n=over 4\\n\\n];]" >>.MM2_tmp
+q% $(NOECHO) $(PERL) -e "print q[@ARGV=split(/\\|/,<STDIN>);]" >.MM2_tmp
+ $(NOECHO) $(PERL) -e "print q[print '=head3 ',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) $(PERL) .MM2_tmp <.MM_tmp >>%.$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
$(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;,.MM2_tmp;
];
@@ -2231,18 +2266,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)
diff --git a/lib/ExtUtils/MakeMaker.pm b/lib/ExtUtils/MakeMaker.pm
index 544dece638..f6da518ee4 100644
--- a/lib/ExtUtils/MakeMaker.pm
+++ b/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.36";
+$Version = $VERSION = "5.38";
$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.206 $, 10)) =~ s/\s+$//;
+($Revision = substr(q$Revision: 1.207 $, 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
@@ -299,7 +300,7 @@ sub full_setup {
@Get_from_Config =
qw(
ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc
- lib_ext mab obj_ext ranlib sitelibexp sitearchexp so
+ lib_ext obj_ext ranlib sitelibexp sitearchexp so
);
my $item;
@@ -429,8 +430,12 @@ 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}->{$newclass} = $self if $self->{PARENT};
} else {
@@ -553,10 +558,10 @@ sub parse_args{
]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);
- }
+# 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
@@ -911,7 +916,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*
@@ -1139,7 +1144,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
@@ -1517,14 +1522,14 @@ 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.201 $ ' =~ /\$Revision:\s+([^\s]+)/;
+ ( $VERSION ) = '$Revision: 1.207 $ ' =~ /\$Revision:\s+([^\s]+)/;
$FOO::VERSION = '1.10';
but these will fail:
diff --git a/lib/ExtUtils/Manifest.pm b/lib/ExtUtils/Manifest.pm
index 14d0f6e1be..e1fcbf0163 100644
--- a/lib/ExtUtils/Manifest.pm
+++ b/lib/ExtUtils/Manifest.pm
@@ -1,21 +1,23 @@
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;
+
+use vars qw(@ISA @EXPORT_OK $VERSION $Debug $Verbose $Is_VMS $Quiet $MANIFEST $found);
+
+@ISA=('Exporter');
+@EXPORT_OK = ('mkmanifest', 'manicheck', 'fullcheck', 'filecheck',
+ 'skipcheck', 'maniread', 'manicopy');
$Debug = 0;
$Verbose = 1;
$Is_VMS = $^O eq 'VMS';
-$VERSION = $VERSION = substr(q$Revision: 1.24 $,10,4);
+$VERSION = substr(q$Revision: 1.27 $,10,4);
$Quiet = 0;
@@ -23,6 +25,7 @@ $MANIFEST = 'MANIFEST';
# Really cool fix from Ilya :)
unless (defined $Config{d_link}) {
+ local($^W) = 0; # avoid sub redefined message
*ln = \&cp;
}
@@ -181,7 +184,7 @@ sub manicopy {
}
sub cp_if_diff {
- my($from,$to, $how)=@_;
+ my($from, $to, $how)=@_;
-f $from || carp "$0: $from not found";
my($diff) = 0;
local(*F,*T);
@@ -197,7 +200,11 @@ sub cp_if_diff {
if (-e $to) {
unlink($to) or confess "unlink $to: $!";
}
- &$how($from, $to);
+ STRICT_SWITCH: {
+ best($from,$to), last STRICT_SWITCH if $how eq 'best';
+ cp($from,$to), last STRICT_SWITCH if $how eq 'cp';
+ ln($from,$to), last STRICT_SWITCH if $how eq 'ln';
+ }
}
}
@@ -350,7 +357,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 +394,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 E<lt>F<koenig@franz.ww.TU-Berlin.DE>E<gt>
=cut
diff --git a/lib/ExtUtils/Mkbootstrap.pm b/lib/ExtUtils/Mkbootstrap.pm
index 77339bd322..35d5236072 100644
--- a/lib/ExtUtils/Mkbootstrap.pm
+++ b/lib/ExtUtils/Mkbootstrap.pm
@@ -1,7 +1,7 @@
package ExtUtils::Mkbootstrap;
-$VERSION = substr q$Revision: 1.11 $, 10;
-# $Id: Mkbootstrap.pm,v 1.11 1996/05/31 08:23:54 k Exp k $
+$VERSION = substr q$Revision: 1.13 $, 10;
+# $Date: 1996/09/03 17:04:43 $
use Config;
use Exporter;
diff --git a/lib/ExtUtils/Mksymlists.pm b/lib/ExtUtils/Mksymlists.pm
index 5c0173a508..0f9a132c36 100644
--- a/lib/ExtUtils/Mksymlists.pm
+++ b/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.12 $, 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}) ]);
@@ -152,7 +153,7 @@ 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>.
diff --git a/lib/ExtUtils/typemap b/lib/ExtUtils/typemap
index a9733d0f49..c65b1cf35d 100644
--- a/lib/ExtUtils/typemap
+++ b/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 = $var ? &sv_yes : &sv_no;
T_U_INT
sv_setiv($arg, (IV)$var);
T_SHORT
diff --git a/lib/ExtUtils/xsubpp b/lib/ExtUtils/xsubpp
index 13f54b4855..d43eb1cb23 100644..100755
--- a/lib/ExtUtils/xsubpp
+++ b/lib/ExtUtils/xsubpp
@@ -71,12 +71,12 @@ See the file F<changes.pod>.
=head1 SEE ALSO
-perl(1), perlxs(1), perlxstut(1), perlapi(1)
+perl(1), perlxs(1), perlxstut(1), perlxs(1)
=cut
# Global Constants
-$XSUBPP_version = "1.937";
+$XSUBPP_version = "1.940";
require 5.002;
use vars '$cplusplus';
@@ -95,7 +95,7 @@ $ProtoUsed = 0 ;
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';
@@ -169,6 +169,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; }
@@ -215,6 +216,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.
@@ -227,8 +229,10 @@ sub check_keyword {
sub print_section {
+ my $count = 0;
$_ = shift(@line) while !/\S/ && @line;
for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
+ print line_directive() unless ($count++);
print "$_\n";
}
}
@@ -240,6 +244,7 @@ sub process_keyword($)
&{"${kwd}_handler"}()
while $kwd = check_keyword($pattern) ;
+ print line_directive();
}
sub CASE_handler {
@@ -316,6 +321,7 @@ sub OUTPUT_handler {
unless defined($args_match{$outarg});
blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
unless defined $var_types{$outarg} ;
+ print line_directive();
if ($outcode) {
print "\t$outcode\n";
} else {
@@ -440,6 +446,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
@@ -615,7 +639,7 @@ print <<EOM ;
*/
EOM
-
+print "#line 1 \"$filename\"\n";
while (<$FH>) {
last if ($Module, $Package, $Prefix) =
@@ -627,7 +651,6 @@ while (<$FH>) {
$lastline = $_;
$lastline_no = $.;
-
# Read next xsub into @line from ($lastline, <$FH>).
sub fetch_para {
# parse paragraph
@@ -642,6 +665,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 +746,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 +763,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 +776,7 @@ while (fetch_para()) {
if (check_keyword("BOOT")) {
&check_cpp;
- push (@BootCode, $_, @line, "") ;
+ push (@BootCode, $_, line_directive(), @line, "") ;
next PARAGRAPH ;
}
@@ -768,12 +796,13 @@ 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";
# 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} ++ ;
@@ -817,7 +846,7 @@ while (fetch_para()) {
# print function header
print Q<<"EOF";
-#XS(XS_${Packid}_$func_name)
+#XS(XS_${Full_func_name})
#[[
# dXSARGS;
EOF
@@ -876,8 +905,13 @@ 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/) {
print "\tchar *";
@@ -902,12 +936,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() ;
@@ -951,10 +988,18 @@ EOF
} elsif ($gotRETVAL || $wantRETVAL) {
&generate_output($ret_type, 0, 'RETVAL');
}
+ print line_directive();
# 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;
# ]]
@@ -1096,6 +1141,15 @@ sub output_init {
eval qq/print " $init\\\n"/;
}
+sub line_directive
+{
+ # work out the line number
+ my $line_no = $line_no[@line_no - @line -1] ;
+
+ return "#line $line_no \"$filename\"\n" ;
+
+}
+
sub Warn
{
# work out the line number
@@ -1148,12 +1202,15 @@ sub generate_init {
$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 {
@@ -1193,15 +1250,27 @@ sub generate_output {
eval "print qq\a$expr\a";
}
elsif ($var eq 'RETVAL') {
- if ($expr =~ /^\t\$arg\s*=\s*\$var\s*;/) {
- eval "print qq\a$expr\a";
- print "\tif (SvREFCNT(ST(0))) sv_2mortal(ST(0));\n";
- }
- elsif ($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";
}
diff --git a/lib/Fatal.pm b/lib/Fatal.pm
index 0d9c51b113..281474c336 100644
--- a/lib/Fatal.pm
+++ b/lib/Fatal.pm
@@ -43,7 +43,7 @@ sub _make_fatal {
$code .= "\(\@_\) || croak \"Can't $name\(\@_\): \$!\";\n}\n";
print $code if $Debug;
eval($code);
- die($@) if $@;
+ die if $@;
local($^W) = 0; # to avoid: Subroutine foo redefined ...
no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
*{$sub} = \&{"Fatal::$name"};
diff --git a/lib/File/Basename.pm b/lib/File/Basename.pm
index 5823ef6228..ad44c5df32 100644
--- a/lib/File/Basename.pm
+++ b/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
@@ -35,10 +33,10 @@ pieces using the syntax of different operating systems.
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" or "AmigaOS", 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
@@ -77,7 +75,7 @@ would yield
$base eq 'draft'
$path eq '/virgil/aeneid/',
- $tail eq '.book7'
+ $type eq '.book7'
Similarly, using VMS syntax:
@@ -118,7 +116,7 @@ require Exporter;
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
#use strict;
#use vars qw($VERSION $Fileparse_fstype);
-$VERSION = "2.3";
+$VERSION = "2.4";
# fileparse_set_fstype() - specify OS-based rules used in future
@@ -135,7 +133,7 @@ sub fileparse_set_fstype {
# fileparse() - parse file specification
#
-# Version 2.3 4-Jul-1996 Charles Bailey bailey@genetics.upenn.edu
+# Version 2.4 27-Sep-1996 Charles Bailey bailey@genetics.upenn.edu
sub fileparse {
@@ -146,18 +144,21 @@ sub fileparse {
if ($fstype =~ /^VMS/i) {
if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation
else {
- ($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
+ ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/);
}
}
if ($fstype =~ /^MSDOS/i) {
- ($dirpath,$basename) = ($fullname =~ /(.*[:\\])?(.*)/);
+ ($dirpath,$basename) = ($fullname =~ /^(.*[:\\\/])?(.*)/);
$dirpath .= '.\\' unless $dirpath =~ /\\$/;
}
elsif ($fstype =~ /^MacOS/i) {
- ($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
+ ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/);
+ }
+ elsif ($fstype =~ /^AmigaOS/i) {
+ ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/);
}
elsif ($fstype !~ /^VMS/i) { # default to Unix
- ($dirpath,$basename) = ($fullname =~ m#(.*/)?(.*)#);
+ ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#);
$dirpath = './' unless $dirpath;
}
@@ -206,6 +207,11 @@ sub dirname {
$dirname =~ s:[^\\]+$:: unless length($basename);
$dirname = '.' unless length($dirname);
}
+ elsif ($fstype =~ /AmigaOS/i) {
+ if ( $dirname =~ /:$/) { return $dirname }
+ chop $dirname;
+ $dirname =~ s#[^:/]+$## unless length($basename);
+ }
else {
if ( $dirname =~ m:^/+$:) { return '/'; }
chop $dirname;
diff --git a/lib/File/Compare.pm b/lib/File/Compare.pm
new file mode 100644
index 0000000000..e76c10fb5f
--- /dev/null
+++ b/lib/File/Compare.pm
@@ -0,0 +1,136 @@
+package File::Compare;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO);
+
+require Exporter;
+use Carp;
+use UNIVERSAL qw(isa);
+
+$VERSION = '1.1';
+@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, $status, $fr, $tr, $fbuf, $tbuf);
+ local(*FROM, *TO);
+ local($\) = '';
+
+ croak("from undefined") unless (defined $from);
+ croak("to undefined") unless (defined $to);
+
+ if (ref($from) && (isa($from,'GLOB') || 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;
+ }
+
+ if (ref($to) && (isa($to,'GLOB') || 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 (@_) {
+ $size = shift(@_) + 0;
+ croak("Bad buffer size for compare: $size\n") unless ($size > 0);
+ } else {
+ $size = -s FROM;
+ $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/lib/File/Copy.pm b/lib/File/Copy.pm
index aedcd7fb03..6afbd393b3 100644
--- a/lib/File/Copy.pm
+++ b/lib/File/Copy.pm
@@ -5,29 +5,33 @@
package File::Copy;
-require Exporter;
+use Exporter;
use Carp;
+use UNIVERSAL qw(isa);
+use vars qw( @ISA @EXPORT @EXPORT_OK $VERSION $Too_Big);
+use strict;
@ISA=qw(Exporter);
-@EXPORT=qw(copy);
-@EXPORT_OK=qw(copy cp);
+@EXPORT=qw(copy move);
+@EXPORT_OK=qw(cp mv);
-$File::Copy::VERSION = '1.5';
-$File::Copy::Too_Big = 1024 * 1024 * 2;
+$VERSION = '1.6';
+$Too_Big = 1024 * 1024 * 2;
sub VERSION {
# Version of File::Copy
- return $File::Copy::VERSION;
+ return $VERSION;
}
sub copy {
croak("Usage: copy( file1, file2 [, 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]) }
+ if (defined &File::Copy::syscopy &&
+ \&File::Copy::syscopy != \&File::Copy::copy &&
+ ref(\$_[1]) ne 'GLOB' &&
+ !(defined ref $_[1] and isa($_[1], 'GLOB')))
+ { return File::Copy::syscopy($_[0],$_[1]) }
my $from = shift;
my $to = shift;
@@ -37,26 +41,22 @@ sub copy {
local(*FROM, *TO);
local($\) = '';
- 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')) {
+ if (ref($from) && (isa($from,'GLOB') || isa($from,'IO::Handle'))) {
*FROM = *$from;
+ } elsif (ref(\$from) eq 'GLOB') {
+ *FROM = $from;
} else {
- open(FROM,"<$from")||goto(fail_open1);
+ open(FROM,"<$from") or goto fail_open1;
binmode FROM;
$closefrom = 1;
}
- 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')) {
+ if (ref($to) && (isa($to,'GLOB') || isa($to,'IO::Handle'))) {
*TO = *$to;
+ } elsif (ref(\$to) eq 'GLOB') {
+ *TO = $to;
} else {
- open(TO,">$to")||goto(fail_open2);
+ open(TO,">$to") or goto fail_open2;
binmode TO;
$closeto=1;
}
@@ -67,7 +67,7 @@ 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 = '';
@@ -76,7 +76,7 @@ sub copy {
goto fail_inner;
}
}
- goto fail_inner unless(defined($r));
+ goto fail_inner unless defined($r);
close(TO) || goto fail_open2 if $closeto;
close(FROM) || goto fail_open1 if $closefrom;
# Use this idiom to avoid uninitialized value warning.
@@ -101,10 +101,29 @@ sub copy {
return 0;
}
+sub move {
+ my($from,$to) = @_;
+ my($copied,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
+
+ return 1 if rename $from, $to;
+
+ ($tosz1,$tomt1) = (stat($to))[7,9];
+ return 1 if ($copied = copy($from,$to)) && unlink($from);
+
+ ($sts,$ossts) = ($! + 0, $^E + 0);
+ ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1;
+ unlink($to) if !defined($tomt1) || $tomt1 != $tomt2 || $tosz1 != $tosz2;
+ ($!,$^E) = ($sts,$ossts);
+ return 0;
+}
-*cp = \&copy;
+{
+ local($^W) = 0; # Hush up used-once warning
+ *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;
@@ -120,6 +139,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;
@@ -129,7 +149,15 @@ 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
@@ -150,6 +178,20 @@ 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 possible, it
+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
@@ -158,10 +200,10 @@ 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
+already opened file, 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
@@ -169,10 +211,12 @@ Perl 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
+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 just an alias for this routine).
+=over 4
+
=item rmscopy($from,$to[,$date_flag])
The first and second arguments may be strings, typeglobs, or
@@ -192,8 +236,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
@@ -207,15 +251,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/lib/File/Find.pm b/lib/File/Find.pm
index 39fab7bcb9..c5ce68ca1a 100644
--- a/lib/File/Find.pm
+++ b/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 \
@@ -70,7 +73,7 @@ that don't resolve:
sub find {
my $wanted = shift;
- my $cwd = Cwd::fastcwd();
+ my $cwd = Cwd::cwd();
my ($topdir,$topdev,$topino,$topmode,$topnlink);
foreach $topdir (@_) {
(($topdev,$topino,$topmode,$topnlink) = stat($topdir))
@@ -256,7 +259,8 @@ if ($^O =~ m:^mswin32:i) {
$dont_use_nlink = 1;
}
-$dont_use_nlink = 1 if $^O eq 'os2';
+$dont_use_nlink = 1
+ if $^O eq 'os2' || $^O eq 'msdos' || $^O eq 'amigaos';
1;
diff --git a/lib/File/Path.pm b/lib/File/Path.pm
index 97cb66855d..2e35303bb3 100644
--- a/lib/File/Path.pm
+++ b/lib/File/Path.pm
@@ -78,8 +78,8 @@ treated as ordinary files.
=head1 AUTHORS
-Tim Bunce <Tim.Bunce@ig.co.uk>
-Charles Bailey <bailey@genetics.upenn.edu>
+Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>
+Charles Bailey E<lt>F<bailey@genetics.upenn.edu>E<gt>
=head1 REVISION
@@ -131,9 +131,13 @@ sub rmtree {
$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));
+ @files = readdir(D);
closedir(D);
+ # 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)) {
@@ -152,7 +156,7 @@ sub rmtree {
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: $!";
+ or croak "Can't unlink file $root: $!";
}
}
}
diff --git a/lib/File/stat.pm b/lib/File/stat.pm
new file mode 100644
index 0000000000..581fbf3214
--- /dev/null
+++ b/lib/File/stat.pm
@@ -0,0 +1,111 @@
+package File::stat;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @ISA = qw(Exporter);
+ @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;
+
+use Class::Template 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.pm - 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::Template
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/lib/FileHandle.pm b/lib/FileHandle.pm
new file mode 100644
index 0000000000..e2ce83d44a
--- /dev/null
+++ b/lib/FileHandle.pm
@@ -0,0 +1,245 @@
+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';
+ for my $f (qw(DESTROY new_from_fd fdopen close fileno getc ungetc gets eof
+ setbuf setvbuf _open_mode_string)) {
+ *{$f} = \&{"IO::Handle::$f"} or die "$f missing";
+ }
+ for my $f (qw(seek tell fgetpos fsetpos fflush ferror clearerr)) {
+ *{$f} = \&{"IO::Seekable::$f"} or die "$f missing";
+ }
+ for my $f (qw(new new_tmpfile open)) {
+ *{$f} = \&{"IO::File::$f"} or die "$f missing";
+ }
+}
+
+#
+# Specialized importer for Fcntl magic.
+#
+sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+ 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);
+}
+
+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/lib/FindBin.pm b/lib/FindBin.pm
index ecfa3005b2..bbd72a2aa2 100644
--- a/lib/FindBin.pm
+++ b/lib/FindBin.pm
@@ -11,12 +11,12 @@ FindBin - Locate directory of original perl script
=head1 SYNOPSIS
use FindBin;
- BEGIN { unshift(@INC,"$FindBin::Bin/../lib") }
+ use lib "$FindBin::Bin/../lib";
or
use FindBin qw($Bin);
- BEGIN { unshift(@INC,"$Bin/../lib") }
+ use lib "$Bin/../lib";
=head1 DESCRIPTION
@@ -24,11 +24,11 @@ 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 <root>/bin and <root>/lib and then the above example will allow
+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 -e option or the perl script is read from
+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.
@@ -46,7 +46,7 @@ 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 -x and -T then FindBin
+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
@@ -55,8 +55,8 @@ Workaround is to invoke perl as
=head1 AUTHORS
-Graham Barr <bodg@tiuk.ti.com>
-Nick Ing-Simmons <nik@tiuk.ti.com>
+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
@@ -96,7 +96,7 @@ $VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
# $realpath;
#}
-sub abs_path
+sub my_abs_path
{
my $start = shift || '.';
my($dotdots, $cwd, @pst, @cst, $dir, @tst);
@@ -154,6 +154,8 @@ BEGIN
{
*Dir = \$Bin;
*RealDir = \$RealBin;
+ if (defined &Cwd::sys_abspath) { *abs_path = \&Cwd::sys_abspath}
+ else { *abs_path = \&my_abs_path}
if($0 eq '-e' || $0 eq '-')
{
diff --git a/lib/Getopt/Long.pm b/lib/Getopt/Long.pm
index 3fa9c8b10f..4047bf1f59 100644
--- a/lib/Getopt/Long.pm
+++ b/lib/Getopt/Long.pm
@@ -1,11 +1,11 @@
# GetOpt::Long.pm -- POSIX compatible options parsing
-# RCS Status : $Id: GetoptLong.pm,v 2.3 1996-04-05 21:03:05+02 jv Exp $
+# RCS Status : $Id: GetoptLong.pm,v 2.5 1996-10-19 16:47:51+02 jv Exp $
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
-# Last Modified On: Fri Apr 5 21:02:52 1996
-# Update Count : 433
+# Last Modified On: Sat Oct 19 16:46:23 1996
+# Update Count : 504
# Status : Released
package Getopt::Long;
@@ -14,9 +14,10 @@ require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
-$VERSION = sprintf("%d.%02d", '$Revision: 2.3 $ ' =~ /(\d+)\.(\d+)/);
+$VERSION = sprintf("%d.%02d", '$Revision: 2.5 $ ' =~ /(\d+)\.(\d+)/);
use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
- $error $debug $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER
+ $passthrough $error $debug
+ $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER
$VERSION $major_version $minor_version);
use strict;
@@ -79,13 +80,13 @@ linkage specified in the HASH.
The command line options are taken from array @ARGV. Upon completion
of GetOptions, @ARGV will contain the rest (i.e. the non-options) of
the command line.
-
+
Each option specifier designates the name of the option, optionally
followed by an argument specifier. 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.
@@ -170,6 +171,17 @@ 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,
@@ -191,7 +203,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
@@ -200,6 +212,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.
@@ -208,7 +225,7 @@ 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
@@ -216,7 +233,7 @@ configuration variable $Getopt::Long::autoabbrev.
=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.
@@ -246,11 +263,18 @@ 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 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 variable $Getopt::Long::getopt_compat is set to a
-non-zero value, options that start with "+" may also include their
+non-zero value, 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.
@@ -285,18 +309,18 @@ 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);
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);
@@ -404,6 +428,16 @@ Ignore case when matching options. Default is 1. When bundling is in
effect, case is ignored on single-character options only if
$Getopt::Long::ignorecase is greater than 1.
+=item $Getopt::Long::passthrough
+
+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 $Getopt::Long::order is
+set to $PERMUTE.
+
=item $Getopt::Long::VERSION
The version number of this Getopt::Long implementation in the format
@@ -454,14 +488,14 @@ my $gen_prefix; # generic prefix (option starters)
# Handle POSIX compliancy.
if ( defined $ENV{"POSIXLY_CORRECT"} ) {
- $gen_prefix = "--|-";
+ $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 = "--|-|\\+";
+ $gen_prefix = "(--|-|\\+)";
$autoabbrev = 1; # automatic abbrev of options
$bundling = 0; # bundling off by default
$getopt_compat = 1; # allow '+' to start options
@@ -472,35 +506,41 @@ else {
$debug = 0; # for debugging
$error = 0; # error tally
$ignorecase = 1; # ignore case when matching options
+$passthrough = 0; # leave unrecognized options alone
($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
+use vars qw($genprefix %opctl @opctl %bopctl $opt $arg $argend $array);
+use vars qw(%aliases $hash $key);
+
################ Subroutines ################
sub GetOptions {
my @optionlist = @_; # local copy of the option descriptions
- my $argend = '--'; # option list terminator
- my %opctl; # table of arg.specs (long and abbrevs)
- my %bopctl; # table of arg.specs (bundles)
+ local ($argend) = '--'; # option list terminator
+ local (%opctl); # table of arg.specs (long and abbrevs)
+ local (%bopctl); # table of arg.specs (bundles)
my $pkg = (caller)[0]; # current context
# Needed if linkage is omitted.
- my %aliases; # alias table
+ local (%aliases); # alias table
my @ret = (); # accum for non-options
my %linkage; # linkage
my $userlinkage; # user supplied HASH
- my $genprefix = $gen_prefix; # so we can call the same module more
+ local ($genprefix) = $gen_prefix; # so we can call the same module more
# than once in differing environments
$error = 0;
- print STDERR ('GetOptions $Revision: 2.3 $ ',
+ print STDERR ('GetOptions $Revision: 2.5 $ ',
"[GetOpt::Long $Getopt::Long::VERSION] -- ",
"called from package \"$pkg\".\n",
+ " (@ARGV)\n",
" autoabbrev=$autoabbrev".
",bundling=$bundling",
",getopt_compat=$getopt_compat",
- ",genprefix=\"$genprefix\"",
",order=$order",
- ",ignorecase=$ignorecase",
+ ",\n ignorecase=$ignorecase",
+ ",passthrough=$passthrough",
+ ",genprefix=\"$genprefix\"",
".\n")
if $debug;
@@ -525,8 +565,8 @@ sub GetOptions {
while ( @optionlist > 0 ) {
my $opt = shift (@optionlist);
- # Strip leading prefix so people can specify "-foo=i" if they like.
- $opt = $2 if $opt =~ /^($genprefix)+([\x00-\xff]*)/;
+ # Strip leading prefix so people can specify "--foo=i" if they like.
+ $opt = $' if $opt =~ /^($genprefix)+/;
if ( $opt eq '<>' ) {
if ( (defined $userlinkage)
@@ -545,7 +585,7 @@ sub GetOptions {
next;
}
- if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
+ if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse][@%]?)?$/ ) {
warn ("Error in option spec: \"", $opt, "\"\n");
$error++;
next;
@@ -560,7 +600,9 @@ sub GetOptions {
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
@@ -593,6 +635,7 @@ sub GetOptions {
$a = $_;
}
}
+ $o = $linko;
}
# If no linkage is supplied in the @optionlist, copy it from
@@ -616,8 +659,16 @@ sub GetOptions {
if ( @optionlist > 0 && ref($optionlist[0]) ) {
print STDERR ("=> link \"$o\" to $optionlist[0]\n")
if $debug;
- if ( ref($optionlist[0]) =~ /^(SCALAR|ARRAY|CODE)$/ ) {
+ if ( ref($optionlist[0]) =~ /^(SCALAR|CODE)$/ ) {
+ $linkage{$o} = shift (@optionlist);
+ }
+ elsif ( ref($optionlist[0]) =~ /^(ARRAY)$/ ) {
+ $linkage{$o} = shift (@optionlist);
+ $opctl{$o} .= '@' unless $opctl{$o} =~ /\@$/;
+ }
+ elsif ( ref($optionlist[0]) =~ /^(HASH)$/ ) {
$linkage{$o} = shift (@optionlist);
+ $opctl{$o} .= '%' unless $opctl{$o} =~ /\%$/;
}
else {
warn ("Invalid option linkage for \"", $opt, "\"\n");
@@ -629,11 +680,16 @@ sub GetOptions {
# Make sure a valid perl identifier results.
my $ov = $o;
$ov =~ s/\W/_/g;
- if ( defined($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;
@@ -646,7 +702,7 @@ sub GetOptions {
return 0 if $error;
# Sort the possible long option names.
- my @opctl = sort(keys (%opctl)) if $autoabbrev;
+ local (@opctl) = sort(keys (%opctl)) if $autoabbrev;
# Show the options tables if debugging.
if ( $debug ) {
@@ -663,24 +719,20 @@ sub GetOptions {
}
}
- my $opt; # current option
- my $arg; # current option value, if any
- my $array; # current option is array typed
+ local ($opt); # current option
+ local ($arg); # current option value, if any
+ local ($array); # current option is array typed
+ local ($hash); # current option is hash typed
+ local ($key); # hash key for a hash option
# Process argument list
while ( @ARGV > 0 ) {
- # >>> See also the continue block <<<
-
#### Get next argument ####
- my $starter; # option starter string, e.g. '-' or '--'
- my $rest = undef; # remainder from unbundling
- my $optarg = undef; # value supplied with --opt=value
-
$opt = shift (@ARGV);
$arg = undef;
- $array = 0;
+ $array = $hash = 0;
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
#### Determine what we have ####
@@ -693,21 +745,76 @@ sub GetOptions {
return ($error == 0);
}
- if ( $opt =~ /^($genprefix)([\x00-\xff]*)/ ) {
- # Looks like an option.
- $opt = $2; # option name (w/o prefix)
- $starter = $1; # option starter
-
- # If it is a long option, it may include the value.
- if (($starter eq "--"
- || ($getopt_compat && $starter eq "+"))
- && $opt =~ /^([^=]+)=([\x00-\xff]*)/ ) {
- $opt = $1;
- $optarg = $2;
- print STDERR ("=> option \"", $opt,
- "\", optarg = \"$optarg\"\n") if $debug;
- }
+ 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 <>.
@@ -715,12 +822,12 @@ sub GetOptions {
# Try non-options call-back.
my $cb;
if ( (defined ($cb = $linkage{'<>'})) ) {
- &$cb($opt);
+ &$cb($tryopt);
}
else {
- print STDERR ("=> saving \"$opt\" ",
+ print STDERR ("=> saving \"$tryopt\" ",
"(not an option, may permute)\n") if $debug;
- push (@ret, $opt);
+ push (@ret, $tryopt);
}
next;
}
@@ -728,227 +835,224 @@ sub GetOptions {
# ...otherwise, terminate.
else {
# Push this one back and exit.
- unshift (@ARGV, $opt);
+ unshift (@ARGV, $tryopt);
return ($error == 0);
}
- #### Look it up ###
-
- my $tryopt = $opt; # option to try
- my $optbl = \%opctl; # table to look it up (long names)
-
- 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
- }
-
- # 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) ) {
+ }
+
+ # Finish.
+ if ( $order == $PERMUTE ) {
+ # Push back accumulated arguments
+ print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
+ if $debug && @ret > 0;
+ unshift (@ARGV, @ret) if @ret > 0;
+ }
+
+ return ($error == 0);
+}
+
+sub find_option {
+
+ return 0 unless $opt =~ /^$genprefix/;
+
+ $opt = $';
+ my ($starter) = $&;
+
+ my $optarg = undef; # value supplied with --opt=value
+ my $rest = undef; # remainder from unbundling
+
+ # If it is a long option, it may include the value.
+ if (($starter eq "--" || $getopt_compat)
+ && $opt =~ /^([^=]+)=/ ) {
+ $opt = $1;
+ $optarg = $';
+ print STDERR ("=> option \"", $opt,
+ "\", optarg = \"$optarg\"\n") if $debug;
+ }
+
+ #### Look it up ###
+
+ my $tryopt = $opt; # option to try
+ my $optbl = \%opctl; # table to look it up (long names)
+
+ 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
+ }
+
+ # 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;
+ }
+ # 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++;
- next;
- }
-
- # Complete the option name, if appropriate.
- if ( @hits == 1 && $hits[0] ne $opt ) {
- $tryopt = $hits[0];
- print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n")
- if $debug;
+ undef $opt;
+ return 1;
}
+ @hits = keys(%hit);
}
- # Check validity by fetching the info.
- my $type = $optbl->{$tryopt};
- unless ( defined $type ) {
- warn ("Unknown option: ", $opt, "\n");
- $error++;
- 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;
}
- # Apparently valid.
- $opt = $tryopt;
- print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
+ }
+
+ # Check validity by fetching the info.
+ my $type = $optbl->{$tryopt};
+ 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 ####
+ #### 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");
- $error++;
- }
- elsif ( $type eq '' ) {
- $arg = 1; # supply explicit value
- }
- else {
- substr ($opt, 0, 2) = ''; # strip NO prefix
- $arg = 0; # supply explicit value
- }
- # When unbundling, unshift the rest with the starter.
- unshift (@ARGV, $starter.$rest) if defined $rest;
- next;
+ # 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;
+ }
- # Get mandatory status and type info.
- my $mand;
- ($mand, $type, $array) = $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 "=" ) {
- print STDERR ("Option ", $opt, " requires an argument\n");
- $error++;
- }
- if ( $mand eq ":" ) {
- $arg = $type eq "s" ? '' : 0;
- }
- next;
+ # 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;
+ }
- # Get (possibly optional) argument.
- $arg = (defined $rest ? $rest
- : (defined $optarg ? $optarg : shift (@ARGV)));
+ # Get (possibly optional) argument.
+ $arg = (defined $rest ? $rest
+ : (defined $optarg ? $optarg : shift (@ARGV)));
- #### Check if the argument is valid for this option ####
+ # 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 ( $type eq "s" ) { # string
- # A mandatory string takes anything.
- next if $mand eq "=";
+ #### Check if the argument is valid for this option ####
- # An optional string takes almost anything.
- next if defined $optarg || defined $rest;
- next if $arg eq "-"; # ??
+ if ( $type eq "s" ) { # string
+ # A mandatory string takes anything.
+ return 1 if $mand eq "=";
- # Check for option or option list terminator.
- if ($arg eq $argend ||
- $arg =~ /^$genprefix.+/) {
- # Push back.
- unshift (@ARGV, $arg);
- # Supply empty value.
- $arg = '';
- }
- next;
- }
+ # An optional string takes almost anything.
+ return 1 if defined $optarg || defined $rest;
+ return 1 if $arg eq "-"; # ??
- 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");
- $error++;
- undef $arg; # don't assign it
- # Push back.
- unshift (@ARGV, $starter.$rest) if defined $rest;
- }
- else {
- # Push back.
- unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
- # Supply default value.
- $arg = 0;
- }
- }
- next;
+ # Check for option or option list terminator.
+ if ($arg eq $argend ||
+ $arg =~ /^$genprefix.+/) {
+ # Push back.
+ unshift (@ARGV, $arg);
+ # Supply empty value.
+ $arg = '';
}
+ }
- 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");
- $error++;
- undef $arg; # don't assign it
- # Push back.
- unshift (@ARGV, $starter.$rest) if defined $rest;
- }
- else {
- # Push back.
- unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
- # Supply default value.
- $arg = 0.0;
- }
+ elsif ( $type eq "n" || $type eq "i" ) { # numeric/integer
+ if ( $arg !~ /^-?[0-9]+$/ ) {
+ if ( defined $optarg || $mand eq "=" ) {
+ return 0 if $passthrough;
+ print STDERR ("Value \"", $arg, "\" invalid for option ",
+ $opt, " (number expected)\n");
+ $error++;
+ undef $opt;
+ # Push back.
+ unshift (@ARGV, $starter.$rest) if defined $rest;
+ }
+ else {
+ # Push back.
+ unshift (@ARGV, defined $rest ? $starter.$rest : $arg);
+ # Supply default value.
+ $arg = 0;
}
- next;
}
-
- die ("GetOpt::Long internal error (Can't happen)\n");
}
- continue {
- 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 '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 ( $type eq "f" ) { # real number, int is also ok
+ if ( $arg !~ /^-?[0-9.]+([eE]-?[0-9]+)?$/ ) {
+ if ( defined $optarg || $mand eq "=" ) {
+ return 0 if $passthrough;
+ 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 ( $order == $PERMUTE ) {
- # Push back accumulated arguments
- print STDERR ("=> restoring \"", join('" "', @ret), "\"\n")
- if $debug && @ret > 0;
- unshift (@ARGV, @ret) if @ret > 0;
+ else {
+ die ("GetOpt::Long internal error (Can't happen)\n");
}
-
- return ($error == 0);
+ return 1;
}
################ Package return ################
diff --git a/lib/Getopt/Std.pm b/lib/Getopt/Std.pm
index 4117ca7f8b..fee0d33e8f 100644
--- a/lib/Getopt/Std.pm
+++ b/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 {
+ eval "\$opt_$first = \$rest;";
+ push( @EXPORT, "\$opt_$first" );
+ }
}
else {
- eval "\$opt_$first = 1;";
- push( @EXPORT, "\$opt_$first" );
+ if (ref $hash) {
+ $$hash{$first} = 1;
+ }
+ else {
+ eval "\$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 {
+ eval "\$opt_$first = \$rest;";
+ push( @EXPORT, "\$opt_$first" );
+ }
}
else {
- eval "\$opt_$first = 1";
- push( @EXPORT, "\$opt_$first" );
+ if (ref $hash) {
+ $$hash{$first} = 1;
+ }
+ else {
+ eval "\$opt_$first = 1";
+ push( @EXPORT, "\$opt_$first" );
+ }
if($rest eq '') {
shift(@ARGV);
}
diff --git a/lib/I18N/Collate.pm b/lib/I18N/Collate.pm
index 0d8314e12e..18c46da835 100644
--- a/lib/I18N/Collate.pm
+++ b/lib/I18N/Collate.pm
@@ -1,3 +1,8 @@
+#-----------------------------------------------------------------------#
+# NOTE! This module is deprecated (obsolete) after the Perl release #
+# 5.003_06 as the functionality has been integrated into the Perl core. #
+#-----------------------------------------------------------------------#
+
package I18N::Collate;
=head1 NAME
@@ -23,21 +28,20 @@ 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
@@ -87,7 +91,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 +108,33 @@ 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 pod/perli18n.pod for further information.
+
+***
+___EOD___
+ $please_use_I18N_Collate_even_if_deprecated++;
+ }
+ }
+
+ bless \$new;
+}
sub setlocale {
my ($category, $locale) = @_[0,1];
diff --git a/lib/IPC/Open2.pm b/lib/IPC/Open2.pm
index 62ec69b335..35bb0d1f16 100644
--- a/lib/IPC/Open2.pm
+++ b/lib/IPC/Open2.pm
@@ -20,7 +20,7 @@ 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|");
open2() returns the process ID of the child process. It doesn't return on
failure: it just raises an exception matching C</^open2:/>.
diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm
index fc93ab548d..d416ae7886 100644
--- a/lib/IPC/Open3.pm
+++ b/lib/IPC/Open3.pm
@@ -19,9 +19,9 @@ 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.
-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
+"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
diff --git a/lib/Math/BigInt.pm b/lib/Math/BigInt.pm
index 68856aea6e..f76f2611f0 100644
--- a/lib/Math/BigInt.pm
+++ b/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);
}
diff --git a/lib/Math/Complex.pm b/lib/Math/Complex.pm
index 969f3c2c79..aec0776c6c 100644
--- a/lib/Math/Complex.pm
+++ b/lib/Math/Complex.pm
@@ -1,123 +1,775 @@
-package Math::Complex;
+# $RCSFile$
+#
+# Complex numbers and associated mathematical functions
+# -- Raphael Manfredi, Sept 1996
require Exporter;
+package Math::Complex; @ISA = qw(Exporter);
-@ISA = ('Exporter');
-
-# just to make use happy
+@EXPORT = qw(
+ pi i Re Im arg
+ log10 logn cbrt root
+ tan cotan asin acos atan acotan
+ sinh cosh tanh cotanh asinh acosh atanh acotanh
+ cplx cplxe
+);
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
+ '+' => \&plus,
+ '-' => \&minus,
+ '*' => \&multiply,
+ '/' => \&divide,
+ '**' => \&power,
+ '<=>' => \&spaceship,
+ 'neg' => \&negate,
+ '~' => \&conjugate,
+ 'abs' => \&abs,
+ 'sqrt' => \&sqrt,
+ 'exp' => \&exp,
+ 'log' => \&log,
+ 'sin' => \&sin,
+ 'cos' => \&cos,
+ '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) = @_;
+ $theta += pi() if $rho < 0;
+ $self->{polar} = [abs($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, $im);
+}
+
+#
+# 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, $theta);
+}
+
+#
+# pi
+#
+# The number defined as 2 * pi = 360 degrees
+#
+sub pi () {
+ $pi = 4 * atan2(1, 1) unless $pi;
+ return $pi;
+}
+
+#
+# i
+#
+# The number defined as i*i = -1;
+#
+sub i () {
+ $i = bless {} unless $i; # There can be only one i
+ $i->{cartesian} = [0, 1];
+ $i->{polar} = [1, pi/2];
+ $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};
+ my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2);
+ 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};
+ my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2);
+ 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) = @_;
+ my ($r1, $t1) = @{$z1->polar};
+ my ($r2, $t2) = ref $z2 ? @{$z2->polar} : (abs($z2), $z2 >= 0 ? 0 : pi);
+ unless (defined $regular) {
+ $z1->set_polar([$r1 * $r2, $t1 + $t2]);
+ return $z1;
+ }
+ return (ref $z1)->emake($r1 * $r2, $t1 + $t2);
+}
+
+#
+# (divide)
+#
+# Computes z1/z2.
+#
+sub divide {
+ my ($z1, $z2, $inverted) = @_;
+ my ($r1, $t1) = @{$z1->polar};
+ my ($r2, $t2) = ref $z2 ? @{$z2->polar} : (abs($z2), $z2 >= 0 ? 0 : pi);
+ unless (defined $inverted) {
+ $z1->set_polar([$r1 / $r2, $t1 - $t2]);
+ return $z1;
+ }
+ return $inverted ?
+ (ref $z1)->emake($r2 / $r1, $t2 - $t1) :
+ (ref $z1)->emake($r1 / $r2, $t1 - $t2);
+}
+
+#
+# (power)
+#
+# Computes z1**z2 = exp(z2 * log z1)).
+#
+sub power {
+ my ($z1, $z2, $inverted) = @_;
+ return exp($z1 * log $z2) if defined $inverted && $inverted;
+ return 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) = @{$z1->cartesian};
+ my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2);
+ 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};
+ return (ref $z)->emake($r, pi + $t);
}
- 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;
+ 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 abs($r);
}
+#
+# arg
+#
+# Compute complex's argument (theta).
+#
+sub arg {
+ my ($z) = @_;
+ return 0 unless ref $z;
+ my ($r, $t) = @{$z->polar};
+ return $t;
+}
+
+#
+# (sqrt)
+#
+# Compute sqrt(z) (positive only).
+#
+sub sqrt {
+ my ($z) = @_;
+ my ($r, $t) = @{$z->polar};
+ return (ref $z)->emake(sqrt($r), $t/2);
+}
+
+#
+# cbrt
+#
+# Compute cbrt(z) (cubic root, primary only).
+#
+sub cbrt {
+ my ($z) = @_;
+ return $z ** (1/3) unless ref $z;
+ my ($r, $t) = @{$z->polar};
+ return (ref $z)->emake($r**(1/3), $t/3);
+}
+
+#
+# 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) = @_;
+ $n = int($n + 0.5);
+ return undef unless $n > 0;
+ my ($r, $t) = ref $z ? @{$z->polar} : (abs($z), $z >= 0 ? 0 : pi);
+ my @root;
+ my $k;
+ my $theta_inc = 2 * pi / $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);
+}
+
+#
+# (log)
+#
+# Compute log(z).
+#
+sub log {
+ my ($z) = @_;
+ my ($r, $t) = @{$z->polar};
+ return (ref $z)->make(log($r), $t);
+}
+
+#
+# log10
+#
+# Compute log10(z).
+#
+sub log10 {
+ my ($z) = @_;
+ $log10 = log(10) unless defined $log10;
+ return log($z) / $log10 unless ref $z;
+ my ($r, $t) = @{$z->polar};
+ return (ref $z)->make(log($r) / $log10, $t / $log10);
+}
+
+#
+# logn
+#
+# Compute logn(z,n) = log(z) / log(n)
+#
+sub logn {
+ my ($z, $n) = @_;
+ my $logn = $logn{$n};
+ $logn = $logn{$n} = log($n) unless defined $logn; # Cache log(n)
+ return log($z) / log($n);
+}
+
+#
+# (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) = @_;
+ return sin($z) / cos($z);
+}
+
+#
+# cotan
+#
+# Computes cotan(z) = 1 / tan(z).
+#
+sub cotan {
+ my ($z) = @_;
+ return cos($z) / sin($z);
+}
+
+#
+# acos
+#
+# Computes the arc cosine acos(z) = -i log(z + sqrt(z*z-1)).
+#
+sub acos {
+ my ($z) = @_;
+ my $cz = $z*$z - 1;
+ $cz = cplx($cz, 0) if !ref $cz && $cz < 0; # Force complex if <0
+ return ~i * log($z + sqrt $cz); # ~i is -i
+}
+
+#
+# asin
+#
+# Computes the arc sine asin(z) = -i log(iz + sqrt(1-z*z)).
+#
+sub asin {
+ my ($z) = @_;
+ my $cz = 1 - $z*$z;
+ $cz = cplx($cz, 0) if !ref $cz && $cz < 0; # Force complex if <0
+ return ~i * log(i * $z + sqrt $cz); # ~i is -i
+}
+
+#
+# atan
+#
+# Computes the arc tagent atan(z) = i/2 log((i+z) / (i-z)).
+#
+sub atan {
+ my ($z) = @_;
+ return i/2 * log((i + $z) / (i - $z));
+}
+
+#
+# acotan
+#
+# Computes the arc cotangent acotan(z) = -i/2 log((i+z) / (z-i))
+#
+sub acotan {
+ my ($z) = @_;
+ return i/-2 * log((i + $z) / ($z - i));
+}
+
+#
+# cosh
+#
+# Computes the hyperbolic cosine cosh(z) = (exp(z) + exp(-z))/2.
+#
+sub cosh {
+ my ($z) = @_;
+ my ($x, $y) = ref $z ? @{$z->cartesian} : ($z);
+ my $ex = exp($x);
+ my $ex_1 = 1 / $ex;
+ return ($ex + $ex_1)/2 unless ref $z;
+ 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 ($x, $y) = ref $z ? @{$z->cartesian} : ($z);
+ my $ex = exp($x);
+ my $ex_1 = 1 / $ex;
+ return ($ex - $ex_1)/2 unless ref $z;
+ 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) = @_;
+ return sinh($z) / cosh($z);
+}
+
+#
+# cotanh
+#
+# Comptutes the hyperbolic cotangent cotanh(z) = cosh(z) / sinh(z).
+#
+sub cotanh {
+ my ($z) = @_;
+ return cosh($z) / sinh($z);
+}
+
+#
+# acosh
+#
+# Computes the arc hyperbolic cosine acosh(z) = log(z + sqrt(z*z-1)).
+#
+sub acosh {
+ my ($z) = @_;
+ my $cz = $z*$z - 1;
+ $cz = cplx($cz, 0) if !ref $cz && $cz < 0; # Force complex if <0
+ return log($z + sqrt $cz);
+}
+
+#
+# asinh
+#
+# Computes the arc hyperbolic sine asinh(z) = log(z + sqrt(z*z-1))
+#
+sub asinh {
+ my ($z) = @_;
+ my $cz = $z*$z + 1; # Already complex if <0
+ return log($z + sqrt $cz);
+}
+
+#
+# atanh
+#
+# Computes the arc hyperbolic tangent atanh(z) = 1/2 log((1+z) / (1-z)).
+#
+sub atanh {
+ my ($z) = @_;
+ my $cz = (1 + $z) / (1 - $z);
+ $cz = cplx($cz, 0) if !ref $cz && $cz < 0; # Force complex if <0
+ return log($cz) / 2;
+}
+
+#
+# acotanh
+#
+# Computes the arc hyperbolic cotangent acotanh(z) = 1/2 log((1+z) / (z-1)).
+#
+sub acotanh {
+ my ($z) = @_;
+ my $cz = (1 + $z) / ($z - 1);
+ $cz = cplx($cz, 0) if !ref $cz && $cz < 0; # Force complex if <0
+ return log($cz) / 2;
+}
+
+#
+# (atan2)
+#
+# Compute atan(z1/z2).
+#
+sub atan2 {
+ my ($z1, $z2, $inverted) = @_;
+ my ($re1, $im1) = @{$z1->cartesian};
+ my ($re2, $im2) = ref $z2 ? @{$z2->cartesian} : ($z2);
+ my $tan;
+ if (defined $inverted && $inverted) { # atan(z2/z1)
+ return pi * ($re2 > 0 ? 1 : -1) if $re1 == 0 && $im1 == 0;
+ $tan = $z2 / $z1;
+ } else {
+ return pi * ($re1 > 0 ? 1 : -1) if $re2 == 0 && $im2 == 0;
+ $tan = $z1 / $z2;
+ }
+ return atan($tan);
+}
+
+#
+# display_format
+# ->display_format
+#
+# Set (fetch if no argument) display format for all complex numbers that
+# don't happen to have overrriden 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;
+
+ $format = $display;
+ $format = $z->{display} if defined $z->{display};
+
+ return $z->stringify_polar if $format =~ /^p/i;
+ return $z->stringify_cartesian;
+}
+
+#
+# ->stringify_cartesian
+#
+# Stringify as a cartesian representation 'a+bi'.
+#
+sub stringify_cartesian {
+ my $z = shift;
+ my ($x, $y) = @{$z->cartesian};
+ my ($re, $im);
+
+ $x = int($x + ($x < 0 ? -1 : 1) * 1e-14)
+ if int(abs($x)) != int(abs($x) + 1e-14);
+ $y = int($y + ($y < 0 ? -1 : 1) * 1e-14)
+ if int(abs($y)) != int(abs($y) + 1e-14);
+
+ $re = "$x" if abs($x) >= 1e-14;
+ if ($y == 1) { $im = 'i' }
+ elsif ($y == -1) { $im = '-i' }
+ elsif (abs($y) >= 1e-14) { $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;
+
+ return '[0,0]' if $r <= 1e-14;
- $re = $x if ($x);
- if ($y == 1) {$im = 'i';}
- elsif ($y == -1){$im = '-i';}
- elsif ($y) {$im = "${y}i"; }
+ my $tpi = 2 * pi;
+ my $nt = $t / $tpi;
+ $nt = ($nt - int($nt)) * $tpi;
+ $nt += $tpi if $nt < 0; # Range [0, 2pi]
- local $_ = $re.'+'.$im;
- s/\+-/-/;
- s/^\+//;
- s/[\+-]$//;
- $_ = 0 if ($_ eq '');
- return $_;
+ if (abs($nt) <= 1e-14) { $theta = 0 }
+ elsif (abs(pi-$nt) <= 1e-14) { $theta = 'pi' }
+
+ if (defined $theta) {
+ $r = int($r + ($r < 0 ? -1 : 1) * 1e-14)
+ if int(abs($r)) != int(abs($r) + 1e-14);
+ $theta = int($theta + ($theta < 0 ? -1 : 1) * 1e-14)
+ if int(abs($theta)) != int(abs($theta) + 1e-14);
+ return "\[$r,$theta\]";
+ }
+
+ #
+ # Okay, number is not a real. Try to identify pi/n and friends...
+ #
+
+ $nt -= $tpi 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) <= 1e-14) {
+ $theta = ($nt < 0 ? '-':'').($k == 1 ? 'pi':"${k}pi").'/'.abs($n);
+ last;
+ }
+ }
+
+ $theta = $nt unless defined $theta;
+
+ $r = int($r + ($r < 0 ? -1 : 1) * 1e-14)
+ if int(abs($r)) != int(abs($r) + 1e-14);
+ $theta = int($theta + ($theta < 0 ? -1 : 1) * 1e-14)
+ if int(abs($theta)) != int(abs($theta) + 1e-14);
+
+ return "\[$r,$theta\]";
}
1;
@@ -125,39 +777,333 @@ __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 substractions. Real numbers are on the I<x>
+axis, and therefore I<theta> is zero.
+
+All the common operations that can be performed on a real number have
+been defined to work on complex numbers as well, and are merely
+I<extensions> of the operations defined on real numbers. This means
+they keep their natural meaning when there is no imaginary part, provided
+the number is within their definition set.
+
+For instance, the C<sqrt> routine which computes the square root of
+its argument is only defined for positive real numbers and yields a
+positive real number (it is an application from B<R+> to B<R+>).
+If we allow it to return a complex number, then it can be extended to
+negative real numbers to become an application from B<R> to B<C> (the
+set of complex numbers):
+
+ sqrt(x) = x >= 0 ? sqrt(x) : sqrt(-x)*i
+
+It can also be extended to be an application from B<C> to B<C>,
+whilst its restriction to B<R> behaves as defined above by using
+the following definition:
+
+ sqrt(z = [r,t]) = sqrt(r) * exp(i * t/2)
+
+Indeed, a negative real number can be noted C<[x,pi]>
+(the modulus I<x> is always positive, so C<[x,pi]> is really C<-x>, a
+negative number)
+and the above definition states that
+
+ sqrt([x,pi]) = sqrt(x) * exp(i*pi/2) = [sqrt(x),pi/2] = sqrt(x)*i
- $i = Math::Complex->new(1,1);
+which is exactly what we had defined for negative real numbers above.
-can be manipulated with overloaded math operators. The operators
+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?).
- + - * / neg ~ abs cos sin exp sqrt
+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.
-are supported as well as
+ z = a + bi
+ ~z = a - bi
- "" (stringify)
+Simple... Now look:
-The methods
+ z * ~z = (a + bi) * (a - bi) = a*a + b*b
- Re Im arg
+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:
-are also provided.
+ 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))
+ abs(z1) = r1
+ 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)
+ cotan(z) = 1 / tan(z)
+
+ asin(z) = -i * log(i*z + sqrt(1-z*z))
+ acos(z) = -i * log(z + sqrt(z*z-1))
+ atan(z) = i/2 * log((i+z) / (i-z))
+ acotan(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)
+ cotanh(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))
+ acotanh(z) = 1/2 * log((1+z) / (z-1))
+
+The I<root> function is available to compute all the I<n>th
+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<spaceshift> operation 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 trigonometric 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).
+(Mnmemonic: C<e> is used as a notation for complex numbers in the trigonometric
+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 positive (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 BUGS
-sqrt() should return two roots, but only returns one.
+Saying C<use Math::Complex;> exports many mathematical routines in the caller
+environment. This is construed as a feature by the Author, actually... ;-)
+
+The code is not optimized for speed, although we try to use the cartesian
+form for addition-like operators and the trigonometric form for all
+multiplication-like operators.
+
+The arg() routine does not ensure the angle is within the range [-pi,+pi]
+(a side effect caused by multiplication and division using the trigonometric
+representation).
-=head1 AUTHORS
+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.
-Dave Nadler, Tom Christiansen, Tim Bunce, Larry Wall.
+=head1 AUTHOR
-=cut
+Raphael Manfredi <F<Raphael_Manfredi@grenoble.hp.com>>
diff --git a/lib/Net/FTP.pm b/lib/Net/FTP.pm
new file mode 100644
index 0000000000..64b21fe751
--- /dev/null
+++ b/lib/Net/FTP.pm
@@ -0,0 +1,943 @@
+;# Net::FTP.pm
+;#
+;# Copyright (c) 1995 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.
+
+;#Notes
+;# should I have a dataconn::close sub which calls response ??
+;# FTP should hold state reguarding cmds sent
+;# A::read needs some more thought
+;# A::write What is previous pkt ended in \r or not ??
+;# need to do some heavy tidy-ing up !!!!
+;# need some documentation
+
+package Net::FTP;
+
+=head1 NAME
+
+Net::FTP - FTP Client class
+
+=head1 SYNOPSIS
+
+ require Net::FTP;
+
+ $ftp = Net::FTP->new("some.host.name");
+ $ftp->login("anonymous","me@here.there");
+ $ftp->cwd("/pub");
+ $ftp->get("that.file");
+ $ftp->quit;
+
+=head1 DESCRIPTION
+
+C<Net::FTP> is a class implementing a simple FTP client in Perl as described
+in RFC959
+
+=head2 TO BE CONTINUED ...
+
+=cut
+
+require 5.001;
+use Socket 1.3;
+use Carp;
+use Net::Socket;
+
+@ISA = qw(Net::Socket);
+
+$VERSION = sprintf("%d.%02d", q$Revision: 1.18 $ =~ /(\d+)\.(\d+)/);
+sub Version { $VERSION }
+
+use strict;
+
+=head1 METHODS
+
+All methods return 0 or undef upon failure
+
+=head2 * new($host [, option => value [,...]] )
+
+Constructor for the FTP client. It will create the connection to the
+remote host. Possible options are:
+
+ Port => port to use for FTP connection
+ Timeout => set timeout value (defaults to 120)
+ Debug => debug level
+
+=cut
+
+sub FTP_READY { 0 } # Ready
+sub FTP_RESPONSE { 1 } # Waiting for a response
+sub FTP_XFER { 2 } # Doing data xfer
+
+sub new {
+ my $pkg = shift;
+ my $host = shift;
+ my %arg = @_;
+ my $me = bless Net::Socket->new(Peer => $host,
+ Service => 'ftp',
+ Port => $arg{Port} || 'ftp'
+ ), $pkg;
+
+ ${*$me} = ""; # partial response text
+ @{*$me} = (); # Last response text
+
+ %{*$me} = (%{*$me}, # Copy current values
+ Code => 0, # Last response code
+ Type => 'A', # Ascii/Binary/etc mode
+ Timeout => $arg{Timeout} || 120, # Timeout value
+ Debug => $arg{Debug} || 0, # Output debug information
+ FtpHost => $host, # Remote hostname
+ State => FTP_RESPONSE, # Current state
+
+ ##############################################################
+ # Other elements used during the lifetime of the object are
+ #
+ # LISTEN Listen socket
+ # DATA Data socket
+ );
+
+ $me->autoflush(1);
+
+ $me->debug($arg{Debug})
+ if(exists $arg{Debug});
+
+ unless(2 == $me->response())
+ {
+ $me->close();
+ undef $me;
+ }
+
+ $me;
+}
+
+##
+## User interface methods
+##
+
+=head2 * debug( $value )
+
+Set the level of debug information for this object. If no argument is given
+then the current state is returned. Otherwise the state is changed to
+C<$value>and the previous state returned.
+
+=cut
+
+sub debug {
+ my $me = shift;
+ my $debug = ${*$me}{Debug};
+
+ if(@_)
+ {
+ ${*$me}{Debug} = 0 + shift;
+
+ printf STDERR "\n$me VERSION %s\n", $Net::FTP::VERSION
+ if(${*$me}{Debug});
+ }
+
+ $debug;
+}
+
+=head2 quit
+
+Send the QUIT command to the remote FTP server and close the socket connection.
+
+=cut
+
+sub quit {
+ my $me = shift;
+
+ return undef
+ unless $me->QUIT;
+
+ close($me);
+
+ return 1;
+}
+
+=head2 ascii/ebcdic/binary/byte
+
+Put the remote FTP server ant the FTP package into the given mode
+of data transfer.
+
+=cut
+
+sub ascii { shift->type('A',@_); }
+sub ebcdic { shift->type('E',@_); }
+sub binary { shift->type('I',@_); }
+sub byte { shift->type('L',@_); }
+
+# Allow the user to send a command directly, BE CAREFUL !!
+
+sub quot {
+ my $me = shift;
+ my $cmd = shift;
+
+ $me->send_cmd( uc $cmd, @_);
+
+ $me->response();
+}
+
+=head2 login([$login [, $password [, $account]]])
+
+Log into the remote FTP server with the given login information. If
+no arguments are given then the users $HOME/.netrc file is searched
+for the remote server's hostname. If no information is found then
+a login of I<anonymous> is used. If no password is given and the login
+is anonymous then the users Email address will be used for a password
+
+=cut
+
+sub login {
+ my $me = shift;
+ my $user = shift;
+ my $pass = shift if(defined $user);
+ my $acct = shift if(defined $pass);
+ my $ok;
+
+ unless(defined $user)
+ {
+ require Net::Netrc;
+ my $rc = Net::Netrc->lookup(${*$me}{FtpHost});
+
+ ($user,$pass,$acct) = $rc->lpa()
+ if $rc;
+ }
+
+ $user = "anonymous"
+ unless defined $user;
+
+ $pass = "-" . (getpwuid($>))[0] . "@"
+ if !defined $pass && $user eq "anonymous";
+
+ $ok = $me->USER($user);
+
+ $ok = $me->PASS($pass)
+ if $ok == 3;
+
+ $ok = $me->ACCT($acct || "")
+ if $ok == 3;
+
+ $ok == 2;
+}
+
+=head2 authorise($auth, $resp)
+
+This is a protocol used by some firewall ftp proxies. It is used
+to authorise the user to send data out.
+
+=cut
+
+sub authorise {
+ my($me,$auth,$resp) = @_;
+ my $ok;
+
+ carp "Net::FTP::authorise <auth> <resp>\n"
+ unless defined $auth && defined $resp;
+
+ $ok = $me->AUTH($auth);
+
+ $ok = $me->RESP($resp)
+ if $ok == 3;
+
+ $ok == 2;
+}
+
+=head2 rename( $oldname, $newname)
+
+Rename a file on the remote FTP server from C<$oldname> to C<$newname>
+
+=cut
+
+sub rename {
+ my($me,$from,$to) = @_;
+
+ croak "Net::FTP:rename <from> <to>\n"
+ unless defined $from && defined $to;
+
+ $me->RNFR($from) and $me->RNTO($to);
+}
+
+sub type {
+ my $me = shift;
+ my $type = shift;
+ my $ok = 0;
+
+ return ${*$me}{Type}
+ unless defined $type;
+
+ return undef
+ unless($me->TYPE($type,@_));
+
+ ${*$me}{Type} = join(" ",$type,@_);
+}
+
+sub abort {
+ my $me = shift;
+
+ ${*$me}{DATA}->abort()
+ if defined ${*$me}{DATA};
+}
+
+sub get {
+ my $me = shift;
+ my $remote = shift;
+ my $local = shift;
+ my $where = shift || 0;
+ my($loc,$len,$buf,$resp,$localfd,$data);
+ local *FD;
+
+ $localfd = ref($local) ? fileno($local)
+ : 0;
+
+ ($local = $remote) =~ s#^.*/## unless(defined $local);
+
+ if($localfd)
+ {
+ $loc = $local;
+ }
+ else
+ {
+ $loc = \*FD;
+
+ unless(($where) ? open($loc,">>$local") : open($loc,">$local"))
+ {
+ carp "Cannot open Local file $local: $!\n";
+ return undef;
+ }
+ }
+
+ if ($where) {
+ $data = $me->rest_cmd($where,$remote) or
+ return undef;
+ }
+ else {
+ $data = $me->retr($remote) or
+ return undef;
+ }
+
+ $buf = '';
+
+ do
+ {
+ $len = $data->read($buf,1024);
+ }
+ while($len > 0 && syswrite($loc,$buf,$len) == $len);
+
+ close($loc)
+ unless $localfd;
+
+ $data->close() == 2; # implied $me->response
+}
+
+sub cwd {
+ my $me = shift;
+ my $dir = shift || "/";
+
+ return $dir eq ".." ? $me->CDUP()
+ : $me->CWD($dir);
+}
+
+sub pwd {
+ my $me = shift;
+
+ $me->PWD() ? ($me->message =~ /\"([^\"]+)/)[0]
+ : undef;
+}
+
+sub put { shift->send("stor",@_) }
+sub put_unique { shift->send("stou",@_) }
+sub append { shift->send("appe",@_) }
+
+sub nlst { shift->data_cmd("NLST",@_) }
+sub list { shift->data_cmd("LIST",@_) }
+sub retr { shift->data_cmd("RETR",@_) }
+sub stor { shift->data_cmd("STOR",@_) }
+sub stou { shift->data_cmd("STOU",@_) }
+sub appe { shift->data_cmd("APPE",@_) }
+
+sub send {
+ my $me = shift;
+ my $cmd = shift;
+ my $local = shift;
+ my $remote = shift;
+ my($loc,$sock,$len,$buf,$localfd);
+ local *FD;
+
+ $localfd = ref($local) ? fileno($local)
+ : 0;
+
+ unless(defined $remote)
+ {
+ croak "Must specify remote filename with stream input\n"
+ if $localfd;
+
+ ($remote = $local) =~ s%.*/%%;
+ }
+
+ if($localfd)
+ {
+ $loc = $local;
+ }
+ else
+ {
+ $loc = \*FD;
+
+ unless(open($loc,"<$local"))
+ {
+ carp "Cannot open Local file $local: $!\n";
+ return undef;
+ }
+ }
+
+ $cmd = lc $cmd;
+
+ $sock = $me->$cmd($remote) or
+ return undef;
+
+ do
+ {
+ $len = sysread($loc,$buf,1024);
+ }
+ while($len && $sock->write($buf,$len) == $len);
+
+ close($loc)
+ unless $localfd;
+
+ $sock->close();
+
+ ($remote) = $me->message =~ /unique file name:\s*(\S*)\s*\)/
+ if $cmd eq 'stou' ;
+
+ return $remote;
+}
+
+sub port {
+ my $me = shift;
+ my $port = shift;
+ my $ok;
+
+ unless(defined $port)
+ {
+ my $listen;
+
+ if(defined ${*$me}{LISTEN})
+ {
+ ${*$me}{LISTEN}->close();
+ delete ${*$me}{LISTEN};
+ }
+
+ # create a Listen socket at same address as the command socket
+
+ $listen = Net::Socket->new(Listen => 5,
+ Service => 'ftp',
+ Addr => $me->sockhost,
+ );
+
+ ${*$me}{LISTEN} = $listen;
+
+ my($myport, @myaddr) = ($listen->sockport, split(/\./,$listen->sockhost));
+
+ $port = join(',', @myaddr, $myport >> 8, $myport & 0xff);
+ }
+
+ $ok = $me->PORT($port);
+
+ ${*$me}{Port} = $port;
+
+ $ok;
+}
+
+sub ls { shift->list_cmd("NLST",@_); }
+sub lsl { shift->list_cmd("LIST",@_); }
+
+sub pasv {
+ my $me = shift;
+ my $hostport;
+
+ return undef
+ unless $me->PASV();
+
+ ($hostport) = $me->message =~ /(\d+(,\d+)+)/;
+
+ ${*$me}{Pasv} = $hostport;
+}
+
+##
+## Communication methods
+##
+
+sub timeout {
+ my $me = shift;
+ my $timeout = ${*$me}{Timeout};
+
+ ${*$me}{Timeout} = 0 + shift if(@_);
+
+ $timeout;
+}
+
+sub accept {
+ my $me = shift;
+
+ return undef unless defined ${*$me}{LISTEN};
+
+ my $data = ${*$me}{LISTEN}->accept;
+
+ ${*$me}{LISTEN}->close();
+ delete ${*$me}{LISTEN};
+
+ ${*$data}{Timeout} = ${*$me}{Timeout};
+ ${*$data}{Cmd} = $me;
+ ${*$data} = "";
+
+ ${*$me}{State} = FTP_XFER;
+ ${*$me}{DATA} = bless $data, "Net::FTP::" . ${*$me}{Type};
+}
+
+sub message {
+ my $me = shift;
+ join("\n", @{*$me});
+}
+
+sub ok {
+ my $me = shift;
+ my $code = ${*$me}{Code} || 0;
+
+ 0 < $code && $code < 400;
+}
+
+sub code {
+ my $me = shift;
+
+ ${*$me}{Code};
+}
+
+sub list_cmd {
+ my $me = shift;
+ my $cmd = lc shift;
+ my $data = $me->$cmd(@_);
+
+ return undef
+ unless(defined $data);
+
+ bless $data, "Net::FTP::A"; # Force ASCII mode
+
+ my $databuf = '';
+ my $buf = '';
+
+ while($data->read($databuf,1024)) {
+ $buf .= $databuf;
+ }
+
+ my $list = [ split(/\n/,$buf) ];
+
+ $data->close();
+
+ wantarray ? @{$list} : $list;
+}
+
+sub data_cmd {
+ my $me = shift;
+ my $cmd = uc shift;
+ my $ok = 1;
+ my $pasv = defined ${*$me}{Pasv} ? 1 : 0;
+
+ $ok = $me->port
+ unless $pasv || defined ${*$me}{Port};
+
+ $ok = $me->$cmd(@_)
+ if $ok;
+
+ return $pasv ? $ok
+ : $ok ? $me->accept()
+ : undef;
+}
+
+sub rest_cmd {
+ my $me = shift;
+ my $ok = 1;
+ my $pasv = defined ${*$me}{Pasv} ? 1 : 0;
+ my $where = shift;
+ my $file = shift;
+
+ $ok = $me->port
+ unless $pasv || defined ${*$me}{Port};
+
+ $ok = $me->REST($where)
+ if $ok;
+
+ $ok = $me->RETR($file)
+ if $ok;
+
+ return $pasv ? $ok
+ : $ok ? $me->accept()
+ : undef;
+}
+
+sub cmd {
+ my $me = shift;
+
+ $me->send_cmd(@_);
+ $me->response();
+}
+
+sub send_cmd {
+ my $me = shift;
+
+ if(scalar(@_)) {
+ my $cmd = join(" ", @_) . "\r\n";
+
+ delete ${*$me}{Pasv};
+ delete ${*$me}{Port};
+
+ syswrite($me,$cmd,length $cmd);
+
+ ${*$me}{State} = FTP_RESPONSE;
+
+ printf STDERR "\n$me>> %s", $cmd=~/^(pass|resp)/i ? "$1 ....\n" : $cmd
+ if $me->debug;
+ }
+
+ $me;
+}
+
+sub pasv_wait {
+ my $me = shift;
+ my $non_pasv = shift;
+ my $file;
+
+ my($rin,$rout);
+ vec($rin,fileno($me),1) = 1;
+ select($rout=$rin, undef, undef, undef);
+
+ $me->response();
+ $non_pasv->response();
+
+ return undef
+ unless $me->ok() && $non_pasv->ok();
+
+ return $1
+ if $me->message =~ /unique file name:\s*(\S*)\s*\)/;
+
+ return $1
+ if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/;
+
+ return 1;
+}
+
+sub response {
+ my $me = shift;
+ my $timeout = ${*$me}{Timeout};
+ my($code,$more,$rin,$rout,$partial,$buf) = (undef,0,'','','','');
+
+ @{*$me} = (); # the responce
+ $buf = ${*$me};
+ my @buf = ();
+
+ vec($rin,fileno($me),1) = 1;
+
+ do
+ {
+ if(length($buf) || ($timeout==0) || select($rout=$rin, undef, undef, $timeout))
+ {
+ unless(length($buf) || sysread($me, $buf, 1024))
+ {
+ carp "Unexpected EOF on command channel";
+ return undef;
+ }
+
+ substr($buf,0,0) = $partial; ## prepend from last sysread
+
+ @buf = split(/\r?\n/, $buf); ## break into lines
+
+ $partial = (substr($buf, -1, 1) eq "\n") ? ''
+ : pop(@buf);
+
+ $buf = "";
+
+ while (@buf)
+ {
+ my $cmd = shift @buf;
+ print STDERR "$me<< $cmd\n"
+ if $me->debug;
+
+ ($code,$more) = ($1,$2)
+ if $cmd =~ /^(\d\d\d)(.)/;
+
+ push(@{*$me},$');
+
+ last unless(defined $more && $more eq "-");
+ }
+ }
+ else
+ {
+ carp "$me: Timeout" if($me->debug);
+ return undef;
+ }
+ }
+ while((scalar(@{*$me}) == 0) || (defined $more && $more eq "-"));
+
+ ${*$me} = @buf ? join("\n",@buf,"") : "";
+ ${*$me} .= $partial;
+
+ ${*$me}{Code} = $code;
+ ${*$me}{State} = FTP_READY;
+
+ substr($code,0,1);
+}
+
+;########################################
+;#
+;# RFC959 commands
+;#
+
+sub no_imp { croak "Not implemented\n"; }
+
+sub ABOR { shift->send_cmd("ABOR")->response() == 2}
+sub CDUP { shift->send_cmd("CDUP")->response() == 2}
+sub NOOP { shift->send_cmd("NOOP")->response() == 2}
+sub PASV { shift->send_cmd("PASV")->response() == 2}
+sub QUIT { shift->send_cmd("QUIT")->response() == 2}
+sub DELE { shift->send_cmd("DELE",@_)->response() == 2}
+sub CWD { shift->send_cmd("CWD", @_)->response() == 2}
+sub PORT { shift->send_cmd("PORT",@_)->response() == 2}
+sub RMD { shift->send_cmd("RMD", @_)->response() == 2}
+sub MKD { shift->send_cmd("MKD", @_)->response() == 2}
+sub PWD { shift->send_cmd("PWD", @_)->response() == 2}
+sub TYPE { shift->send_cmd("TYPE",@_)->response() == 2}
+sub APPE { shift->send_cmd("APPE",@_)->response() == 1}
+sub LIST { shift->send_cmd("LIST",@_)->response() == 1}
+sub NLST { shift->send_cmd("NLST",@_)->response() == 1}
+sub RETR { shift->send_cmd("RETR",@_)->response() == 1}
+sub STOR { shift->send_cmd("STOR",@_)->response() == 1}
+sub STOU { shift->send_cmd("STOU",@_)->response() == 1}
+sub RNFR { shift->send_cmd("RNFR",@_)->response() == 3}
+sub RNTO { shift->send_cmd("RNTO",@_)->response() == 2}
+sub ACCT { shift->send_cmd("ACCT",@_)->response() == 2}
+sub RESP { shift->send_cmd("RESP",@_)->response() == 2}
+sub REST { shift->send_cmd("REST",@_)->response() == 3}
+sub USER { my $ok = shift->send_cmd("USER",@_)->response();($ok == 2 || $ok == 3) ? $ok : 0;}
+sub PASS { my $ok = shift->send_cmd("PASS",@_)->response();($ok == 2 || $ok == 3) ? $ok : 0;}
+sub AUTH { my $ok = shift->send_cmd("AUTH",@_)->response();($ok == 2 || $ok == 3) ? $ok : 0;}
+
+sub ALLO { no_imp; }
+sub SMNT { no_imp; }
+sub HELP { no_imp; }
+sub MODE { no_imp; }
+sub SITE { no_imp; }
+sub SYST { no_imp; }
+sub STAT { no_imp; }
+sub STRU { no_imp; }
+sub REIN { no_imp; }
+
+package Net::FTP::dataconn;
+use Carp;
+no strict 'vars';
+
+sub abort {
+ my $fd = shift;
+ my $ftp = ${*$fd}{Cmd};
+
+ $ftp->send_cmd("ABOR");
+ $fd->close();
+}
+
+sub close {
+ my $fd = shift;
+ my $ftp = ${*$fd}{Cmd};
+
+ $fd->Net::Socket::close();
+ delete ${*$ftp}{DATA};
+
+ $ftp->response();
+}
+
+sub timeout {
+ my $me = shift;
+ my $timeout = ${*$me}{Timeout};
+
+ ${*$me}{Timeout} = 0 + shift if(@_);
+
+ $timeout;
+}
+
+sub _select {
+ my $fd = shift;
+ local *timeout = \$_[0]; shift;
+ my $rw = shift;
+ my($rin,$win);
+
+ return 1 unless $timeout;
+
+ $rin = '';
+ vec($rin,fileno($fd),1) = 1;
+
+ $win = $rw ? undef : $rin;
+ $rin = undef unless $rw;
+
+ my $nfound = select($rin, $win, undef, $timeout);
+
+ croak "select: $!"
+ if $nfound < 0;
+
+ return $nfound;
+}
+
+sub can_read {
+ my $fd = shift;
+ local *timeout = \$_[0];
+
+ $fd->_select($timeout,1);
+}
+
+sub can_write {
+ my $fd = shift;
+ local *timeout = \$_[0];
+
+ $fd->_select($timeout,0);
+}
+
+sub cmd {
+ my $me = shift;
+
+ ${*$me}{Cmd};
+}
+
+
+@Net::FTP::L::ISA = qw(Net::FTP::I);
+@Net::FTP::E::ISA = qw(Net::FTP::I);
+
+package Net::FTP::A;
+@Net::FTP::A::ISA = qw(Net::FTP::dataconn);
+use Carp;
+
+no strict 'vars';
+
+sub read {
+ my $fd = shift;
+ local *buf = \$_[0]; shift;
+ my $size = shift || croak 'read($buf,$size,[$offset])';
+ my $offset = shift || 0;
+ my $timeout = ${*$fd}{Timeout};
+ my $l;
+
+ croak "Bad offset"
+ if($offset < 0);
+
+ $offset = length $buf
+ if($offset > length $buf);
+
+ $l = 0;
+ READ:
+ {
+ $fd->can_read($timeout) or
+ croak "Timeout";
+
+ my $n = sysread($fd, ${*$fd}, $size, length ${*$fd});
+
+ return $n
+ unless($n >= 0);
+
+# my $lf = substr(${*$fd},-1,1) eq "\r" ? chop(${*$fd})
+# : "";
+
+ my $lf = (length ${*$fd} > 0 && substr(${*$fd},-1,1) eq "\r") ? chop(${*$fd})
+ : "";
+
+ ${*$fd} =~ s/\r\n/\n/go;
+
+ substr($buf,$offset) = ${*$fd};
+
+ $l += length(${*$fd});
+ $offset += length(${*$fd});
+
+ ${*$fd} = $lf;
+
+ redo READ
+ if($l == 0 && $n > 0);
+
+ if($n == 0 && $l == 0)
+ {
+ substr($buf,$offset) = ${*$fd};
+ ${*$fd} = "";
+ }
+ }
+
+ return $l;
+}
+
+sub write {
+ my $fd = shift;
+ local *buf = \$_[0]; shift;
+ my $size = shift || croak 'write($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift : ${*$fd}{Timeout};
+
+ $fd->can_write($timeout) or
+ croak "Timeout";
+
+ # What is previous pkt ended in \r or not ??
+
+ my $tmp;
+ ($tmp = $buf) =~ s/(?!\r)\n/\r\n/g;
+
+ my $len = $size + length($tmp) - length($buf);
+ my $wrote = syswrite($fd, $tmp, $len);
+
+ if($wrote >= 0)
+ {
+ $wrote = $wrote == $len ? $size
+ : $len - $wrote
+ }
+
+ return $wrote;
+}
+
+package Net::FTP::I;
+@Net::FTP::I::ISA = qw(Net::FTP::dataconn);
+use Carp;
+
+no strict 'vars';
+
+sub read {
+ my $fd = shift;
+ local *buf = \$_[0]; shift;
+ my $size = shift || croak 'read($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift : ${*$fd}{Timeout};
+
+ $fd->can_read($timeout) or
+ croak "Timeout";
+
+ my $n = sysread($fd, $buf, $size);
+
+ $n;
+}
+
+sub write {
+ my $fd = shift;
+ local *buf = \$_[0]; shift;
+ my $size = shift || croak 'write($buf,$size,[$timeout])';
+ my $timeout = @_ ? shift : ${*$fd}{Timeout};
+
+ $fd->can_write($timeout) or
+ croak "Timeout";
+
+ syswrite($fd, $buf, $size);
+}
+
+=head2 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head2 REVISION
+
+$Revision: 1.17 $
+
+=head2 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
+
+
+1;
+
diff --git a/lib/Net/Netrc.pm b/lib/Net/Netrc.pm
new file mode 100644
index 0000000000..58f066363d
--- /dev/null
+++ b/lib/Net/Netrc.pm
@@ -0,0 +1,123 @@
+package Net::Netrc;
+
+use Carp;
+use strict;
+
+my %netrc = ();
+
+sub _readrc {
+ my $host = shift;
+ my $file = (getpwuid($>))[7] . "/.netrc";
+ my($login,$pass,$acct) = (undef,undef,undef);
+ local *NETRC;
+ local $_;
+
+ $netrc{default} = undef;
+
+ my @stat = stat($file);
+
+ if(@stat)
+ {
+ if($stat[2] & 077)
+ {
+ carp "Bad permissions: $file";
+ return ();
+ }
+ if($stat[4] != $<)
+ {
+ carp "Not owner: $file";
+ return ();
+ }
+ }
+
+ if(open(NETRC,$file))
+ {
+ my($mach,$macdef,$tok,@tok) = (0,0);
+
+ while(<NETRC>)
+ {
+ undef $macdef if /\A\n\Z/;
+
+ if($macdef)
+ {
+ push(@$macdef,$_);
+ next;
+ }
+
+ push(@tok, split(/[\s\n]+/, $_));
+
+TOKEN:
+ while(@tok)
+ {
+ if($tok[0] eq "default")
+ {
+ shift(@tok);
+ $mach = $netrc{default} = {};
+
+ next TOKEN;
+ }
+
+ last TOKEN unless @tok > 1;
+ $tok = shift(@tok);
+
+ if($tok eq "machine")
+ {
+ my $host = shift @tok;
+ $mach = $netrc{$host} = {};
+ }
+ elsif($tok =~ /^(login|password|account)$/)
+ {
+ next TOKEN unless $mach;
+ my $value = shift @tok;
+ $mach->{$1} = $value;
+ }
+ elsif($tok eq "macdef")
+ {
+ next TOKEN unless $mach;
+ my $value = shift @tok;
+ $mach->{macdef} = {} unless exists $mach->{macdef};
+ $macdef = $mach->{machdef}{$value} = [];
+ }
+ }
+ }
+ close(NETRC);
+ }
+}
+
+sub lookup {
+ my $pkg = shift;
+ my $mach = shift;
+
+ _readrc() unless exists $netrc{default};
+
+ return bless \$mach if exists $netrc{$mach};
+
+ return bless \("default") if defined $netrc{default};
+
+ return undef;
+}
+
+sub login {
+ my $me = shift;
+ $me = $netrc{$$me};
+ exists $me->{login} ? $me->{login} : undef;
+}
+
+sub account {
+ my $me = shift;
+ $me = $netrc{$$me};
+ exists $me->{account} ? $me->{account} : undef;
+}
+
+sub password {
+ my $me = shift;
+ $me = $netrc{$$me};
+ exists $me->{password} ? $me->{password} : undef;
+}
+
+sub lpa {
+ my $me = shift;
+ ($me->login, $me->password, $me->account);
+}
+
+1;
diff --git a/lib/Net/Socket.pm b/lib/Net/Socket.pm
new file mode 100644
index 0000000000..d24e625233
--- /dev/null
+++ b/lib/Net/Socket.pm
@@ -0,0 +1,332 @@
+package Net::Socket;
+
+=head1 NAME
+
+Net::Socket - TEMPORARY Socket filedescriptor class, so Net::FTP still
+works while IO::Socket is having a re-fit <GBARR>
+
+=head1 DESCRIPTION
+
+NO TEXT --- THIS MODULE IS TEMPORARY
+
+=cut
+
+require 5.001;
+use Socket 1.3;
+use Carp;
+require Exporter;
+
+@ISA = qw(Exporter);
+@EXPORT_OK = @Socket::EXPORT;
+
+$VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);
+sub Version { $VERSION }
+
+##
+## Really WANT FileHandle::new to return this !!!
+##
+my $seq = 0;
+sub _gensym {
+ my $pkg = @_ ? ref($_[0]) || $_[0] : "";
+ local *{$pkg . "::GLOB" . ++$seq};
+ \delete ${$pkg . "::"}{'GLOB' . $seq};
+}
+
+my %socket_type = (
+ tcp => SOCK_STREAM,
+ udp => SOCK_DGRAM,
+ rpc => SOCK_DGRAM,
+);
+
+# Peer => remote host name for a 'connect' socket
+# Proto => specifiy protocol by it self (but override by Service)
+# Service => require service eg 'ftp' or 'ftp/tcp', overrides Proto
+# Port => port num for connect eg 'ftp' or 21, defaults to Service
+# Bind => port to bind to, defaults to INADDR_ANY
+# Listen => queue size for listen
+#
+# if Listen is defined then a listen socket is created, else if the socket
+# type, which is derived from the protocol, is SOCK_STREAM then a connect
+# is called
+
+=head2 new( %args )
+
+The new constructor takes its arguments in the form of a hash. Accepted
+arguments are
+
+ Peer => remote host name for a 'connect' socket
+ Proto => specifiy protocol by it self (but override by Service)
+ Service => require service eg 'ftp' or 'ftp/tcp', overrides Proto
+ Port => port num for connect eg 'ftp' or 21, defaults to Service
+ Bind => port to bind to, defaults to INADDR_ANY
+ Listen => queue size for listen
+
+=cut
+
+sub new {
+ my $pkg = shift;
+ my %arg = @_;
+
+ my $proto = $arg{Proto} || "";
+ my $bindport = $arg{Bind} || 0;
+ my $servport = $arg{Port} || 0;
+
+ my $service = $arg{Service} || $servport || $bindport;
+
+ ($service,$proto) = split(m,/,, $service)
+ if $service =~ m,/,;
+
+ my @serv = $service =~ /\D/ ? getservbyname($service,$proto)
+ : getservbyport($service,$proto);
+
+ $proto = $proto || $serv[3];
+
+ croak "cannot determine protocol"
+ unless $proto;
+
+ my @proto = $proto =~ /\D/ ? getprotobyname($proto)
+ : getprotobynumber($proto);
+
+ croak "unknown protocol"
+ unless @proto;
+
+ my $type = $arg{Type} || $socket_type{$proto[0]} or
+ croak "Unknown socket type";
+
+ my $bindaddr = exists $arg{Addr} ? inet_aton($arg{Addr})
+ : INADDR_ANY;
+
+ croak "bad bind address $arg{Addr}"
+ unless $bindaddr;
+
+ my $sock = bless _gensym(), ref($pkg) || $pkg;
+
+ socket($sock, AF_INET, $type, $proto[2]) or
+ croak "socket: $!";
+
+ $bindport = (getservbyname($bindport,$proto))[2]
+ if $bindport =~ /\D/;
+
+ bind($sock, sockaddr_in($bindport, $bindaddr)) or
+ croak "bind: $!";
+
+ if(defined $arg{Listen})
+ {
+ my $queue = $arg{Listen} || 1;
+
+ listen($sock, $queue) or
+ croak "listen: $!";
+ }
+ else
+ {
+ $servport = $serv[2] || 0
+ unless $servport =~ /^\d+$/ && $servport > 0;
+
+ croak "cannot determine port"
+ unless($servport);
+
+ my $destaddr = defined $arg{Peer} ? inet_aton($arg{Peer})
+ : undef;
+
+ my $peername = defined $destaddr ? sockaddr_in($servport,$destaddr)
+ : undef;
+
+
+ if($type == SOCK_STREAM || $destaddr)
+ {
+ croak "bad peer address"
+ unless defined $destaddr;
+
+ connect($sock, $peername) or
+ croak "connect: $!";
+
+ ${*$sock}{Peername} = getpeername($sock);
+ }
+ else
+ {
+ ${*$sock}{Peername} = $peername;
+ }
+ }
+
+ ${*$sock}{Sockname} = getsockname($sock);
+
+ $sock;
+}
+
+=head2 autoflush( [$val] )
+
+Set the file descriptor to autoflush, depending on C<$val>
+
+=cut
+
+sub autoflush {
+ my $sock = shift;
+ my $val = @_ ? shift : 0;
+
+ select((select($sock), $| = $val)[$[]);
+}
+
+=head2 accept
+
+perform the system call C<accept> on the socket and return a new Net::Socket
+object. This object can be used to communicate with the client that was trying
+to connect.
+
+=cut
+
+sub accept {
+ my $sock = shift;
+
+ my $new = bless _gensym();
+
+ accept($new,$sock) or
+ croak "accept: $!";
+
+ ${*$new}{Peername} = getpeername($new) or
+ croak "getpeername: $!";
+
+ ${*$new}{Sockname} = getsockname($new) or
+ croak "getsockname: $!";
+
+ $new;
+}
+
+=head2 close
+
+Close the file descriptor
+
+=cut
+
+sub close {
+ my $sock = shift;
+
+ delete ${*$sock}{Sockname};
+ delete ${*$sock}{Peername};
+
+ close($sock);
+}
+
+=head2 dup
+
+Create a duplicate of the socket object
+
+=cut
+
+sub dup {
+ my $sock = shift;
+ my $dup = bless _gensym(), ref($sock);
+
+ if(open($dup,">&" . fileno($sock))) {
+ # Copy all the internals
+ ${*$dup} = ${*$sock};
+ @{*$dup} = @{*$sock};
+ %{*$dup} = %{*$sock};
+ }
+ else {
+ undef $dup;
+ }
+
+ $dup;
+}
+
+# Some info about the local socket
+
+=head2 sockname
+
+Return a packed sockaddr structure for the socket
+
+=head2 sockaddr
+
+Return the address part of the sockaddr structure for the socket
+
+=head2 sockport
+
+Return the port number that the socket is using on the local host
+
+=head2 sockhost
+
+Return the address part of the sockaddr structure for the socket in a
+text form xx.xx.xx.xx
+
+=cut
+
+sub sockname { my $sock = shift; ${*$sock}{Sockname} }
+sub sockaddr { (sockaddr_in(shift->sockname))[1]}
+sub sockport { (sockaddr_in(shift->sockname))[0]}
+sub sockhost { inet_ntoa( shift->sockaddr);}
+
+# Some info about the remote socket, for connect-d sockets
+
+=head2 peername, peeraddr, peerport, peerhost
+
+Same as for the sock* functions, but returns the data about the peer
+host instead of the local host.
+
+=cut
+
+sub peername { my $sock = shift; ${*$sock}{Peername} or croak "no peer" }
+sub peeraddr { (sockaddr_in(shift->peername))[1]}
+sub peerport { (sockaddr_in(shift->peername))[0]}
+sub peerhost { inet_ntoa( shift->peeraddr);}
+
+=head2 send( $buf [, $flags [, $to]] )
+
+For a udp socket, send the contents of C<$buf> to the remote host C<$to> using
+flags C<$flags>.
+
+If C<$to> is not specified then the data is sent to the host which the socket
+last communicated with, ie sent to or recieved from.
+
+If C<$flags> is ommited then 0 is used
+
+=cut
+
+sub send {
+ my $sock = shift;
+ local *buf = \$_[0]; shift;
+ my $flags = shift || 0;
+ my $to = shift || $sock->peername;
+
+ # remember who we send to
+ ${*$sock}{Peername} = $to;
+
+ send($sock, $buf, $flags, $to);
+}
+
+=head2 recv( $buf, $len [, $flags] )
+
+Receive C<$len> bytes of data from the socket and place into C<$buf>
+
+If C<$flags> is ommited then 0 is used
+
+=cut
+
+sub recv {
+ my $sock = shift;
+ local *buf = \$_[0]; shift;
+ my $len = shift;
+ my $flags = shift || 0;
+
+ # remember who we recv'd from
+ ${*$sock}{Peername} = recv($sock, $buf='', $len, $flags);
+}
+
+=head1 AUTHOR
+
+Graham Barr <Graham.Barr@tiuk.ti.com>
+
+=head1 REVISION
+
+$Revision: 1.2 $
+
+=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
+
+1; # Keep require happy
+
+
diff --git a/lib/Net/hostent.pm b/lib/Net/hostent.pm
new file mode 100644
index 0000000000..1eeaae3393
--- /dev/null
+++ b/lib/Net/hostent.pm
@@ -0,0 +1,147 @@
+package Net::hostent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @ISA = qw(Exporter);
+ @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;
+
+use Class::Template 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 addresses. The aliases and
+addresses methods return array reference, the rest scalars. The addr
+method is equivalent to the zeroth element in the addresses 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::Template
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/lib/Net/netent.pm b/lib/Net/netent.pm
new file mode 100644
index 0000000000..9f385b06d1
--- /dev/null
+++ b/lib/Net/netent.pm
@@ -0,0 +1,165 @@
+package Net::netent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @ISA = qw(Exporter);
+ @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;
+
+use Class::Template 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::Template
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/lib/Net/protoent.pm b/lib/Net/protoent.pm
new file mode 100644
index 0000000000..ffd6acd587
--- /dev/null
+++ b/lib/Net/protoent.pm
@@ -0,0 +1,92 @@
+package Net::protoent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @ISA = qw(Exporter);
+ @EXPORT = qw(getprotobyname getprotobynumber getprotoent);
+ @EXPORT_OK = qw( $p_name @p_aliases $p_proto );
+ %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
+}
+use vars @EXPORT_OK;
+
+use Class::Template 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::Template
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/lib/Net/servent.pm b/lib/Net/servent.pm
new file mode 100644
index 0000000000..8c0fc13890
--- /dev/null
+++ b/lib/Net/servent.pm
@@ -0,0 +1,109 @@
+package Net::servent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @ISA = qw(Exporter);
+ @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;
+
+use Class::Template 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::Template
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/lib/Pod/Text.pm b/lib/Pod/Text.pm
index 1411587538..c43172854a 100644
--- a/lib/Pod/Text.pm
+++ b/lib/Pod/Text.pm
@@ -1,6 +1,6 @@
package Pod::Text;
-# Version 1.01
+# Version 1.02
=head1 NAME
@@ -28,13 +28,13 @@ 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
+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
@@ -73,8 +73,8 @@ if($termcap and !$setuptermcap) {
}
$SCREEN = ($_[0] =~ /^-(\d+)/ && (shift, $1))
- || ($ENV{TERMCAP} =~ /co#(\d+)/)[0]
|| $ENV{COLUMNS}
+ || ($ENV{TERMCAP} =~ /co#(\d+)/)[0]
|| (`stty -a 2>/dev/null` =~ /(\d+) columns/)[0]
|| 72;
@@ -116,14 +116,14 @@ sub prepare_for_output {
$maxnest = 10;
while ($maxnest-- && /[A-Z]</) {
unless ($FANCY) {
- s/C<(.*?)>/`$1'/g;
+ 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 +167,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);
}
diff --git a/lib/Search/Dict.pm b/lib/Search/Dict.pm
index 295da6b31d..1cd5cf8a11 100644
--- a/lib/Search/Dict.pm
+++ b/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;
}
@@ -65,7 +65,7 @@ sub look {
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/lib/SelfLoader.pm b/lib/SelfLoader.pm
index 136d42bef1..11dc6a24bf 100644
--- a/lib/SelfLoader.pm
+++ b/lib/SelfLoader.pm
@@ -230,7 +230,7 @@ that filehandle (and ONLY if you want to), you should either
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->load_stubs();', or by using a
+reads first by calling 'SelfLoader-E<gt>load_stubs();', or by using a
function which is selfloaded;
or
@@ -258,7 +258,7 @@ 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 C<__DATA__> token BEFORE
diff --git a/lib/Symbol.pm b/lib/Symbol.pm
index 3f99fc545a..75d1dfb1fa 100644
--- a/lib/Symbol.pm
+++ b/lib/Symbol.pm
@@ -34,7 +34,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
@@ -46,7 +46,7 @@ which are qualified by their nature.
=cut
-use 5.002;
+BEGIN { require 5.002; }
require Exporter;
@ISA = qw(Exporter);
@@ -56,12 +56,7 @@ require Exporter;
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);
sub gensym () {
my $name = "GEN" . $genseq++;
@@ -88,13 +83,3 @@ sub qualify ($;$) {
}
1;
-
-__DATA__
-ARGV
-ARGVOUT
-ENV
-INC
-SIG
-STDERR
-STDIN
-STDOUT
diff --git a/lib/Sys/Hostname.pm b/lib/Sys/Hostname.pm
index d527e4525f..ec04efc889 100644
--- a/lib/Sys/Hostname.pm
+++ b/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
diff --git a/lib/Sys/Syslog.pm b/lib/Sys/Syslog.pm
index 9df3161a63..ee90127340 100644
--- a/lib/Sys/Syslog.pm
+++ b/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
#
@@ -85,7 +86,7 @@ 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>
=cut
@@ -190,10 +191,10 @@ 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 {
diff --git a/lib/Term/Cap.pm b/lib/Term/Cap.pm
index 656889591a..5a73ecfc52 100644
--- a/lib/Term/Cap.pm
+++ b/lib/Term/Cap.pm
@@ -195,6 +195,7 @@ sub Tgetent { ## public -- static method
last;
}
}
+ defined $entry or $entry = '';
$entry .= $_;
};
diff --git a/lib/Term/Complete.pm b/lib/Term/Complete.pm
index 6faef2296e..bdab2ad81d 100644
--- a/lib/Term/Complete.pm
+++ b/lib/Term/Complete.pm
@@ -28,7 +28,7 @@ The following command characters are defined:
=over 4
-=item <tab>
+=item E<lt>tabE<gt>
Attempts word completion.
Cannot be changed.
@@ -42,7 +42,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 +55,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 +71,8 @@ CONFIG: {
}
sub Complete {
+ my($prompt, @cmp_list, $return, @match, $l, $test, $cmp, $r);
+
$prompt = shift;
if (ref $_[0] || $_[0] =~ /^\*/) {
@cmp_lst = sort @{$_[0]};
diff --git a/lib/Term/ReadLine.pm b/lib/Term/ReadLine.pm
index 2ce7423186..88fc6386c3 100644
--- a/lib/Term/ReadLine.pm
+++ b/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,7 @@ 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 C<Features>
diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm
index 2a89f20dde..cca05b7291 100644
--- a/lib/Test/Harness.pm
+++ b/lib/Test/Harness.pm
@@ -1,19 +1,40 @@
package Test::Harness;
-use 5.002;
+require 5.002;
+
use Exporter;
use Benchmark;
use Config;
use FileHandle;
-use vars qw($VERSION $verbose $switches $have_devel_corestack);
+use strict;
+
+use vars qw($VERSION $verbose $switches $have_devel_corestack $curtest
+ @ISA @EXPORT @EXPORT_OK);
$have_devel_corestack = 0;
-$VERSION = "1.12";
+$VERSION = "1.13";
@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}
+}
+.
+
$verbose = 0;
$switches = "-w";
@@ -21,12 +42,13 @@ $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;
+ my $old5lib = $ENV{PERL5LIB};
local($ENV{'PERL5LIB'}) = join($Config{path_sep}, @INC); # pass -I flags to children
my $t_start = new Benchmark;
@@ -35,7 +57,8 @@ sub runtests {
chop($te);
print "$te" . '.' x (20 - length($te));
my $fh = new FileHandle;
- $fh->open("$^X $switches $test|") || (print "can't run. $!\n");
+ if ($^O eq 'VMS') { $fh->open("MCR $^X $switches $test|") || (print "can't run. $!\n"); }
+ else { $fh->open("$^X $switches $test|") || (print "can't run. $!\n"); }
$ok = $next = $max = 0;
@failed = ();
while (<$fh>) {
@@ -82,6 +105,11 @@ sub runtests {
}
}
$bad++;
+ $failedtests{$test} = { canon => '??', max => $max || '??',
+ failed => '??',
+ name => $test, percent => undef,
+ estat => $estatus, wstat => $wstatus,
+ };
} elsif ($ok == $max && $next == $max+1) {
if ($max) {
print "ok\n";
@@ -94,18 +122,35 @@ sub runtests {
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: got $ok ok, expected $max\n";
+ $failedtests{$test} = { canon => '??', max => $max,
+ failed => '??',
+ name => $test, percent => undef,
+ estat => '', wstat => '',
+ };
}
$bad++;
} elsif ($next == 0) {
print "FAILED before any test output arrived\n";
$bad++;
+ $failedtests{$test} = { canon => '??', max => '??',
+ failed => '??',
+ name => $test, percent => undef,
+ estat => '', wstat => '',
+ };
}
}
my $t_total = timediff(new Benchmark, $t_start);
+ if ($^O eq 'VMS' and defined($old5lib)) { $ENV{PERL5LIB} = $old5lib; }
if ($bad == 0 && $totmax) {
print "All tests successful.\n";
} elsif ($total==0){
@@ -117,13 +162,18 @@ sub runtests {
$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 > 1) {
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) ;
}
sub corestatus {
@@ -154,6 +204,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) {
@@ -168,13 +219,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;
@@ -252,7 +306,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>
diff --git a/lib/Text/Abbrev.pm b/lib/Text/Abbrev.pm
index d12dfb36a6..893f3b1729 100644
--- a/lib/Text/Abbrev.pm
+++ b/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,13 +39,21 @@ 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;
+ my @extra = split(//,$name);
+ my $abbrev = shift(@extra);
+ my $len = 1;
+ my $cmp;
foreach $cmp (@cmp) {
next if $cmp eq $name;
while (substr($cmp,0,$len) eq $abbrev) {
@@ -53,6 +67,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/lib/Text/ParseWords.pm b/lib/Text/ParseWords.pm
index 317597cb83..f86c8c2991 100644
--- a/lib/Text/ParseWords.pm
+++ b/lib/Text/ParseWords.pm
@@ -115,7 +115,7 @@ sub quotewords {
last;
}
else {
- while (length($_) && !(/^$delim/ || /^['"\\]/)) {
+ while ($_ ne '' && !(/^$delim/ || /^['"\\]/)) {
$snippet .= substr($_, 0, 1);
substr($_, 0, 1) = '';
}
diff --git a/lib/Text/Soundex.pm b/lib/Text/Soundex.pm
index a334404667..ddc758c94e 100644
--- a/lib/Text/Soundex.pm
+++ b/lib/Text/Soundex.pm
@@ -48,7 +48,7 @@ sub soundex
foreach (@s)
{
- tr/a-z/A-Z/;
+ $_ = uc $_;
tr/A-Z//cd;
if ($_ eq '')
diff --git a/lib/Text/Tabs.pm b/lib/Text/Tabs.pm
index 8cc0d92f23..acd7afb7d6 100644
--- a/lib/Text/Tabs.pm
+++ b/lib/Text/Tabs.pm
@@ -7,7 +7,7 @@ require Exporter;
@EXPORT = qw(expand unexpand $tabstop);
use vars qw($VERSION $tabstop $debug);
-$VERSION = 96.051501;
+$VERSION = 96.121201;
use strict;
@@ -27,7 +27,7 @@ sub expand
/sex;
}
return @l if wantarray;
- return @l[0];
+ return $l[0];
}
sub unexpand
@@ -60,7 +60,7 @@ sub unexpand
$x = join("\n", @lines);
}
return @l if wantarray;
- return @l[0];
+ return $l[0];
}
1;
diff --git a/lib/Text/Wrap.pm b/lib/Text/Wrap.pm
index 8f8cdccd48..96ccf7ee2d 100644
--- a/lib/Text/Wrap.pm
+++ b/lib/Text/Wrap.pm
@@ -17,7 +17,6 @@ BEGIN {
}
use Text::Tabs;
-use strict;
sub wrap
{
@@ -64,6 +63,7 @@ sub wrap
return $r;
}
+
1;
__DATA__
@@ -83,7 +83,7 @@ Text::Wrap - line wrapping to form simple paragraphs
=head1 DESCRIPTION
-Text::Wrap is a very simple paragraph formatter. It formats a
+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
@@ -96,6 +96,38 @@ should be set to the full width of your output device.
=head1 AUTHOR
-David Muir Sharnoff <muir@idiom.com>
+David Muir Sharnoff <muir@idiom.com> with help from Tim Pierce and
+others.
=cut
+
+ 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/lib/Tie/RefHash.pm b/lib/Tie/RefHash.pm
new file mode 100644
index 0000000000..66de2572fc
--- /dev/null
+++ b/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/lib/Time/Local.pm b/lib/Time/Local.pm
index 40e8da796b..0119f9ddb8 100644
--- a/lib/Time/Local.pm
+++ b/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
@@ -40,12 +40,12 @@ after the 1st of January, 2038 on most machines.
=cut
BEGIN {
- @epoch = localtime(0);
-
$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;
my $t = time;
@@ -71,13 +71,13 @@ BEGIN {
sub timegm {
$ym = pack(C2, @_[5,4]);
$cheat = $cheat{$ym} || &cheat;
- return -1 if $cheat<0;
+ return -1 if $cheat<0 and $^O ne 'VMS';
$cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY;
}
sub timelocal {
$time = &timegm + $tzsec;
- return -1 if $cheat<0;
+ return -1 if $cheat<0 and $^O ne 'VMS';
@test = localtime($time);
$time -= $HR if $test[2] != $_[2];
$time;
@@ -88,19 +88,14 @@ sub cheat {
$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 = "";
while ($diff = $year - $g[5]) {
$guess += $diff * (363 * $DAY);
diff --git a/lib/Time/gmtime.pm b/lib/Time/gmtime.pm
new file mode 100644
index 0000000000..35233f586a
--- /dev/null
+++ b/lib/Time/gmtime.pm
@@ -0,0 +1,87 @@
+package Time::gmtime;
+use strict;
+use Time::tm;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @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 ] );
+}
+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.pm - 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::Template
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/lib/Time/localtime.pm b/lib/Time/localtime.pm
new file mode 100644
index 0000000000..2e811e627f
--- /dev/null
+++ b/lib/Time/localtime.pm
@@ -0,0 +1,83 @@
+package Time::localtime;
+use strict;
+use Time::tm;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @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 ] );
+}
+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.pm - 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::Template
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/lib/Time/tm.pm b/lib/Time/tm.pm
new file mode 100644
index 0000000000..87fc883b88
--- /dev/null
+++ b/lib/Time/tm.pm
@@ -0,0 +1,27 @@
+package Time::tm;
+use strict;
+
+use Class::Template qw(struct);
+struct('Time::tm' => [
+ map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst }
+]);
+
+1;
+__END__
+
+=head1 NAME
+
+Time::tm.pm - internal object used by Time::gmtime and Time::localtime
+
+=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/lib/UNIVERSAL.pm b/lib/UNIVERSAL.pm
new file mode 100644
index 0000000000..c006547db0
--- /dev/null
+++ b/lib/UNIVERSAL.pm
@@ -0,0 +1,81 @@
+package UNIVERSAL;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(isa);
+
+1;
+__END__
+
+=head1 NAME
+
+UNIVERSAL - base class for ALL classes (blessed references)
+
+=head1 SYNOPSIS
+
+ use UNIVERSAL qw(isa);
+
+ $yes = isa($ref, "HASH");
+ $io = $fd->isa("IO::Handle");
+ $sub = $obj->can('print');
+
+=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 the 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
+
+C<UNIVERSAL> also optionally exports the following subroutines
+
+=over 4
+
+=item isa ( REF, 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<REF> is a blessed reference and is blessed into package C<TYPE>
+or inherits from package C<TYPE>
+
+=item
+
+C<REF> is a reference to a C<TYPE> of perl variable (er 'HASH')
+
+=back
+
+=back
+
+=cut
diff --git a/lib/User/grent.pm b/lib/User/grent.pm
new file mode 100644
index 0000000000..1185958430
--- /dev/null
+++ b/lib/User/grent.pm
@@ -0,0 +1,91 @@
+package User::grent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @ISA = qw(Exporter);
+ @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;
+
+use Class::Template 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.pm - 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::Template
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/lib/User/pwent.pm b/lib/User/pwent.pm
new file mode 100644
index 0000000000..fd4eb4f09d
--- /dev/null
+++ b/lib/User/pwent.pm
@@ -0,0 +1,101 @@
+package User::pwent;
+use strict;
+
+BEGIN {
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @ISA = qw(Exporter);
+ @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;
+
+use Class::Template qw(struct);
+struct 'User::pwent' => [
+ name => '$',
+ passwd => '$',
+ uid => '$',
+ gid => '$',
+ quota => '$',
+ comment => '$',
+ gcos => '$',
+ 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 getpwgid ($) { populate(CORE::getpwgid(shift)) }
+sub getpw ($) { ($_[0] =~ /^\d+/) ? &getpwgid : &getpwnam }
+
+1;
+__END__
+
+=head1 NAME
+
+User::pwent.pm - 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::Template
+module to build a struct-like class, you shouldn't rely upon this.
+
+=head1 AUTHOR
+
+Tom Christiansen
diff --git a/lib/abbrev.pl b/lib/abbrev.pl
index c233d4af7e..62975e66f3 100644
--- a/lib/abbrev.pl
+++ b/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/lib/bigint.pl b/lib/bigint.pl
index e6ba644e3b..bfd2efa88c 100644
--- a/lib/bigint.pl
+++ b/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/lib/blib.pm b/lib/blib.pm
new file mode 100644
index 0000000000..8af1727d8f
--- /dev/null
+++ b/lib/blib.pm
@@ -0,0 +1,70 @@
+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;
+
+
+sub import
+{
+ my $package = shift;
+ my $dir = getcwd;
+ if (@_)
+ {
+ print join(',',@_),"\n";
+ $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/lib/complete.pl b/lib/complete.pl
index 1e08f9145a..335245269c 100644
--- a/lib/complete.pl
+++ b/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, *_) = @_;
}
diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm
index f20b956b7d..31e7670b82 100644..100755
--- a/lib/diagnostics.pm
+++ b/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{'privlibexp'}) .
- '/pod/perldiag.pod';
-}
-else { $diagnostics::PODFILE= $Config{privlibexp} . "/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.
@@ -176,6 +162,18 @@ Tom Christiansen F<E<lt>tchrist@mox.perl.comE<gt>>, 25 June 1995.
=cut
+require 5.001;
+use English;
+use Carp;
+
+use Config;
+if ($^O eq 'VMS') {
+ $PODFILE = VMS::Filespec::unixify($Config{privlibexp}).'/pod/perldiag.pod';
+}
+else {
+ $PODFILE = $Config{privlibexp} . "/pod/perldiag.pod";
+}
+
$DEBUG ||= 0;
my $WHOAMI = ref bless []; # nobody's business, prolly not even mine
@@ -334,7 +332,8 @@ EOFUNC
$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} = '';
}
@@ -415,10 +414,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
diff --git a/lib/getcwd.pl b/lib/getcwd.pl
index d8860181c1..9dd694500c 100644
--- a/lib/getcwd.pl
+++ b/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[$[] ||
diff --git a/lib/getopts.pl b/lib/getopts.pl
index a0818d1e3a..852aae89b1 100644
--- a/lib/getopts.pl
+++ b/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/lib/lib.pm b/lib/lib.pm
index 8748613588..8ca28de3ea 100644
--- a/lib/lib.pm
+++ b/lib/lib.pm
@@ -11,9 +11,11 @@ my $archname = $Config{'archname'};
sub import {
shift;
foreach (reverse @_) {
- unless (defined $_ and $_ ne '') {
+ ## Ignore this if not defined.
+ next unless defined($_);
+ if ($_ eq '') {
require Carp;
- Carp::carp("Empty or undefined compile time value given"); # at foo.pl line ...
+ 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
diff --git a/lib/locale.pm b/lib/locale.pm
new file mode 100644
index 0000000000..48213ab86c
--- /dev/null
+++ b/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/lib/look.pl b/lib/look.pl
index 4c14e64727..e8dc8aacb6 100644
--- a/lib/look.pl
+++ b/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/lib/newgetopt.pl b/lib/newgetopt.pl
index d284b5b192..0b7eed8bfe 100644
--- a/lib/newgetopt.pl
+++ b/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.16 1996/03/16 11:46:08 jv Exp $
+# $Id: newgetopt.pl,v 1.17 1996-10-02 11:17:16+02 jv Exp $
{ package newgetopt;
@@ -16,6 +16,7 @@
$option_start = "(--|-)";
$order = $REQUIRE_ORDER;
$bundling = 0;
+ $passthrough = 0;
}
else {
$autoabbrev = 1; # automatic abbrev of options
@@ -23,6 +24,7 @@
$option_start = "(--|-|\\+)";
$order = $PERMUTE;
$bundling = 0;
+ $passthrough = 0;
}
# Other configurable settings.
@@ -51,6 +53,10 @@ sub NGetOpt {
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/lib/open3.pl b/lib/open3.pl
index 03e151c2d6..8b3917a851 100644
--- a/lib/open3.pl
+++ b/lib/open3.pl
@@ -68,10 +68,10 @@ sub main'open3 {
die "open2: fork failed: $!";
} elsif ($kidpid == 0) {
if ($dup_wtr) {
- open(STDIN, ">&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr));
+ open(STDIN, "<&$dad_wtr") if (fileno(STDIN) != fileno($dad_wtr));
} else {
close($dad_wtr);
- open(STDIN, ">&$kid_rdr");
+ open(STDIN, "<&$kid_rdr");
}
if ($dup_rdr) {
open(STDOUT, ">&$dad_rdr") if (fileno(STDOUT) != fileno($dad_rdr));
diff --git a/lib/overload.pm b/lib/overload.pm
index 28e7d0b3e7..20411ea576 100644
--- a/lib/overload.pm
+++ b/lib/overload.pm
@@ -203,7 +203,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>
@@ -376,7 +376,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
@@ -476,7 +476,7 @@ 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
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 35ce69a8f9..15b5295e06 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -2,7 +2,7 @@ package DB;
# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 0.95;
+$VERSION = 0.97;
$header = "perl5db.pl patch level $VERSION";
# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
@@ -17,14 +17,35 @@ $header = "perl5db.pl patch level $VERSION";
# 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(*{"_<$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 @{"_<$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 $
@@ -64,8 +85,6 @@ $header = "perl5db.pl patch level $VERSION";
# information into db.out. (If you interrupt it, you would better
# reset LineInfo to something "interactive"!)
#
-# Changes: 0.95: v command shows versions.
-
##################################################################
# Changelog:
@@ -82,6 +101,29 @@ $header = "perl5db.pl patch level $VERSION";
# 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.
+
####################################################################
# Needed for the statement after exec():
@@ -101,7 +143,7 @@ warn ( # Do not ;-)
@ARGS,
$Carp::CarpLevel,
$panic,
- $first_time,
+ $second_time,
) if 0;
# Command-line + PERLLIB:
@@ -111,18 +153,14 @@ warn ( # Do not ;-)
$trace = $signal = $single = 0; # Uninitialized warning suppression
# (local $^W cannot help - other packages!).
-$doret = -2;
-$frame = 0;
-@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
+ globPrint PrintRet UsageOnly frame AutoTrace
TTY noTTY ReadLine NonStop LineInfo
recallCommand ShellBang pager tkRunning
- signalLevel warnLevel dieLevel);
+ signalLevel warnLevel dieLevel inhibit_exit);
%optionVars = (
hashDepth => \$dumpvar::hashDepth,
@@ -134,7 +172,9 @@ $option{PrintRet} = 1;
globPrint => \$dumpvar::globPrint,
tkRunning => \$readline::Tk_toloop,
UsageOnly => \$dumpvar::usageOnly,
- frame => \$frame,
+ frame => \$frame,
+ AutoTrace => \$trace,
+ inhibit_exit => \$inhibit_exit,
);
%optionAction = (
@@ -165,6 +205,9 @@ $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);
@@ -194,9 +237,11 @@ 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) {
+ %{$postponed_file{$had_breakpoints[$_]}} = get_list("PERLDB_FILE_$_");
}
my %opt = get_list("PERLDB_OPT");
my ($opt,$val);
@@ -277,30 +322,23 @@ if (defined &afterinit) { # May be defined in $rcfile
############################################################ 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;
($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}++;
$max = $#dbline;
if (($stop,$action) = split(/\0/,$dbline{$line})) {
if ($stop eq '1') {
@@ -310,7 +348,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";
@@ -322,43 +362,51 @@ 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;
+ map {$evalarg = $_, &eval} @$pre;
print $OUT $#stack . " levels deep in subroutine calls!\n"
if $single & 4;
$start = $line;
+ @typeahead = @$pretype, @typeahead;
CMD:
while (($term || &setterm),
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 =~ /^q$/ && ($exiting = 1) && exit 0;
$cmd =~ /^$/ && ($cmd = $laststep);
push(@hist,$cmd) if length($cmd) > 1;
PIPE: {
@@ -372,8 +420,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";
}
@@ -425,11 +475,10 @@ sub DB {
}}
}
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}++;
$max = $#dbline;
$filename = $file;
$start = 1;
@@ -445,7 +494,6 @@ sub DB {
$file = join(':', @pieces);
if ($file ne $filename) {
*dbline = "::_<$file";
- $visited{$file}++;
$max = $#dbline;
$filename = $file;
}
@@ -497,7 +545,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];
@@ -508,7 +556,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 = "::_<$file";
+ my $max = $#dbline;
+ my $was;
+
for ($i = 1; $i <= $max ; $i++) {
if (defined $dbline{$i}) {
$dbline{$i} =~ s/^[^\0]+//;
@@ -517,19 +571,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 = "::_<$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}};
+ next unless keys %db;
+ print $OUT " $file:\n";
+ for $line (sort {$a <=> $b} keys %db) {
+ print $OUT " $i:\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;
+ {
+ $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\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
+ my $cond = $2 || '1';
+ my $subname = $1;
+ $subname =~ s/\'/::/;
+ $subname = "${'package'}::" . $subname
+ unless $subname =~ /::/;
+ $subname = "main".$subname if substr($subname,0,2) eq "::";
+ $postponed{$subname} = "break +0 if $cond";
next CMD; };
$cmd =~ /^b\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
$subname = $1;
@@ -544,7 +668,7 @@ sub DB {
if ($i) {
$filename = $file;
*dbline = "::_<$filename";
- $visited{$filename}++;
+ $had_breakpoints{$filename} = 1;
$max = $#dbline;
++$i while $dbline[$i] == 0 && $i < $max;
$dbline{$i} =~ s/^[^\0]*/$cond/;
@@ -558,6 +682,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; };
@@ -567,13 +692,20 @@ sub DB {
delete $dbline{$i} if $dbline{$i} eq '';
next CMD; };
$cmd =~ /^A$/ && do {
+ my $file;
+ for $file (keys %had_breakpoints) {
+ local *dbline = "::_<$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($_);
@@ -582,11 +714,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;
@@ -598,14 +745,17 @@ 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 {
+ end_report(), next CMD if $finished and $level <= 1;
$i = $1;
if ($i =~ /\D/) { # subroutine name
($file,$i) = ($sub{$i} =~ /^(.*):(.*)$/);
@@ -613,7 +763,7 @@ sub DB {
if ($i) {
$filename = $file;
*dbline = "::_<$filename";
- $visited{$filename}++;
+ $had_breakpoints{$filename}++;
$max = $#dbline;
++$i while $dbline[$i] == 0 && $i < $max;
} else {
@@ -633,11 +783,12 @@ sub DB {
}
last CMD; };
$cmd =~ /^r$/ && do {
+ end_report(), next CMD if $finished and $level <= 1;
$stack[$#stack] |= 1;
$doret = $option{PrintRet} ? $#stack - 1 : -2;
last CMD; };
$cmd =~ /^R$/ && do {
- print $OUT "Warning: 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
@@ -658,52 +809,63 @@ 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 = "::_<$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 = "::_<$_";
+ 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);
$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;
@@ -767,7 +929,7 @@ sub DB {
$cmd = $hist[$i] . "\n";
print $OUT $cmd;
redo CMD; };
- $cmd =~ /^$sh$sh\s*([\x00-\xff]]*)/ && do {
+ $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
&system($1);
next CMD; };
$cmd =~ /^$rc([^$rc].*)$/ && do {
@@ -797,8 +959,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~";
@@ -832,7 +994,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;
@@ -844,7 +1006,6 @@ 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;
@@ -861,7 +1022,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 {
@@ -872,9 +1033,8 @@ sub DB {
$piped= "";
}
} # CMD:
- if ($post) {
- $evalarg = $post; &eval;
- }
+ $exiting = 1 unless defined $cmd;
+ map {$evalarg = $_; &eval} @$post;
} # if ($single || $signal)
($@, $!, $,, $/, $\, $^W) = @saved;
();
@@ -888,23 +1048,33 @@ sub sub {
if ($sub =~ /::AUTOLOAD$/) {
$al = " for $ {$` . '::AUTOLOAD'}";
}
- print $LINEINFO ' ' x $#stack, "entering $sub$al\n" if $frame;
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);
print ($OUT "list context return from $sub:\n"), dumpit( \@ret ),
$doret = -2 if $doret eq $#stack;
- print $LINEINFO ' ' x $#stack, "exited $sub$al\n" if $frame > 1;
+ ($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;
@ret;
} else {
$ret = &$sub;
$single |= pop(@stack);
print ($OUT "scalar context return from $sub: "), dumpit( $ret ),
$doret = -2 if $doret eq $#stack;
- print $LINEINFO ' ' x $#stack, "exited $sub$al\n" if $frame > 1;
+ ($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;
$ret;
}
}
@@ -929,6 +1099,7 @@ sub eval {
$^D = $od;
}
my $at = $@;
+ local $saved[0]; # Preserve the old value of $@
eval "&DB::save";
if ($at) {
print $OUT $at;
@@ -937,16 +1108,46 @@ sub eval {
}
}
-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) = ($sub{$subname} =~ /^(.*):(\d+)-.*$/);
+ $i += $offset;
+ if ($i) {
+ local *dbline = "::_<$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;
}
+ #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};
+ }
+ undef %{$postponed_file{$filename}};
}
sub dumpit {
@@ -969,6 +1170,82 @@ sub dumpit {
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
+ for ($i=0; $i <= $#sub; $i++) {
+ last if $signal;
+ local $" = ', ';
+ my $args = defined $sub[$i]{args}
+ ? "(@{ $sub[$i]{args} })"
+ : '' ;
+ my $file = $sub[$i]{file};
+ $file = $file eq '-e' ? $file : "file `$file'" unless $short;
+ if ($short) {
+ my $sub = @_ >= 4 ? $_[3] : $sub[$i]{sub};
+ print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
+ } else {
+ print $fh "$sub[$i]{context} = $sub[$i]{sub}$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/\\$//) {
@@ -1032,6 +1309,12 @@ sub setterm {
$readline::rl_basic_word_break_characters .= "[:"
if defined $readline::rl_basic_word_break_characters
and index($readline::rl_basic_word_break_characters, ":") == -1;
+ $readline::rl_special_prefixes =
+ $readline::rl_special_prefixes = '$@&%';
+ $readline::rl_completer_word_break_characters =
+ $readline::rl_completer_word_break_characters . '$@&%';
+ $readline::rl_completion_function =
+ $readline::rl_completion_function = \&db_complete;
}
$LINEINFO = $OUT unless defined $LINEINFO;
$lineinfo = $console unless defined $lineinfo;
@@ -1057,6 +1340,14 @@ sub 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}};
@@ -1067,12 +1358,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/([\\\'])/\\$1/g;
- printf $OUT "%20s = '%s'\n", $opt, $val;
+ $val
}
sub parse_options {
@@ -1147,6 +1437,7 @@ sub get_list {
sub catch {
$signal = 1;
+ return; # Put nothing on the stack - malloc/free land!
}
sub warn {
@@ -1244,6 +1535,7 @@ sub list_versions {
s,\.p[lm]$,,i ;
s,/,::,g ;
s/^perl5db$/DB/;
+ s/^Term::ReadLine::readline$/readline/;
if (defined $ { $_ . '::VERSION' }) {
$version{$file} = "$ { $_ . '::VERSION' } from ";
}
@@ -1265,8 +1557,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.
@@ -1275,10 +1567,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.
@@ -1287,6 +1579,10 @@ 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.
d [line] Delete the breakpoint for line.
D Delete all breakpoints.
a [line] command
@@ -1303,6 +1599,9 @@ O [opt[=val]] [opt\"val\"] [opt?]...
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;
@@ -1310,15 +1609,18 @@ 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.
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.
+< 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.
@@ -1328,17 +1630,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.
v Show versions of loaded modules.
-R Pure-man-restart of debugger, debugger state and command-line
- options are lost.
+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";
@@ -1348,11 +1653,11 @@ List/search source lines: Control script execution:
w [line] List around line n [expr] Next, steps over subs
f filename View source in file <CR> Repeat last n or s
/pattern/ ?patt? Search forw/backw r Return from subroutine
- v Show versions of modules c [line] Continue until line
+ 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
@@ -1360,19 +1665,19 @@ 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 expr Evals expression in array context, dumps the result.
+ 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;
local $doret = -2;
- $SIG{'ABRT'} = DEFAULT;
+ $SIG{'ABRT'} = 'DEFAULT';
kill 'ABRT', $$ if $panic++;
print $DB::OUT "Got $_[0]!\n"; # in the case cannot continue
local $SIG{__WARN__} = '';
@@ -1386,7 +1691,11 @@ sub dbwarn {
local $frame = 0;
local $doret = -2;
local $SIG{__WARN__} = '';
- require Carp;
+ local $SIG{__DIE__} = '';
+ eval { require Carp }; # If error/warning during compilation,
+ # require may be broken.
+ warn(@_, "\nPossible unrecoverable error"), warn("\nTry to decrease warnLevel `O'ption!\n"), return
+ unless defined &Carp::longmess;
#&warn("Entering dbwarn\n");
my ($mysingle,$mytrace) = ($single,$trace);
$single = 0; $trace = 0;
@@ -1415,7 +1724,9 @@ sub dbdie {
#&warn("dieing quietly in dbdie\n") if $ineval and $dieLevel < 2;
die @_ if $ineval and $dieLevel < 2;
}
- require Carp;
+ eval { require Carp }; # If error/warning during compilation,
+ # require may be broken.
+ die(@_, "\nUnrecoverable error") 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);
@@ -1431,7 +1742,7 @@ sub warnLevel {
$prevwarn = $SIG{__WARN__} unless $warnLevel;
$warnLevel = shift;
if ($warnLevel) {
- $SIG{__WARN__} = 'DB::dbwarn';
+ $SIG{__WARN__} = \&DB::dbwarn;
} else {
$SIG{__WARN__} = $prevwarn;
}
@@ -1444,8 +1755,8 @@ 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";
print $OUT "Dump printed too.\n" if $dieLevel > 2;
@@ -1463,8 +1774,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;
@@ -1485,7 +1796,7 @@ BEGIN { # This does not compile, alas.
$window = 10;
$preview = 3;
$sub = '';
- $SIG{INT} = "DB::catch";
+ $SIG{INT} = \&DB::catch;
# This may be enabled to debug debugger:
#$warnLevel = 1 unless defined $warnLevel;
#$dieLevel = 1 unless defined $dieLevel;
@@ -1494,10 +1805,91 @@ BEGIN { # This does not compile, alas.
$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 {
+ my($text, $line, $start) = @_;
+ my ($itext, $prefix, $pack) = $text;
+
+ if ((substr $text, 0, 1) eq '&') { # subroutines
+ $text = substr $text, 1;
+ $prefix = "&";
+ return map "$prefix$_", grep /^\Q$text/, 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 @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 @out;
+ }
+ return grep /^\Q$text/, (keys %sub), qw(postpone load) # subroutines
+ if (substr $line, 0, $start) =~ /^[bl]\s+(postpone\s+)?$/;
+ return grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # packages
+ if (substr $line, 0, $start) =~ /^V\s+$/;
+ 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
+ $readline::rl_completer_terminator_character
+ = $readline::rl_completer_terminator_character
+ = (@out == 1 ? $out : '? ');
+ return @out;
+ }
+ return &readline::rl_filename_list($text); # filenames
+}
+
+sub end_report { print $OUT "Use `q' to quit and `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 {
+ "Debuggee terminated. Use `q' to quit and `R' to restart.";
+}
+
+package DB; # Do not trace this 1; below!
+
1;
diff --git a/lib/sigtrap.pm b/lib/sigtrap.pm
index f90f46b4ba..c081123b6b 100644
--- a/lib/sigtrap.pm
+++ b/lib/sigtrap.pm
@@ -8,7 +8,7 @@ sigtrap - Perl pragma to enable simple signal handling
use Carp;
-$VERSION = 1.01;
+$VERSION = 1.02;
$Verbose ||= 0;
sub import {
@@ -29,13 +29,16 @@ sub import {
}
}
elsif ($_ eq 'normal-signals') {
- unshift @_, qw(HUP INT PIPE TERM);
+ unshift @_, grep(exists $SIG{$_}, qw(HUP INT PIPE TERM));
}
elsif ($_ eq 'error-signals') {
- unshift @_, qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP);
+ unshift @_, grep(exists $SIG{$_},
+ qw(ABRT BUS EMT FPE ILL QUIT SEGV SYS TRAP));
}
elsif ($_ eq 'old-interface-signals') {
- unshift @_, qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP);
+ unshift @_,
+ grep(exists $SIG{$_},
+ qw(ABRT BUS EMT FPE ILL PIPE QUIT SEGV SYS TERM TRAP));
}
elsif ($_ eq 'stack-trace') {
$handler = \&handler_traceback;
@@ -160,13 +163,13 @@ installed handlers.
These options affect which handler will be used for subsequently
installed signals.
-=over
+=over 4
=item B<stack-trace>
-The handler used for subsequently installed signals will output a Perl
-stack trace to STDERR and then tries to dump core. This is the default
-signal handler.
+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>
@@ -183,9 +186,9 @@ assignment to an element of C<%SIG>.
=head2 SIGNAL LISTS
-B<sigtrap> has two built-in lists of signals to trap. They are:
+B<sigtrap> has a few built-in lists of signals to trap. They are:
-=over
+=over 4
=item B<normal-signals>
@@ -204,15 +207,22 @@ QUIT, SEGV, SYS and TRAP.
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.
+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> only to install handlers for subsequently
+This token tells B<sigtrap> to install handlers only for subsequently
listed signals which aren't already trapped or ignored.
=item B<any>
@@ -222,9 +232,9 @@ listed signals. This is the default behavior.
=item I<signal>
-Any argument which looks like a signals name (that is,
-C</^[A-Z][A-Z0-9]*$/>) is taken as a signal name and indicates that
-B<sigtrap> should install a handler for it.
+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>
diff --git a/lib/splain b/lib/splain
deleted file mode 100644
index f20b956b7d..0000000000
--- a/lib/splain
+++ /dev/null
@@ -1,507 +0,0 @@
-#!/usr/local/bin/perl
-eval 'exec perl -S $0 ${1+"$@"}'
- if 0;
-
-use Config;
-if ($^O eq 'VMS') {
- $diagnostics::PODFILE = VMS::Filespec::unixify($Config{'privlibexp'}) .
- '/pod/perldiag.pod';
-}
-else { $diagnostics::PODFILE= $Config{privlibexp} . "/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/lib/strict.pm b/lib/strict.pm
index a1c51531e9..e261e92f67 100644
--- a/lib/strict.pm
+++ b/lib/strict.pm
@@ -11,7 +11,6 @@ strict - Perl pragma to restrict unsafe constructs
use strict "vars";
use strict "refs";
use strict "subs";
- use strict "untie";
use strict;
no strict "vars";
@@ -20,8 +19,8 @@ strict - Perl pragma to restrict unsafe constructs
If no import list is supplied, all possible restrictions are assumed.
(This is the safest mode to operate in, but is sometimes too strict for
-casual programming.) Currently, there are four possible things to be
-strict about: "subs", "vars", "refs", and "untie".
+casual programming.) Currently, there are three possible things to be
+strict about: "subs", "vars", and "refs".
=over 6
@@ -56,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';
@@ -66,24 +65,6 @@ appears in curly braces or on the left hand side of the "=>" symbol.
-=item C<strict untie>
-
-This generates a runtime error if any references to the object returned
-by C<tie> (or C<tied>) still exist when C<untie> is called. Note that
-to get this strict behaviour, the C<use strict 'untie'> statement must
-be in the same scope as the C<untie>. See L<perlfunc/tie>,
-L<perlfunc/untie>, L<perlfunc/tied> and L<perltie>.
-
- use strict 'untie';
- $a = tie %a, 'SOME_PKG';
- $b = tie %b, 'SOME_PKG';
- $b = 0;
- tie %c, PKG;
- $c = tied %c;
- untie %a ; # blows up, $a is a valid object reference.
- untie %b; # ok, $b is not a reference to the object.
- untie %c ; # blows up, $c is a valid object reference.
-
=back
See L<perlmod/Pragmatic Modules>.
@@ -97,19 +78,18 @@ sub bits {
$bits |= 0x00000002 if $sememe eq 'refs';
$bits |= 0x00000200 if $sememe eq 'subs';
$bits |= 0x00000400 if $sememe eq 'vars';
- $bits |= 0x00000800 if $sememe eq 'untie';
}
$bits;
}
sub import {
shift;
- $^H |= bits(@_ ? @_ : qw(refs subs vars untie));
+ $^H |= bits(@_ ? @_ : qw(refs subs vars));
}
sub unimport {
shift;
- $^H &= ~ bits(@_ ? @_ : qw(refs subs vars untie));
+ $^H &= ~ bits(@_ ? @_ : qw(refs subs vars));
}
1;
diff --git a/lib/subs.pm b/lib/subs.pm
index 84c913a346..aa4c7e751e 100644
--- a/lib/subs.pm
+++ b/lib/subs.pm
@@ -15,7 +15,12 @@ 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;
diff --git a/lib/syslog.pl b/lib/syslog.pl
index 29c3a1cc9a..9e03399e4d 100644
--- a/lib/syslog.pl
+++ b/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/lib/termcap.pl b/lib/termcap.pl
index e8f108df06..c36575aa45 100644
--- a/lib/termcap.pl
+++ b/lib/termcap.pl
@@ -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/lib/timelocal.pl b/lib/timelocal.pl
index 75f1ac1851..ad322756e3 100644
--- a/lib/timelocal.pl
+++ b/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/lib/vars.pm b/lib/vars.pm
index 0dd5758297..f0a6e54988 100644
--- a/lib/vars.pm
+++ b/lib/vars.pm
@@ -14,6 +14,11 @@ 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
diff --git a/makeaperl.SH b/makeaperl.SH
index d621e67f03..16b74350e0 100755
--- a/makeaperl.SH
+++ b/makeaperl.SH
@@ -20,8 +20,8 @@ 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/makedepend.SH b/makedepend.SH
index 931dd82655..89f650d26d 100755
--- a/makedepend.SH
+++ b/makedepend.SH
@@ -18,16 +18,13 @@ case "$0" in
*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
esac
-: ${bin_sh=/bin/sh}
-
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!'
@@ -59,16 +56,22 @@ $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' \
@@ -124,21 +127,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..."; \
@@ -160,7 +169,7 @@ 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
diff --git a/malloc.c b/malloc.c
index 87b1ac7a35..f702c57dd8 100644
--- a/malloc.c
+++ b/malloc.c
@@ -22,6 +22,11 @@
#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
@@ -64,7 +69,7 @@ union overhead {
#define ov_rmagic ovu.ovu_rmagic
};
-#ifdef debug
+#ifdef DEBUGGING
static void botch _((char *s));
#endif
static void morecore _((int bucket));
@@ -107,8 +112,8 @@ static int findbucket _((union overhead *freep, int srchlen));
# 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) ((int)x & ~TWOK_MASK)
-# define TWOK_SHIFT(x) ((int)x & TWOK_MASK)
+# 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) + \
@@ -125,11 +130,6 @@ static u_short blk_shift[11 - 3] = {256, 128, 64, 32,
# define MAX_NONSHIFT 2 /* Shift 64 greater than chunk 32. */
};
-# ifdef DEBUGGING_MSTATS
-static u_int sbrk_slack;
-static u_int start_slack;
-# endif
-
#else /* !PACK_MALLOC */
# define OV_MAGIC(block,bucket) (block)->ov_magic
@@ -140,6 +140,84 @@ static u_int start_slack;
# 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
* precedes the data area returned to the user.
@@ -160,17 +238,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
@@ -185,22 +264,22 @@ malloc(nbytes)
register int bucket = 0;
register MEM_SIZE shiftr;
-#ifdef safemalloc
+#ifdef PERL_CORE
#ifdef DEBUGGING
MEM_SIZE size = nbytes;
#endif
-#ifdef MSDOS
+#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");
#endif
-#endif /* safemalloc */
+#endif /* PERL_CORE */
/*
* Convert amount of memory requested into
@@ -211,6 +290,11 @@ malloc(nbytes)
#ifdef PACK_MALLOC
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;
#ifdef PACK_MALLOC
@@ -229,9 +313,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
@@ -239,15 +323,15 @@ malloc(nbytes)
#endif
}
-#ifdef safemalloc
- DEBUG_m(fprintf(Perl_debug_log,"0x%lx: (%05d) malloc %ld bytes\n",
+#ifdef PERL_CORE
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) malloc %ld bytes\n",
(unsigned long)(p+1),an++,(long)size));
-#endif /* safemalloc */
+#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;
@@ -255,9 +339,6 @@ malloc(nbytes)
#ifndef PACK_MALLOC
OV_INDEX(p) = bucket;
#endif
-#ifdef DEBUGGING_MSTATS
- nmalloc[bucket]++;
-#endif
#ifdef RCHECK
/*
* Record allocated size of block and
@@ -281,11 +362,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
@@ -295,13 +379,13 @@ morecore(bucket)
op = (union overhead *)sbrk(0);
# ifndef I286
# ifdef PACK_MALLOC
- if ((int)op & 0x7ff)
- (void)sbrk(slack = 2048 - ((int)op & 0x7ff));
+ if ((u_int)op & 0x7ff)
+ (void)sbrk(slack = 2048 - ((u_int)op & 0x7ff));
# else
- if ((int)op & 0x3ff)
- (void)sbrk(slack = 1024 - ((int)op & 0x3ff));
+ if ((u_int)op & 0x3ff)
+ (void)sbrk(slack = 1024 - ((u_int)op & 0x3ff));
# endif
-# if defined(DEBUGGING_MSTATS) && defined(PACK_MALLOC)
+# if defined(DEBUGGING_MSTATS)
sbrk_slack += slack;
# endif
# else
@@ -318,22 +402,30 @@ morecore(bucket)
rnu = (bucket <= 11) ? 14 : bucket + 3;
#endif
nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */
- /* if (rnu < bucket)
- rnu = bucket; Why anyone needs this? */
- 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
# ifdef PACK_MALLOC
- if ((int)op & 0x7ff)
+ if ((u_int)op & 0x7ff)
croak("panic: Off-page sbrk");
# endif
- if ((int)op & 7) {
+ if ((u_int)op & 7) {
op = (union overhead *)(((MEM_SIZE)op + 8) &~ 7);
nblks--;
}
@@ -360,14 +452,15 @@ morecore(bucket)
} 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);
}
-#if defined(USE_PERL_SBRK) || defined(OS2)
- /* all real sbrks return zeroe-d memory, perl's sbrk doesn't guarantee this */
+ /* Not all sbrks return zeroed memory.*/
op->ov_next = (union overhead *)NULL;
-#endif
#ifdef PACK_MALLOC
if (bucket == 7 - 3) { /* Special case, explanation is above. */
union overhead *n_op = nextf[7 - 3]->ov_next;
@@ -389,9 +482,9 @@ free(mp)
u_char bucket;
#endif
-#ifdef safemalloc
- DEBUG_m(fprintf(Perl_debug_log,"0x%lx: (%05d) free\n",(unsigned long)cp,an++));
-#endif /* safemalloc */
+#ifdef PERL_CORE
+ DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%lx: (%05d) free\n",(unsigned long)cp,an++));
+#endif /* PERL_CORE */
if (cp == NULL)
return;
@@ -400,7 +493,7 @@ free(mp)
#ifdef PACK_MALLOC
bucket = OV_INDEX(op);
#endif
-#ifdef debug
+#ifdef DEBUGGING
ASSERT(OV_MAGIC(op, bucket) == MAGIC); /* make sure it was in use */
#else
if (OV_MAGIC(op, bucket) != MAGIC) {
@@ -430,9 +523,6 @@ free(mp)
size = OV_INDEX(op);
op->ov_next = nextf[size];
nextf[size] = op;
-#ifdef DEBUGGING_MSTATS
- nmalloc[size]--;
-#endif
}
/*
@@ -460,30 +550,30 @@ realloc(mp, nbytes)
int was_alloced = 0;
char *cp = (char*)mp;
-#ifdef safemalloc
+#ifdef PERL_CORE
#ifdef DEBUGGING
MEM_SIZE size = nbytes;
#endif
-#ifdef MSDOS
+#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) * CHUNK_SHIFT);
i = OV_INDEX(op);
if (OV_MAGIC(op, i) == MAGIC) {
- was_alloced++;
+ was_alloced = 1;
} else {
/*
* Already free, doing "compaction".
@@ -506,10 +596,24 @@ realloc(mp, nbytes)
#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 */
+ /*
+ * 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) - M_OVERHEAD) {
+ 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
@@ -539,15 +643,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",
+ PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) rfree\n",(unsigned long)res,an++);
+ PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) realloc %ld bytes\n",
(unsigned long)res,an++,(long)size);
}
#endif
-#endif /* safemalloc */
+#endif /* PERL_CORE */
return ((Malloc_t)res);
}
@@ -603,7 +707,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++) {
@@ -611,28 +715,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");
-#ifdef PACK_MALLOC
- if (sbrk_slack || start_slack) {
- fprintf(stderr, "Odd ends: %7d bytes from sbrk(), %7d from malloc.\n",
- sbrk_slack, start_slack);
- }
-#endif
+ PerlIO_printf(PerlIO_stderr(), "\nTotal sbrk(): %8d. Odd ends: sbrk(): %7d, malloc(): %7d bytes.\n",
+ goodsbrk + sbrk_slack, sbrk_slack, start_slack);
}
#else
void
@@ -646,32 +745,31 @@ dump_mstats(s)
#ifdef USE_PERL_SBRK
-#ifdef NeXT
-#ifdef HIDEMYMALLOC
-#undef malloc
-#else
-#include "Error: -DUSE_PERL_SBRK on the NeXT requires -DHIDEMYMALLOC"
-#endif
+# 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)
-
-#else
-
-/* OS/2 comes to mind ... */
-
-#endif
+# 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)
+# define PERLSBRK_32_K (1<<15)
+# define PERLSBRK_64_K (1<<16)
char *
Perl_sbrk(size)
@@ -681,7 +779,7 @@ int size;
int small, reqsize;
if (!size) return 0;
-#ifdef safemalloc
+#ifdef PERL_CORE
reqsize = size; /* just for the DEBUG_m statement */
#endif
if (size <= Perl_sbrk_oldsize) {
@@ -692,7 +790,7 @@ int size;
if (size >= PERLSBRK_32_K) {
small = 0;
} else {
-#ifndef safemalloc
+#ifndef PERL_CORE
reqsize = size;
#endif
size = PERLSBRK_64_K;
@@ -706,8 +804,8 @@ int size;
}
}
-#ifdef safemalloc
- DEBUG_m(fprintf(stderr,"sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n",
+#ifdef PERL_CORE
+ DEBUG_m(PerlIO_printf(PerlIO_stderr(), "sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n",
size, reqsize, Perl_sbrk_oldsize, got));
#endif
diff --git a/mg.c b/mg.c
index 4b46ec4573..d4c781ea71 100644
--- a/mg.c
+++ b/mg.c
@@ -15,11 +15,22 @@
#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
-*/
+
+#ifdef HAS_GETGROUPS
+# ifndef NGROUPS
+# define NGROUPS 32
+# endif
+#endif
+
+#define TAINT_FROM_REGEX(sv,rx) \
+ if ((rx)->exec_tainted) \
+ SvTAINTED_on(sv); \
+ else \
+ SvTAINTED_off(sv);
/*
* Use the "DESTRUCTOR" scope cleanup to reinstate magic.
@@ -33,15 +44,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 +58,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 +76,6 @@ void* p;
if (SvGMAGICAL(sv))
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
}
-
- safefree((void *)mgs);
}
@@ -96,12 +101,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 +115,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 +136,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 +169,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 +188,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;
@@ -259,28 +273,31 @@ 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)
+ if (i >= 0) {
+ TAINT_IF(rx->exec_tainted);
return i;
+ }
}
}
return 0;
break;
case '+':
- if (curpm) {
- paren = curpm->op_pmregexp->lastparen;
+ if (curpm && (rx = curpm->op_pmregexp)) {
+ paren = rx->lastparen;
if (!paren)
return 0;
goto getparen;
@@ -288,20 +305,21 @@ MAGIC *mg;
return 0;
break;
case '`':
- if (curpm) {
- if (curpm->op_pmregexp &&
- (s = curpm->op_pmregexp->subbeg) ) {
- i = curpm->op_pmregexp->startp[0] - s;
- if (i >= 0)
+ if (curpm && (rx = curpm->op_pmregexp)) {
+ if ((s = rx->subbeg)) {
+ i = rx->startp[0] - s;
+ if (i >= 0) {
+ TAINT_IF(rx->exec_tainted);
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 ((s = rx->endp[0])) {
+ TAINT_IF(rx->exec_tainted);
+ return (STRLEN) (rx->subend - s);
}
}
return 0;
@@ -326,6 +344,7 @@ MAGIC *mg;
register I32 paren;
register char *s;
register I32 i;
+ register REGEXP *rx;
char *t;
switch (*mg->mg_ptr) {
@@ -333,7 +352,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
@@ -342,7 +361,7 @@ 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
@@ -350,58 +369,56 @@ MAGIC *mg;
}
#else
#ifdef OS2
- sv_setnv(sv,(double)Perl_rc);
+ sv_setnv(sv, (double)Perl_rc);
sv_setpv(sv, os2error(Perl_rc));
#else
- sv_setnv(sv,(double)errno);
+ 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 '\024': /* ^T */
#ifdef BIG_TIME
- sv_setnv(sv,basetime);
+ sv_setnv(sv, basetime);
#else
- sv_setiv(sv,(I32)basetime);
+ 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) {
+ 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;
if (i >= 0) {
- MAGIC *tmg;
sv_setpvn(sv,s,i);
- if (tainting && (tmg = mg_find(sv,'t')))
- tmg->mg_len = 0; /* guarantee $1 untainted */
+ TAINT_FROM_REGEX(sv,rx);
break;
}
}
@@ -409,20 +426,20 @@ 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 (curpm && (rx = curpm->op_pmregexp)) {
+ if ((s = rx->subbeg)) {
+ i = rx->startp[0] - s;
if (i >= 0) {
sv_setpvn(sv,s,i);
+ TAINT_FROM_REGEX(sv,rx);
break;
}
}
@@ -430,10 +447,10 @@ MAGIC *mg;
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);
+ if (curpm && (rx = curpm->op_pmregexp)) {
+ if ((s = rx->endp[0])) {
+ sv_setpvn(sv,s, rx->subend - s);
+ TAINT_FROM_REGEX(sv,rx);
break;
}
}
@@ -442,12 +459,12 @@ 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)statusvalue);
break;
case '^':
s = IoTOP_NAME(GvIOp(defoutgv));
@@ -466,13 +483,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 ':':
@@ -480,10 +497,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);
@@ -496,12 +513,12 @@ 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
{
int saveerrno = errno;
- sv_setnv(sv,(double)errno);
+ sv_setnv(sv, (double)errno);
#ifdef OS2
if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc));
else
@@ -513,35 +530,35 @@ MAGIC *mg;
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 '(':
+ sv_setiv(sv, (IV)gid);
s = buf;
(void)sprintf(s,"%d",(int)gid);
goto add_groups;
case ')':
+ sv_setiv(sv, (IV)egid);
s = buf;
(void)sprintf(s,"%d",(int)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]);
+ (void)sprintf(s," %d", (int)gary[i]);
while (*s) s++;
}
}
#endif
sv_setpv(sv,buf);
+ SvIOK_on(sv); /* what a wonderful hack! */
break;
case '*':
break;
@@ -573,15 +590,19 @@ MAGIC* mg;
STRLEN len;
I32 i;
s = SvPV(sv,len);
- ptr = (mg->mg_len == HEf_SVKEY) ? SvPV((SV*)mg->mg_ptr, na) : mg->mg_ptr;
+ ptr = MgPV(mg);
my_setenv(ptr, s);
#ifdef DYNAMIC_ENV_FETCH
/* We just undefd an environment var. Is a replacement */
/* waiting in the wings? */
if (!len) {
HE *envhe;
- if (envhe = hv_fetch_ent(GvHVn(envgv),HeSVKEY((HE*)(mg->mg_ptr)),FALSE,0))
+ SV *keysv;
+ if (mg->mg_len == HEf_SVKEY) keysv = (SV *)mg->mg_ptr;
+ else keysv = newSVpv(mg->mg_ptr,mg->mg_len);
+ if (envhe = hv_fetch_ent(GvHVn(envgv),keysv,FALSE,0))
s = SvPV(HeVAL(envhe),len);
+ if (mg->mg_len != HEf_SVKEY) SvREFCNT_dec(keysv);
}
#endif
/* And you'll never guess what the dog had */
@@ -607,51 +628,10 @@ magic_clearenv(sv,mg)
SV* sv;
MAGIC* mg;
{
- my_setenv(((mg->mg_len == HEf_SVKEY) ?
- SvPV((SV*)mg->mg_ptr, na) : mg->mg_ptr),Nullch);
+ my_setenv(MgPV(mg),Nullch);
return 0;
}
-#ifdef HAS_SIGACTION
-/* set up reliable signal() clone */
-
-typedef void (*Sigfunc) _((int));
-
-static
-Sigfunc rsignal(signo,handler)
-int signo;
-Sigfunc 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) < 0)
- return(SIG_ERR);
- else
- return(oact.sa_handler);
-}
-
-#else
-
-/* ah well, so much for reliability */
-
-#define rsignal(x,y) signal(x,y)
-
-#endif
-
-static sig_trapped;
-static
-Signal_t
-sig_trap(signo)
-int signo;
-{
- sig_trapped++;
-}
int
magic_getsig(sv,mg)
SV* sv;
@@ -659,20 +639,15 @@ MAGIC* mg;
{
I32 i;
/* Are we fetching a signal entry? */
- i = whichsig(mg->mg_ptr);
+ i = whichsig(MgPV(mg));
if (i) {
if(psig_ptr[i])
sv_setsv(sv,psig_ptr[i]);
else {
- void (*origsig)(int);
- /* get signal state without losing signals */
- sig_trapped=0;
- origsig = rsignal(i,sig_trap);
- rsignal(i,origsig);
- if(sig_trapped)
- kill(getpid(),i);
+ Sighandler_t sigstate = rsignal_state(i);
+
/* cache state so we don't fetch it again */
- if(origsig == SIG_IGN)
+ if(sigstate == SIG_IGN)
sv_setpv(sv,"IGNORE");
else
sv_setsv(sv,&sv_undef);
@@ -689,7 +664,7 @@ MAGIC* mg;
{
I32 i;
/* Are we clearing a signal entry? */
- i = whichsig(mg->mg_ptr);
+ i = whichsig(MgPV(mg));
if (i) {
if(psig_ptr[i]) {
SvREFCNT_dec(psig_ptr[i]);
@@ -712,7 +687,7 @@ MAGIC* mg;
I32 i;
SV** svp;
- s = (mg->mg_len == HEf_SVKEY) ? SvPV((SV*)mg->mg_ptr, na) : mg->mg_ptr;
+ s = MgPV(mg);
if (*s == '_') {
if (strEQ(s,"__DIE__"))
svp = &diehook;
@@ -740,13 +715,13 @@ MAGIC* mg;
psig_ptr[i] = SvREFCNT_inc(sv);
if(psig_name[i])
SvREFCNT_dec(psig_name[i]);
- psig_name[i] = newSVpv(mg->mg_ptr,strlen(mg->mg_ptr));
+ psig_name[i] = newSVpv(s,strlen(s));
SvTEMP_off(sv); /* Make sure it doesn't go away on us */
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;
@@ -754,23 +729,25 @@ 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(hints & HINT_STRICT_REFS)
+ die(no_symref,s,"a subroutine");
if (!strchr(s,':') && !strchr(s,'\'')) {
sprintf(tokenbuf, "main::%s",s);
sv_setpv(sv,tokenbuf);
}
if (i)
- (void)rsignal(i,sighandler);
+ (void)rsignal(i, sighandler);
else
*svp = SvREFCNT_inc(sv);
}
@@ -800,6 +777,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;
@@ -937,7 +926,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)), FALSE);
if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp)))
o->op_private = i;
else
@@ -1024,7 +1014,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;
}
@@ -1072,10 +1068,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;
}
@@ -1107,6 +1101,37 @@ MAGIC* mg;
}
int
+magic_setvivary(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ if (LvTARGLEN(sv)) {
+ AV* av = (AV*)LvTARG(sv);
+ if (LvTARGOFF(sv) <= AvFILL(av)) {
+ SV** svp = AvARRAY(av) + LvTARGOFF(sv);
+ LvTARG(sv) = newSVsv(*svp);
+ SvREFCNT_dec(*svp);
+ *svp = SvREFCNT_inc(LvTARG(sv));
+ }
+ else
+ LvTARG(sv) = Nullsv;
+ LvTARGLEN(sv) = 0;
+ SvREFCNT_dec(av);
+ }
+ if (LvTARG(sv))
+ sv_setsv(LvTARG(sv), sv);
+ return 0;
+}
+
+int
+magic_freevivary(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ SvREFCNT_dec(LvTARG(sv));
+}
+
+int
magic_setmglob(sv,mg)
SV* sv;
MAGIC* mg;
@@ -1127,6 +1152,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;
@@ -1139,6 +1174,19 @@ MAGIC* mg;
}
int
+magic_setcollxfrm(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+ /*
+ * René Descartes said "I think not."
+ * and vanished with a faint plop.
+ */
+ sv_unmagic(sv, 'o');
+ return 0;
+}
+
+int
magic_set(sv,mg)
SV* sv;
MAGIC* mg;
@@ -1392,7 +1440,8 @@ MAGIC* mg;
if (origargv[i] == s + 1)
s += strlen(++s); /* this one is ok too */
}
- if (origenviron[0] == s + 1) { /* can grab env area too? */
+ /* can grab env area too? */
+ if (origenviron && origenviron[0] == s + 1) {
my_setenv("NoNeSuCh", Nullch);
/* force copy of environment */
for (i = 0; origenviron[i]; i++)
@@ -1454,6 +1503,10 @@ int sig;
SV *sv;
CV *cv;
AV *oldstack;
+
+ if(!psig_ptr[sig])
+ die("Signal SIG%s received, but no signal handler set.\n",
+ sig_name[sig]);
cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
if (!cv || !CvROOT(cv)) {
diff --git a/mg.h b/mg.h
index ab24eb03ab..8fbda82ea1 100644
--- a/mg.h
+++ b/mg.h
@@ -34,3 +34,7 @@ struct magic {
#define MgTAINTEDDIR(mg) (mg->mg_flags & MGf_TAINTEDDIR)
#define MgTAINTEDDIR_on(mg) (mg->mg_flags |= MGf_TAINTEDDIR)
+
+#define MgPV(mg) ((mg)->mg_len == HEf_SVKEY) ? \
+ SvPV((SV*)((mg)->mg_ptr),na) : \
+ (mg)->mg_ptr
diff --git a/minimod.pl b/minimod.pl
index b9b70715b2..b9b70715b2 100644..100755
--- a/minimod.pl
+++ b/minimod.pl
diff --git a/miniperlmain.c b/miniperlmain.c
index 2d66964093..680b04284a 100644
--- a/miniperlmain.c
+++ b/miniperlmain.c
@@ -40,6 +40,7 @@ char **env;
if (!my_perl)
exit(1);
perl_construct( my_perl );
+ perl_destruct_level = 0;
}
exitstatus = perl_parse( my_perl, xs_init, argc, argv, (char **) NULL );
diff --git a/myconfig b/myconfig
index 719ca701f5..444eca00fd 100755
--- a/myconfig
+++ b/myconfig
@@ -24,6 +24,7 @@ Summary of my $package ($baserev patchlevel $PATCHLEVEL subversion $SUBVERSION)
osname=$osname, osvers=$osvers, archname=$archname
uname='$myuname'
hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction
+ useperlio=$useperlio d_sfio=$d_sfio
Compiler:
cc='$cc', optimize='$optimize', gccversion=$gccversion
cppflags='$cppflags'
@@ -36,6 +37,7 @@ Summary of my $package ($baserev patchlevel $PATCHLEVEL subversion $SUBVERSION)
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/nostdio.h b/nostdio.h
new file mode 100644
index 0000000000..256a638c9a
--- /dev/null
+++ b/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/op.c b/op.c
index c4f0d41fb4..a7460b1ffc 100644
--- a/op.c
+++ b/op.c
@@ -41,7 +41,7 @@ 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*
@@ -49,7 +49,7 @@ CvNAME(cv)
CV* cv;
{
SV* tmpsv = sv_newmortal();
- gv_efullname(tmpsv, CvGV(cv));
+ gv_efullname3(tmpsv, CvGV(cv), Nullch);
return SvPV(tmpsv,na);
}
@@ -120,8 +120,8 @@ 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]))
+ sprintf(name+1, "^%c", toCTRL(name[1])); /* XXX tokenbuf, really */
croak("Can't use global %s in \"my\"",name);
}
if (AvFILL(comppad_name) >= 0) {
@@ -160,11 +160,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;
@@ -189,9 +189,18 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix)
seq > (I32)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)
+ return 0; /* don't clone 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);
newoff = pad_alloc(OP_PADSV, SVs_PADMY);
@@ -201,9 +210,17 @@ pad_findlex(char *name, PADOFFSET newoff, I32 seq, CV* startcv, I32 cx_ix)
SvNVX(sv) = (double)curcop->cop_seq;
SvIVX(sv) = 999999999; /* A ref, intro immediately */
SvFLAGS(sv) |= SVf_FAKE;
+ /* "It's closures all the way down." */
+ CvCLONE_on(compcv);
+ if (cv != startcv) {
+ CV *bcv;
+ for (bcv = startcv;
+ bcv && bcv != cv && !CvCLONE(bcv);
+ bcv = CvOUTSIDE(bcv))
+ CvCLONE_on(bcv);
+ }
}
av_store(comppad, newoff, SvREFCNT_inc(oldsv));
- CvCLONE_on(compcv);
return newoff;
}
}
@@ -253,7 +270,7 @@ char *name;
I32 off;
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--) {
@@ -314,14 +331,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(Perl_debug_log, "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;
}
@@ -335,7 +364,7 @@ pad_sv(PADOFFSET po)
{
if (!po)
croak("panic: pad_sv po");
- DEBUG_X(fprintf(Perl_debug_log, "Pad sv %d\n", po));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad sv %d\n", po));
return curpad[po]; /* eventually we'll turn this into a macro */
}
@@ -353,7 +382,7 @@ pad_free(PADOFFSET po)
croak("panic: pad_free curpad");
if (!po)
croak("panic: pad_free po");
- DEBUG_X(fprintf(Perl_debug_log, "Pad free %d\n", po));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad free %d\n", po));
if (curpad[po] && curpad[po] != &sv_undef)
SvPADTMP_off(curpad[po]);
if ((I32)po < padix)
@@ -372,7 +401,7 @@ pad_swipe(PADOFFSET po)
croak("panic: pad_swipe curpad");
if (!po)
croak("panic: pad_swipe po");
- DEBUG_X(fprintf(Perl_debug_log, "Pad swipe %d\n", po));
+ DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad swipe %d\n", po));
SvPADTMP_off(curpad[po]);
curpad[po] = NEWSV(1107,0);
SvPADTMP_on(curpad[po]);
@@ -387,7 +416,7 @@ pad_reset()
if (AvARRAY(comppad) != curpad)
croak("panic: pad_reset curpad");
- DEBUG_X(fprintf(Perl_debug_log, "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)
@@ -429,9 +458,9 @@ OP *op;
break;
case OP_NEXTSTATE:
case OP_DBSTATE:
+ Safefree(cCOP->cop_label);
SvREFCNT_dec(cCOP->cop_filegv);
break;
- /* case OP_ANONCODE: XXX breaks eval of anon subs in closures (cf. Opcode) */
case OP_CONST:
SvREFCNT_dec(cSVOP->op_sv);
break;
@@ -538,7 +567,8 @@ OP *op;
OP *kid;
/* assumes no premature commitment */
- if (!op || (op->op_flags & OPf_KNOW) || error_count)
+ if (!op || (op->op_flags & OPf_KNOW) || op->op_type == OP_RETURN
+ || error_count)
return op;
op->op_flags &= ~OPf_LIST;
@@ -609,6 +639,8 @@ OP *op;
default:
if (!(opargs[op->op_type] & OA_FOLDCONST))
break;
+ /* FALL THROUGH */
+ case OP_REPEAT:
if (op->op_flags & OPf_STACKED)
break;
/* FALL THROUGH */
@@ -727,11 +759,6 @@ 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:
@@ -792,7 +819,8 @@ OP *op;
OP *kid;
/* assumes no premature commitment */
- if (!op || (op->op_flags & OPf_KNOW) || error_count)
+ if (!op || (op->op_flags & OPf_KNOW) || op->op_type == OP_RETURN
+ || error_count)
return op;
op->op_flags |= (OPf_KNOW | OPf_LIST);
@@ -889,7 +917,6 @@ I32 type;
{
OP *kid;
SV *sv;
- char mtype;
if (!op || error_count)
return op;
@@ -911,6 +938,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)) {
@@ -997,6 +1028,8 @@ 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. */
/* FALL THROUGH */
case OP_PADSV:
modcount++;
@@ -1008,21 +1041,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;
@@ -1109,8 +1137,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;
@@ -1137,8 +1167,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;
@@ -1262,41 +1294,42 @@ OP *o;
}
int
-block_start()
+block_start(full)
+int full;
{
int retval = savestack_ix;
- SAVEINT(comppad_name_floor);
- if ((comppad_name_fill = AvFILL(comppad_name)) > 0)
- comppad_name_floor = comppad_name_fill;
- else
- comppad_name_floor = 0;
- 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;
}
@@ -1814,6 +1847,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);
@@ -2292,23 +2328,9 @@ 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) {
cop->op_type = OP_DBSTATE;
@@ -2326,7 +2348,7 @@ OP *op;
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)
@@ -2350,6 +2372,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;
@@ -2667,7 +2712,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;
}
@@ -2736,16 +2781,43 @@ CV *cv;
}
}
-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*)*av_fetch(padlist, 0, FALSE);
+ AV* pad = (AV*)*av_fetch(padlist, 1, FALSE);
+ SV** pname = AvARRAY(pad_name);
+ SV** ppad = AvARRAY(pad);
+ I32 ix;
+
+ PerlIO_printf(Perl_debug_log, "\tCV=0x%p (%s), OUTSIDE=0x%p (%s)\n",
+ cv, CvANON(cv) ? "ANON" : GvNAME(CvGV(cv)),
+ outside, CvANON(outside) ? "ANON" : GvNAME(CvGV(outside)));
+
+ for (ix = 1; ix <= AvFILL(pad); ix++) {
+ if (SvPOK(pname[ix]))
+ PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (\"%s\")\n",
+ ix, ppad[ix], SvPVX(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);
AV* comppadlist;
CV* cv;
@@ -2757,14 +2829,16 @@ CV* proto;
cv = compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)cv, SVt_PVCV);
CvCLONED_on(cv);
+ if (CvANON(proto))
+ CvANON_on(cv);
CvFILEGV(cv) = CvFILEGV(proto);
CvGV(cv) = GvREFCNT_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);
comppad = newAV();
@@ -2773,7 +2847,7 @@ CV* proto;
av_store(comppadlist, 0, SvREFCNT_inc((SV*)protopad_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 @_ */
@@ -2781,38 +2855,100 @@ 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 = AvFILL(protopad); ix > 0; ix--) {
+ SV* sv;
+ if (pname[ix] != &sv_undef) {
+ char *name = SvPVX(pname[ix]); /* XXX */
+ if (SvFLAGS(pname[ix]) & SVf_FAKE) { /* lexical from outside? */
+ I32 off = pad_findlex(name, ix, SvIVX(pname[ix]),
+ 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());
+ 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 = NEWSV(0,0);
SvPADTMP_on(sv);
+ curpad[ix] = sv;
}
}
+ /* Now that vars are all in place, clone nested closures. */
+
+ for (ix = AvFILL(protopad); ix > 0; ix--) {
+ if (pname[ix] != &sv_undef
+ && !(SvFLAGS(pname[ix]) & SVf_FAKE)
+ && *SvPVX(pname[ix]) == '&'
+ && 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 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));
+}
+
+SV *
+cv_const_sv(cv)
+CV *cv;
+{
+ OP *o;
+ SV *sv = Nullsv;
+
+ if(cv && SvPOK(cv) && !SvCUR(cv)) {
+ 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 (type != OP_CONST || sv)
+ return Nullsv;
+
+ sv = ((SVOP*)o)->op_sv;
+ }
+ }
+ return sv;
+}
+
+CV *
newSUB(floor,op,proto,block)
I32 floor;
OP *op;
@@ -2832,11 +2968,22 @@ OP *block;
if (GvCVGEN(gv))
cv = 0; /* just a cached method */
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
- if (dowarn && strNE(name, "BEGIN")) {/* already defined (or promised)? */
+ SV* const_sv = cv_const_sv(cv);
+
+ char *p = proto ? SvPVx(((SVOP*)proto)->op_sv, na) : Nullch;
+
+ if((!proto != !SvPOK(cv)) || (p && strNE(SvPV((SV*)cv,na), p))) {
+ warn("Prototype mismatch: (%s) vs (%s)",
+ SvPOK(cv) ? SvPV((SV*)cv,na) : "none",
+ p ? p : "none");
+ }
+
+ if ((const_sv || dowarn) && strNE(name, "BEGIN")) {/* already defined (or promised)? */
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);
@@ -2864,8 +3011,6 @@ OP *block;
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);
}
@@ -2936,14 +3081,29 @@ OP *block;
if (perldb && curstash != debstash) {
SV *sv;
SV *tmpstr = sv_newmortal();
+ static GV *db_postponed;
+ CV *cv;
+ HV *hv;
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);
+ gv_efullname3(tmpstr, gv, Nullch);
hv_store(GvHV(DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
+ if (!db_postponed) {
+ db_postponed = gv_fetchpv("DB::postponed", TRUE, 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);
+ }
}
op_free(op);
copline = NOLINE;
@@ -3221,6 +3381,27 @@ OP *o;
/* Check routines. */
OP *
+ck_anoncode(op)
+OP *op;
+{
+ PADOFFSET ix = pad_alloc(op->op_type, SVs_PADMY);
+ av_store(comppad_name, ix, newSVpv("&", 1));
+ 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;
{
@@ -3259,10 +3440,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;
@@ -3344,6 +3529,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;
{
@@ -3392,13 +3591,6 @@ register OP *op;
}
OP *
-ck_formline(op)
-OP *op;
-{
- return ck_fun(op);
-}
-
-OP *
ck_ftst(op)
OP *op;
{
@@ -3647,7 +3839,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);
}
@@ -3702,7 +3894,43 @@ 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 *
@@ -3807,6 +4035,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;
@@ -3843,6 +4077,7 @@ OP *op;
op->op_flags |= OPf_SPECIAL;
}
}
+
return op;
}
@@ -4109,7 +4344,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;
@@ -4123,8 +4358,7 @@ register OP* o;
if (pop->op_type == OP_CONST &&
(op = pop->op_next) &&
pop->op_next->op_type == OP_AELEM &&
- !(pop->op_next->op_private &
- (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO)) &&
+ !(pop->op_next->op_private & (OPpDEREF|OPpLVAL_INTRO)) &&
(i = SvIV(((SVOP*)pop)->op_sv) - compiling.cop_arybase)
<= 255 &&
i >= 0)
diff --git a/op.h b/op.h
index 7c210bcbf9..4b57b333fd 100644
--- a/op.h
+++ b/op.h
@@ -86,8 +86,10 @@ typedef U32 PADOFFSET;
/* (lower bits carry hints) */
#define OPpENTERSUB_AMPER 8 /* Used & form to call. */
#define OPpENTERSUB_DB 16 /* Debug subroutine. */
-#define OPpDEREF_AV 32 /* Want ref to AV. */
-#define OPpDEREF_HV 64 /* Want ref to HV. */
+#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. */
/* Private for OP_CONST */
#define OPpCONST_ENTERED 16 /* Has been entered as symbol. */
@@ -100,9 +102,15 @@ typedef U32 PADOFFSET;
/* Private for OP_LIST */
#define OPpLIST_GUESSED 64 /* Guessed that pushmark was needed. */
-/* Private for OP_LEAVE and friends */
+/* Private for OP_LEAVE, OP_DELETE, and friends(?) */
#define OPpLEAVE_VOID 64 /* No need to copy out values. */
+/* Private for OP_DELETE */
+#define OPpSLICE 32 /* 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
};
@@ -167,7 +175,7 @@ struct pmop {
#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/opcode.h b/opcode.h
index 01dd521ddb..518c1e492f 100644
--- a/opcode.h
+++ b/opcode.h
@@ -1052,14 +1052,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 +1075,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));
@@ -1776,9 +1780,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 +1801,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 +1849,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 +1865,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 +1896,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 +1914,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 */
@@ -2195,8 +2199,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 */
@@ -2247,11 +2251,11 @@ EXT U32 opargs[] = {
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 +2263,7 @@ EXT U32 opargs[] = {
0x00000408, /* each */
0x00000408, /* values */
0x00000408, /* keys */
- 0x00000104, /* delete */
+ 0x00000100, /* delete */
0x00000114, /* exists */
0x00000048, /* rv2hv */
0x00001404, /* helem */
@@ -2344,7 +2348,7 @@ EXT U32 opargs[] = {
0x00000e14, /* eof */
0x00000e0c, /* tell */
0x00011604, /* seek */
- 0x00001614, /* truncate */
+ 0x00001114, /* truncate */
0x0001160c, /* fcntl */
0x0001160c, /* ioctl */
0x0000161c, /* flock */
diff --git a/opcode.pl b/opcode.pl
index 2c2bc50a50..b23193349c 100755
--- a/opcode.pl
+++ b/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
@@ -278,8 +279,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 +297,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.
@@ -338,16 +339,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 mst 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.
@@ -361,8 +362,8 @@ aslice array slice ck_null m A L
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
+delete delete ck_delete 0 S
+exists exists operator ck_exists 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
@@ -477,7 +478,8 @@ 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 truncate ck_trunc is F S
+# truncate really behaves as if it had both "S S" and "F S"
+truncate truncate ck_trunc is S S
fcntl fcntl ck_fun st F S S
ioctl ioctl ck_fun st F S S
diff --git a/os2/Changes b/os2/Changes
new file mode 100644
index 0000000000..83af2d8893
--- /dev/null
+++ b/os2/Changes
@@ -0,0 +1,124 @@
+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).
diff --git a/os2/Makefile.SHs b/os2/Makefile.SHs
index 83227bb38b..6b07e72dba 100644
--- a/os2/Makefile.SHs
+++ b/os2/Makefile.SHs
@@ -1,4 +1,4 @@
-# This file is read by Makefile.SH to produce rules for $(perllib) (and
+# 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.
@@ -12,17 +12,28 @@ AOUT_CCCMD = \$(CC) $aout_ccflags $optimize
AOUT_AR = $aout_ar
AOUT_OBJ_EXT = $aout_obj_ext
AOUT_LIB_EXT = $aout_lib_ext
-aout_perllib = libperl$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
+
!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) $(libs) perl5.def
@@ -41,6 +52,8 @@ perl5.def: perl.linkexp
echo ' "dlopen"' >>$@
echo ' "dlsym"' >>$@
echo ' "dlerror"' >>$@
+ echo ' "my_tmpfile"' >>$@
+ echo ' "my_tmpnam"' >>$@
!NO!SUBS!
if [ ! -z "$myttyname" ] ; then
@@ -55,16 +68,12 @@ $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
@@ -90,6 +99,16 @@ os2ish.h: os2/os2ish.h
dlfcn.h: os2/dlfcn.h
cp $< $@
+# We link miniperl statically, since .DLL depends on $(DYNALOADER)
+
+miniperl: $& miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj)
+ $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) perl$(OBJ_EXT) $(obj) $(libs)
+ @./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest
+
+# 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)
@@ -102,22 +121,48 @@ 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_perllib) : $(aout_obj) perl$(AOUT_OBJ_EXT)
- rm -f $(perllib)
- $(AOUT_AR) rcu $(aout_perllib) perl$(AOUT_OBJ_EXT) $(aout_obj)
+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_perllib) ext.libs
- $(CC) $(LARGE) $(AOUT_CLDFLAGS) $(CCDLFLAGS) -o miniperl_ miniperlmain$(AOUT_OBJ_EXT) $(aout_perllib) `cat ext.libs` $(libs)
+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_: $& aout_perlmain$(AOUT_OBJ_EXT) $(aout_perllib) $(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_perllib) `cat ext.libs` $(libs)
+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
@@ -128,13 +173,22 @@ 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
+ - 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_ Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl
+ cd $(dir $@) ; ../../miniperl_ -I ../../lib Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl
!NO!SUBS!
diff --git a/os2/OS2/ExtAttr/Changes b/os2/OS2/ExtAttr/Changes
new file mode 100644
index 0000000000..55fdc5f6d5
--- /dev/null
+++ b/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/os2/OS2/ExtAttr/ExtAttr.pm b/os2/OS2/ExtAttr/ExtAttr.pm
new file mode 100644
index 0000000000..bebbcc963e
--- /dev/null
+++ b/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/os2/OS2/ExtAttr/ExtAttr.xs b/os2/OS2/ExtAttr/ExtAttr.xs
new file mode 100644
index 0000000000..566b6595c8
--- /dev/null
+++ b/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/os2/OS2/ExtAttr/MANIFEST b/os2/OS2/ExtAttr/MANIFEST
new file mode 100644
index 0000000000..b1a8e80e77
--- /dev/null
+++ b/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/os2/OS2/ExtAttr/Makefile.PL b/os2/OS2/ExtAttr/Makefile.PL
new file mode 100644
index 0000000000..35680288b8
--- /dev/null
+++ b/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/os2/OS2/ExtAttr/myea.h b/os2/OS2/ExtAttr/myea.h
new file mode 100644
index 0000000000..ec4dc81f99
--- /dev/null
+++ b/os2/OS2/ExtAttr/myea.h
@@ -0,0 +1,2 @@
+#include <sys/ea.h>
+#include <sys/ead.h>
diff --git a/os2/OS2/ExtAttr/t/os2_ea.t b/os2/OS2/ExtAttr/t/os2_ea.t
new file mode 100644
index 0000000000..dc6f996564
--- /dev/null
+++ b/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";
+
diff --git a/os2/OS2/ExtAttr/typemap b/os2/OS2/ExtAttr/typemap
new file mode 100644
index 0000000000..a5ff8d63ac
--- /dev/null
+++ b/os2/OS2/ExtAttr/typemap
@@ -0,0 +1,2 @@
+struct _ea * T_PTR
+_ead T_PTR
diff --git a/os2/OS2/PrfDB/Changes b/os2/OS2/PrfDB/Changes
new file mode 100644
index 0000000000..3e8bf3f580
--- /dev/null
+++ b/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/os2/OS2/PrfDB/MANIFEST b/os2/OS2/PrfDB/MANIFEST
new file mode 100644
index 0000000000..fb96b03c5d
--- /dev/null
+++ b/os2/OS2/PrfDB/MANIFEST
@@ -0,0 +1,7 @@
+Changes
+MANIFEST
+Makefile.PL
+PrfDB.pm
+PrfDB.xs
+t/os2_prfdb.t
+typemap
diff --git a/os2/OS2/PrfDB/Makefile.PL b/os2/OS2/PrfDB/Makefile.PL
new file mode 100644
index 0000000000..39521685df
--- /dev/null
+++ b/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/os2/OS2/PrfDB/PrfDB.pm b/os2/OS2/PrfDB/PrfDB.pm
new file mode 100644
index 0000000000..41d7dba2f1
--- /dev/null
+++ b/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/os2/OS2/PrfDB/PrfDB.xs b/os2/OS2/PrfDB/PrfDB.xs
new file mode 100644
index 0000000000..a5b2c89ca6
--- /dev/null
+++ b/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/os2/OS2/PrfDB/t/os2_prfdb.t b/os2/OS2/PrfDB/t/os2_prfdb.t
new file mode 100644
index 0000000000..4c0883db50
--- /dev/null
+++ b/os2/OS2/PrfDB/t/os2_prfdb.t
@@ -0,0 +1,185 @@
+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");
+
+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");
diff --git a/os2/OS2/PrfDB/typemap b/os2/OS2/PrfDB/typemap
new file mode 100644
index 0000000000..0b91f3750a
--- /dev/null
+++ b/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/os2/OS2/Process/MANIFEST b/os2/OS2/Process/MANIFEST
new file mode 100644
index 0000000000..0d90d15fca
--- /dev/null
+++ b/os2/OS2/Process/MANIFEST
@@ -0,0 +1,4 @@
+MANIFEST
+Makefile.PL
+Process.pm
+Process.xs
diff --git a/os2/OS2/Process/Makefile.PL b/os2/OS2/Process/Makefile.PL
new file mode 100644
index 0000000000..b7a295f857
--- /dev/null
+++ b/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/os2/OS2/Process/Process.pm b/os2/OS2/Process/Process.pm
new file mode 100644
index 0000000000..9216bb1e05
--- /dev/null
+++ b/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/os2/OS2/Process/Process.xs b/os2/OS2/Process/Process.xs
new file mode 100644
index 0000000000..bdb2ece7a0
--- /dev/null
+++ b/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/os2/OS2/REXX/Changes b/os2/OS2/REXX/Changes
new file mode 100644
index 0000000000..46b38ef46c
--- /dev/null
+++ b/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/os2/OS2/REXX/MANIFEST b/os2/OS2/REXX/MANIFEST
new file mode 100644
index 0000000000..4ac81492e4
--- /dev/null
+++ b/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/os2/OS2/REXX/Makefile.PL b/os2/OS2/REXX/Makefile.PL
new file mode 100644
index 0000000000..c27cb0d905
--- /dev/null
+++ b/os2/OS2/REXX/Makefile.PL
@@ -0,0 +1,8 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'OS2::REXX',
+ VERSION => '0.2',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes',
+);
diff --git a/os2/OS2/REXX/REXX.pm b/os2/OS2/REXX/REXX.pm
new file mode 100644
index 0000000000..78e0cf917d
--- /dev/null
+++ b/os2/OS2/REXX/REXX.pm
@@ -0,0 +1,387 @@
+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;
+ }
+ 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$&\E/;
+ return bless \$name, OS2::REXX::_SCALAR;
+}
+
+sub TIEARRAY
+{
+ my ($obj, $name) = @_;
+ $name =~ s/^[\w!?]+/\U$&\E/;
+ return bless [$name, 0], OS2::REXX::_ARRAY;
+}
+
+sub TIEHASH
+{
+ my ($obj, $name) = @_;
+ $name =~ s/^[\w!?]+/\U$&\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 or, as last resort, PATH.
+
+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/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs
new file mode 100644
index 0000000000..df7646c42e
--- /dev/null
+++ b/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/os2/OS2/REXX/t/rx_cmprt.t b/os2/OS2/REXX/t/rx_cmprt.t
new file mode 100644
index 0000000000..a73e43e36e
--- /dev/null
+++ b/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/os2/OS2/REXX/t/rx_dllld.t b/os2/OS2/REXX/t/rx_dllld.t
new file mode 100644
index 0000000000..317743f3cb
--- /dev/null
+++ b/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/os2/OS2/REXX/t/rx_objcall.t b/os2/OS2/REXX/t/rx_objcall.t
new file mode 100644
index 0000000000..b4f04c308a
--- /dev/null
+++ b/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/os2/OS2/REXX/t/rx_sql.test b/os2/OS2/REXX/t/rx_sql.test
new file mode 100644
index 0000000000..4f984250a3
--- /dev/null
+++ b/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/os2/OS2/REXX/t/rx_tiesql.test b/os2/OS2/REXX/t/rx_tiesql.test
new file mode 100644
index 0000000000..2947516755
--- /dev/null
+++ b/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/os2/OS2/REXX/t/rx_tievar.t b/os2/OS2/REXX/t/rx_tievar.t
new file mode 100644
index 0000000000..6132e23f80
--- /dev/null
+++ b/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/os2/OS2/REXX/t/rx_tieydb.t b/os2/OS2/REXX/t/rx_tieydb.t
new file mode 100644
index 0000000000..8251051265
--- /dev/null
+++ b/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/os2/OS2/REXX/t/rx_varset.t b/os2/OS2/REXX/t/rx_varset.t
new file mode 100644
index 0000000000..9d4f3b2e56
--- /dev/null
+++ b/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/os2/OS2/REXX/t/rx_vrexx.t b/os2/OS2/REXX/t/rx_vrexx.t
new file mode 100644
index 0000000000..a40749f55f
--- /dev/null
+++ b/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/os2/diff.configure b/os2/diff.configure
index 53aa16b4a2..d19bf4a823 100644
--- a/os2/diff.configure
+++ b/os2/diff.configure
@@ -1,589 +1,240 @@
-*** 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
+--- perl5.003_06/Configure Fri Oct 4 11:08:50 1996
++++ Configure Wed Oct 9 17:53:14 1996
+@@ -1451,7 +1451,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
+@@ -1460,7 +1460,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
+ /*)
+@@ -3091,7 +3093,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." ;;
+@@ -3275,6 +3277,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
+@@ -3387,7 +3395,7 @@
+ esac
+ ;;
+ esac
+-libnames='';
++#libnames='';
+ case "$libs" in
+ '') ;;
+ *) for thislib in $libs; do
+@@ -3583,6 +3593,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
+@@ -3593,23 +3607,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
+@@ -5606,7 +5630,7 @@
+ exit(0);
+ }
+ EOCP
+- 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
+ intsize=`./try`
+ echo "Your integers are $intsize bytes long."
+ else
+@@ -5686,7 +5710,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
+@@ -5767,7 +5791,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
+@@ -5806,7 +5830,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
+@@ -6148,7 +6172,7 @@
+ 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 $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
+@@ -6159,7 +6183,7 @@
+ val="$undef"
+ fi
+ elif $test `./findhdr fcntl.h` && \
+- $cc "-DI_FCNTL" open3.c -o open3 >/dev/null 2>&1 ; then
++ $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
+@@ -6642,7 +6666,7 @@
+ y*|true)
+ usemymalloc='y'
+ mallocsrc='malloc.c'
+- mallocobj='malloc.o'
++ mallocobj="malloc$obj_ext"
+ d_mymalloc="$define"
+ case "$libs" in
+ *-lmalloc*)
+@@ -7867,7 +7891,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'
+@@ -7915,7 +7939,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)
+@@ -8337,7 +8361,7 @@
+ printf("%d\n",i);
+ }
+ EOCP
+- if $cc try.c -o try >/dev/null 2>&1 ; then
++ if $cc $ldflags try.c -o try >/dev/null 2>&1 ; then
+ dflt=`try`
+ else
+ dflt='?'
+@@ -8447,7 +8471,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="$*"
+@@ -8517,7 +8541,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
+@@ -8534,7 +8558,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
+@@ -9272,7 +9296,7 @@
+ else
+ echo "false"
+ fi
+-$rm -f varargs.o
++$rm -f varargs$obj_ext
+ EOP
+ chmod +x varargs
+
+@@ -9596,7 +9620,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/os2/dlfcn.h b/os2/dlfcn.h
index df2ea33d32..c96f97f82d 100644
--- a/os2/dlfcn.h
+++ b/os2/dlfcn.h
@@ -1,6 +1,3 @@
void *dlopen(char *path, int mode);
void *dlsym(void *handle, char *symbol);
char *dlerror(void);
-void *dlopen(char *path, int mode);
-void *dlsym(void *handle, char *symbol);
-char *dlerror(void);
diff --git a/os2/notes b/os2/notes
deleted file mode 100644
index e8026aabbf..0000000000
--- a/os2/notes
+++ /dev/null
@@ -1,27 +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 --git a/os2/os2.c b/os2/os2.c
index fee5ffbc46..c9d1e55f6c 100644
--- a/os2/os2.c
+++ b/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,11 +13,37 @@
#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. */
@@ -36,7 +60,7 @@ get_sysinfo(ULONG pid, ULONG flags)
rc = QuerySysState(flags, pid, pbuffer, buf_len);
while (rc == ERROR_BUFFER_OVERFLOW) {
Renew(pbuffer, buf_len *= 2, char);
- rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
+ rc = QuerySysState(flags, pid, pbuffer, buf_len);
}
if (rc) {
FillOSError(rc);
@@ -75,6 +99,7 @@ setpriority(int which, int pid, int val)
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)
@@ -116,6 +141,7 @@ getpriority(int which /* ignored */, int pid)
PIB *pib;
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) { */
@@ -130,6 +156,23 @@ getpriority(int which /* ignored */, int pid)
/*****************************************************************************/
/* spawn */
+typedef void (*Sigfunc) _((int));
+
+static
+Sigfunc rsignal(signo,handler)
+int signo;
+Sigfunc handler;
+{
+ struct sigaction act,oact;
+
+ act.sa_handler = handler;
+ sigemptyset(&act.sa_mask);
+ act.sa_flags = 0;
+ if (sigaction(signo, &act, &oact) < 0)
+ return(SIG_ERR);
+ else
+ return(oact.sa_handler);
+}
static int
result(int flag, int pid)
@@ -137,22 +180,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
@@ -170,7 +227,7 @@ register SV **sp;
New(401,Argv, sp - mark + 1, char*);
a = Argv;
- if (mark < sp && SvIOKp(*(mark+1))) {
+ if (mark < sp && SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
++mark;
flag = SvIVx(*mark);
}
@@ -187,8 +244,14 @@ 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? */
if (really && *(tmps = SvPV(really, na)))
rc = result(trueflag, spawnvp(flag,tmps,Argv));
else
@@ -203,14 +266,20 @@ 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;
+ char *shell, *copt, *news = NULL;
int rc;
#ifdef TRYSHELL
@@ -227,13 +296,22 @@ 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_PATH;
+ 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(4545, news, strlen(cmd) - 7 + l, char);
+ strcpy(news, sh_path);
+ strcpy(news + l, cmd + 7);
+ cmd = news;
+ }
+
/* save an extra exec if possible */
/* see if there are shell metacharacters in it */
@@ -249,16 +327,26 @@ 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;
}
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;
}
}
@@ -276,33 +364,130 @@ char *cmd;
}
*a = Nullch;
if (Argv[0]) {
- rc = result(P_WAIT, spawnvp(P_NOWAIT,Argv[0],Argv));
+ 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 && dowarn)
- warn("Can't spawn \"%s\": %s", Argv[0], Strerror(errno));
+ warn("Can't %s \"%s\": %s",
+ (execf == EXECF_SPAWN ? "spawn" : "exec"),
+ Argv[0], Strerror(errno));
if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */
} else
rc = -1;
+ if (news) Safefree(news);
do_execfree();
return rc;
}
-#ifndef HAS_FORK
-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_PATH);
+ 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 */
+
}
-#endif
-/*****************************************************************************/
+/******************************************************************/
#ifndef HAS_FORK
int
@@ -314,7 +499,7 @@ fork(void)
}
#endif
-/*****************************************************************************/
+/*******************************************************************/
/* not implemented in EMX 0.9a */
void * ctermid(x) { return 0; }
@@ -323,18 +508,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 */
@@ -362,55 +587,22 @@ os2_stat(char *name, struct stat *st)
#endif
-#ifndef NO_SYS_ALLOC
-
-static char *oldchunk;
-static long oldsize;
+#ifdef USE_PERL_SBRK
-#define _32_K (1<<15)
-#define _64_K (1<<16)
-
-/* 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 */
@@ -463,8 +655,8 @@ mod2fname(sv)
SV *sv;
{
static char fname[9];
- int pos = 7;
- int len;
+ int pos = 6, len, avlen;
+ unsigned int sum = 0;
AV *av;
SV *svp;
char *s;
@@ -473,13 +665,30 @@ mod2fname(sv)
sv = SvRV(sv);
if (SvTYPE(sv) != SVt_PVAV)
croak("Not array reference given to mod2fname");
- if (av_len((AV*)sv) < 0)
+
+ avlen = av_len((AV*)sv);
+ if (avlen < 0)
croak("Empty array reference given to mod2fname");
- s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na);
+
+ s = SvPV(*av_fetch((AV*)sv, avlen, FALSE), na);
strncpy(fname, s, 8);
- if ((len=strlen(s)) < 7) pos = len;
- fname[pos] = '_';
- fname[pos + 1] = '\0';
+ 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;
}
@@ -505,6 +714,7 @@ 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))
@@ -514,7 +724,349 @@ os2error(int rc)
return buf;
}
-OS2_Perl_data_t OS2_Perl_data;
+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) = RETVAL ? &sv_yes : &sv_no;
+ 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) = RETVAL ? &sv_yes : &sv_no;
+ 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) = RETVAL ? &sv_yes : &sv_no;
+ 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) = RETVAL ? &sv_yes : &sv_no;
+ 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) = RETVAL ? &sv_yes : &sv_no;
+ 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) = RETVAL ? &sv_yes : &sv_no;
+ if (SvREFCNT(ST(0))) sv_2mortal(ST(0));
+ }
+ XSRETURN(1);
+}
int
Xs_OS2_init()
@@ -522,17 +1074,31 @@ Xs_OS2_init()
char *file = __FILE__;
{
GV *gv;
-
- newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
+
+ 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);
-#ifdef PERL_IS_AOUT
+ 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()
{
@@ -541,11 +1107,50 @@ Perl_OS2_init()
settmppath();
OS2_Perl_data.xs_init = &Xs_OS2_init;
if ( (shell = getenv("PERL_SH_DRIVE")) ) {
+ New(404, 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(404, 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] = '/';
+ }
}
}
-char sh_path[33] = BIN_SH;
+#undef tmpnam
+#undef tmpfile
-extern void dlopen();
-void *fakedl = &dlopen; /* Pull in dynaloading part. */
+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. */
+}
diff --git a/os2/os2ish.h b/os2/os2ish.h
index 917f515112..cf945f36d3 100644
--- a/os2/os2ish.h
+++ b/os2/os2ish.h
@@ -45,8 +45,13 @@
#endif
#define ABORT() kill(getpid(),SIGABRT);
-#define BIT_BUCKET "/dev/null" /* Will this work? */
+#define BIT_BUCKET "/dev/nul" /* Will this work? */
+#if defined(I_SYS_UN) && !defined(TCPIPV4)
+/* It is not working without TCPIPV4 defined. */
+# undef I_SYS_UN
+#endif
+
void Perl_OS2_init();
#define PERL_SYS_INIT(argcp, argvp) STMT_START { \
@@ -62,12 +67,37 @@ void Perl_OS2_init();
#define dXSUB_SYS int fake = OS2_XS_init()
#ifdef PERL_IS_AOUT
-#define NO_SYS_ALLOC
+/* # 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
/*
* fwrite1() should be a routine with the same calling sequence as fwrite(),
@@ -79,6 +109,11 @@ extern char *tmppath;
#define my_getenv(var) getenv(var)
+void *emx_calloc (size_t, size_t);
+void emx_free (void *);
+void *emx_malloc (size_t);
+void *emx_realloc (void *, size_t);
+
/*****************************************************************************/
#include <stdlib.h> /* before the following definitions */
@@ -142,7 +177,7 @@ extern OS2_Perl_data_t OS2_Perl_data;
#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. */
+/* 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))
@@ -160,8 +195,10 @@ extern OS2_Perl_data_t OS2_Perl_data;
set_Perl_HAB_f; \
}
-extern char sh_path[33];
-#define SH_PATH sh_path
+#define STATIC_FILE_LENGTH 127
+
+#define PERLLIB_MANGLE(s, n) perllib_mangle((s), (n))
+char *perllib_mangle(char *, unsigned int);
char *os2error(int rc);
@@ -171,8 +208,8 @@ char *os2error(int rc);
Dos32QuerySysState(flags, 0, pid, 0, buf, bufsz)
#define QSS_PROCESS 1
-#define QSS_MODULE 2
-#define QSS_SEMAPHORES 4
+#define QSS_MODULE 4
+#define QSS_SEMAPHORES 2
#define QSS_FILE 8 /* Buggy until fixpack18 */
#define QSS_SHARED 16
@@ -335,3 +372,4 @@ typedef struct {
PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags);
#endif /* _OS2EMX_H */
+
diff --git a/os2/perl2cmd.pl b/os2/perl2cmd.pl
index aa1c353f13..c17ab761aa 100644
--- a/os2/perl2cmd.pl
+++ b/os2/perl2cmd.pl
@@ -16,7 +16,8 @@ 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|.*/||;
diff --git a/patchlevel.h b/patchlevel.h
index 8aac9310d3..73210e2242 100644
--- a/patchlevel.h
+++ b/patchlevel.h
@@ -1,5 +1,5 @@
#define PATCHLEVEL 3
-#define SUBVERSION 1
+#define SUBVERSION 12
/*
local_patches -- list of locally applied less-than-subversion patches.
diff --git a/perl.c b/perl.c
index 7600f8f1fa..3e03044cc8 100644
--- a/perl.c
+++ b/perl.c
@@ -15,11 +15,10 @@
#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";
@@ -36,6 +35,7 @@ dEXT char rcsid[] = "perl.c\nPatch level: ###\n";
#endif
static void find_beginning _((void));
+static void forbid_setid _((char *));
static void incpush _((char *));
static void init_ids _((void));
static void init_debugger _((void));
@@ -117,21 +117,27 @@ register PerlInterpreter *sv_interp;
rsfp = Nullfp;
statname = Nullsv;
tmps_floor = -1;
+ perl_destruct_level = 1;
#endif
init_ids();
+ 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)
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 */
@@ -154,11 +160,22 @@ 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
+ /* 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;
+
LEAVE;
FREETMPS;
@@ -186,8 +203,24 @@ register PerlInterpreter *sv_interp;
/* The exit() function will do everything that needs doing. */
return;
}
-
+
+ /* loosen bonds of global variables */
+
+ setdefout(Nullgv);
+
+ sv_free(nrs);
+ nrs = Nullsv;
+
+ sv_free(lastscream);
+ lastscream = Nullsv;
+
+ sv_free(statname);
+ statname = Nullsv;
+ statgv = Nullgv;
+ laststatval = -1;
+
/* Prepare to destruct main symbol table. */
+
hv = defstash;
defstash = 0;
SvREFCNT_dec(hv);
@@ -337,7 +370,7 @@ setuid perl scripts securely.\n");
calllist(endav);
return(statusvalue); /* my_exit() was called */
case 3:
- fprintf(stderr, "panic: top_env\n");
+ PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
return 1;
}
@@ -388,18 +421,22 @@ setuid perl scripts securely.\n");
(void)mktemp(e_tmpname);
if (!*e_tmpname)
croak("Can't mktemp()");
- e_fp = fopen(e_tmpname,"w");
+ e_fp = PerlIO_open(e_tmpname,"w");
if (!e_fp)
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");
+ forbid_setid("-I");
sv_catpv(sv,"-");
sv_catpv(sv,s);
sv_catpv(sv," ");
@@ -414,12 +451,12 @@ setuid perl scripts securely.\n");
}
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;
@@ -500,7 +537,7 @@ setuid perl scripts securely.\n");
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))
croak("Can't write to temp file for -e: %s", Strerror(errno));
e_fp = Nullfp;
argc++,argv--;
@@ -508,8 +545,8 @@ setuid perl scripts securely.\n");
}
else if (scriptname == Nullch) {
#ifdef MSDOS
- if ( isatty(fileno(stdin)) )
- moreswitches("v");
+ if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
+ moreswitches("h");
#endif
scriptname = "-";
}
@@ -619,7 +656,7 @@ PerlInterpreter *sv_interp;
return(statusvalue); /* my_exit() was called */
case 3:
if (!restartop) {
- fprintf(stderr, "panic: restartop\n");
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
FREETMPS;
return 1;
}
@@ -630,15 +667,15 @@ PerlInterpreter *sv_interp;
break;
}
- DEBUG_r(fprintf(stderr, "%s $` $& $' support.\n",
+ DEBUG_r(PerlIO_printf(PerlIO_stderr(), "%s $` $& $' support.\n",
sawampersand ? "Enabling" : "Omitting"));
if (!restartop) {
DEBUG_x(dump_all());
- DEBUG(fprintf(Perl_debug_log,"\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)
@@ -809,8 +846,12 @@ I32 flags; /* See G_* flags in cop.h */
if (flags & G_ARRAY)
myop.op_flags |= OPf_LIST;
- if (perldb && curstash != debstash
- && (DBcv || (DBcv = GvCV(DBsub)))) /* to handle first BEGIN of -d */
+ if (perldb && 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) {
@@ -1037,6 +1078,9 @@ I32 namlen;
# define PERLLIB_SEP ':'
# endif
#endif
+#ifndef PERLLIB_MANGLE
+# define PERLLIB_MANGLE(s,n) (s)
+#endif
static void
incpush(p)
@@ -1056,10 +1100,11 @@ char *p;
p++;
}
if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
- av_push(GvAVn(incgv), newSVpv(p, (STRLEN)(s - p)));
+ av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, (STRLEN)(s - p)),
+ (STRLEN)(s - p)));
p = s + 1;
} else {
- av_push(GvAVn(incgv), newSVpv(p, 0));
+ av_push(GvAVn(incgv), newSVpv(PERLLIB_MANGLE(p, 0), 0));
break;
}
}
@@ -1133,7 +1178,7 @@ char *s;
s++;
return s;
case 'd':
- taint_not("-d");
+ forbid_setid("-d");
s++;
if (*s == ':' || *s == '=') {
sprintf(buf, "use Devel::%s;", ++s);
@@ -1147,7 +1192,7 @@ char *s;
return s;
case 'D':
#ifdef DEBUGGING
- taint_not("-D");
+ forbid_setid("-D");
if (isALPHA(s[1])) {
static char debopts[] = "psltocPmfrxuLHXD";
char *d;
@@ -1178,7 +1223,7 @@ char *s;
*s = '\0';
break;
case 'I':
- taint_not("-I");
+ forbid_setid("-I");
if (*++s) {
char *e;
for (e = s; *e && !isSPACE(*e); e++) ;
@@ -1211,10 +1256,10 @@ char *s;
}
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 ";
@@ -1254,7 +1299,7 @@ char *s;
s++;
return s;
case 's':
- taint_not("-s");
+ forbid_setid("-s");
doswitches = TRUE;
s++;
return s;
@@ -1277,25 +1322,24 @@ char *s;
printf("\nThis is perl, version %s",patchlevel);
#endif
- fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
- fputs("\n\t+ suidperl security patch", stdout);
+ printf("\n\nCopyright 1987-1996, Larry Wall\n");
+ printf("\n\t+ suidperl security patch");
#ifdef MSDOS
- fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
- stdout);
+ printf("\n\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-1996, Andreas Kaiser, Ilya Zakharevich\n", stdout);
+ printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
+ "Version 5 port Copyright (c) 1994-1996, 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;
@@ -1337,7 +1381,7 @@ my_unexec()
status = unexec(buf, tokenbuf, &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", tokenbuf, buf);
exit(status);
#else
# ifdef VMS
@@ -1374,6 +1418,7 @@ init_main_stash()
defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
GvMULTI_on(errgv);
+ sv_setpvn(GvSV(errgv), "", 0);
curstash = defstash;
compiling.cop_stash = defstash;
debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
@@ -1456,7 +1501,7 @@ SV *sv;
extidx = 0;
do {
#endif
- DEBUG_p(fprintf(Perl_debug_log,"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 */
@@ -1496,9 +1541,10 @@ 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) {
@@ -1570,16 +1616,20 @@ sed %s -e \"/^[^#]/b\" \
rsfp = my_popen(buf,"r");
}
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 &&
@@ -1625,7 +1675,7 @@ char *scriptname;
#ifdef DOSUID
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;
@@ -1665,9 +1715,9 @@ 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,
+ PerlIO_printf(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,
@@ -1700,13 +1750,13 @@ 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++;
- for (s2 = s; (s2 > tokenbuf+2 &&
+ 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");
@@ -1730,7 +1780,7 @@ 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 */
@@ -1805,16 +1855,16 @@ 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);
- lseek(fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ 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]);
+ (void)sprintf(buf, "/dev/fd/%d/%.127s", PerlIO_fileno(rsfp), origargv[which]);
origargv[which] = buf;
#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);
@@ -1824,7 +1874,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#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)
@@ -1845,12 +1895,12 @@ find_beginning()
/* 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] == '!' && (s = instr(s,"perl"))) {
- ungetc('\n',rsfp); /* to keep line count right */
+ PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */
doextract = FALSE;
while (*s && !(isSPACE (*s) || *s == '#')) s++;
s2 = s;
@@ -1882,6 +1932,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;
@@ -1903,15 +1963,32 @@ static void
init_stacks()
{
curstack = newAV();
- mainstack = curstack; /* remember in case we switch stacks */
- AvREAL_off(curstack); /* not a real array */
+ mainstack = curstack; /* remember in case we switch stacks */
+ AvREAL_off(curstack); /* not a real array */
av_extend(curstack,127);
stack_base = AvARRAY(curstack);
stack_sp = stack_base;
stack_max = stack_base + 127;
- /* Shouldn't these stacks be per-interpreter? */
+ cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
+ New(50,cxstack,cxstack_max + 1,CONTEXT);
+ cxstack_ix = -1;
+
+ New(50,tmps_stack,128,SV*);
+ tmps_ix = -1;
+ tmps_max = 128;
+
+ DEBUG( {
+ 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 {
@@ -1942,20 +2019,7 @@ init_stacks()
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;
-
- New(50,tmps_stack,128,SV*);
- tmps_ix = -1;
- tmps_max = 128;
-
- DEBUG( {
- New(51,debname,128,char);
- New(52,debdelim,128,char);
- } )
+ }
}
static void
@@ -1963,14 +2027,18 @@ 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;
-
lex_start(linestr);
rsfp = tmpfp;
subname = newSVpv("main",4);
@@ -1986,14 +2054,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);
@@ -2001,7 +2069,7 @@ 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));
@@ -2047,7 +2115,7 @@ 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);
@@ -2096,10 +2164,9 @@ register char **env;
#endif
hv_magic(hv, envgv, 'E');
}
- tainted = 0;
+ TAINT_NOT;
if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
sv_setiv(GvSV(tmpgv),(I32)getpid());
-
}
static void
@@ -2107,13 +2174,29 @@ init_perllib()
{
char *s;
if (!tainting) {
+#ifndef VMS
s = getenv("PERL5LIB");
if (s)
incpush(s);
else
incpush(getenv("PERLLIB"));
+#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); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ else
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf);
+#endif /* VMS */
}
+/* Use the ~-expanded versions of APPLIB (undocumented),
+ ARCHLIB PRIVLIB SITEARCH SITELIB and OLDARCHLIB
+*/
#ifdef APPLLIB_EXP
incpush(APPLLIB_EXP);
#endif
@@ -2200,7 +2283,7 @@ AV* list;
return;
case 3:
if (!restartop) {
- fprintf(stderr, "panic: restartop\n");
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
FREETMPS;
break;
}
diff --git a/perl.h b/perl.h
index 60b11f1900..85c7c86844 100644
--- a/perl.h
+++ b/perl.h
@@ -10,6 +10,20 @@
#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 */
+
/*
* STMT_START { statements; } STMT_END;
* can be used as a single statement, as in
@@ -38,6 +52,16 @@
#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
#endif
@@ -74,34 +98,83 @@
# 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
@@ -115,14 +188,28 @@
#include <ctype.h>
#endif /* USE_NEXT_CTYPE */
-#ifdef I_LOCALE
-#include <locale.h>
-#endif
-
#ifdef METHOD /* Defined by OSF/1 v3.0 by ctype.h */
#undef METHOD
#endif
+#ifdef I_LOCALE
+# include <locale.h>
+#endif
+
+#if !defined(NO_LOCALE) && defined(HAS_SETLOCALE)
+# define USE_LOCALE
+# if !defined(NO_LOCALE_COLLATE) && defined(LC_COLLATE) \
+ && defined(HAS_STRXFRM)
+# define USE_LOCALE_COLLATE
+# endif
+# if !defined(NO_LOCALE_CTYPE) && defined(LC_CTYPE)
+# define USE_LOCALE_CTYPE
+# endif
+# if !defined(NO_LOCALE_NUMERIC) && defined(LC_NUMERIC)
+# define USE_LOCALE_NUMERIC
+# endif
+#endif /* !NO_LOCALE && HAS_SETLOCALE */
+
#include <setjmp.h>
#ifdef I_SYS_PARAM
@@ -136,27 +223,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
-# ifndef DONT_HIDEMYMALLOC
-# define malloc Mymalloc
+
+# ifdef HIDEMYMALLOC
+# define malloc Mymalloc
+# define calloc Mycalloc
# define realloc Myremalloc
-# define free Myfree
-# define calloc Mycalloc
+# define free Myfree
+# endif
+# ifdef EMBEDMYMALLOC
+# define malloc Perl_malloc
+# define calloc Perl_calloc
+# define realloc Perl_realloc
+# define free Perl_free
# endif
-# define safemalloc malloc
+
+# undef safemalloc
+# undef safecalloc
+# undef saferealloc
+# undef safefree
+# define safemalloc malloc
+# define safecalloc calloc
# define saferealloc realloc
-# define safefree free
-# define safecalloc calloc
-#endif
+# define safefree free
+
+#endif /* MYMALLOC */
#define MEM_SIZE Size_t
+#if defined(STANDARD_C) && defined(I_STDDEF)
+# include <stddef.h>
+# define OFFSETOF(s,m) offsetof(s,m)
+#else
+# define OFFSETOF(s,m) (Size_t)(&(((s *)0)->m))
+#endif
+
#if defined(I_STRING) || defined(__cplusplus)
# include <string.h>
#else
@@ -168,10 +274,6 @@
#define strrchr rindex
#endif
-#if defined(mips) && defined(ultrix) && !defined(__STDC__)
-# undef HAS_MEMCMP
-#endif
-
#ifdef I_MEMORY
# include <memory.h>
#endif
@@ -209,42 +311,42 @@
# endif
#endif /* HAS_MEMSET */
-#ifdef HAS_MEMCMP
+#if !defined(HAS_MEMMOVE) && !defined(memmove)
+# if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
+# define memmove(d,s,l) bcopy(s,d,l)
+# else
+# if defined(HAS_MEMCPY) && defined(HAS_SAFE_MEMCPY)
+# define memmove(d,s,l) memcpy(d,s,l)
+# else
+# define memmove(d,s,l) my_bcopy(s,d,l)
+# endif
+# endif
+#endif
+
+#if defined(mips) && defined(ultrix) && !defined(__STDC__)
+# undef HAS_MEMCMP
+#endif
+
+#if defined(HAS_MEMCMP) && defined(HAS_SANE_MEMCMP)
# if !defined(STANDARD_C) && !defined(I_STRING) && !defined(I_MEMORY)
# ifndef memcmp
extern int memcmp _((char*, char*, int));
# endif
# endif
+# ifdef BUGGY_MSC
+ # pragma function(memcmp)
+# endif
#else
# ifndef memcmp
# define memcmp my_memcmp
# endif
-#endif /* HAS_MEMCMP */
+#endif /* HAS_MEMCMP && HAS_SANE_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 */
-
-#if !defined(HAS_MEMMOVE) && !defined(memmove)
-# if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY)
-# define memmove(d,s,l) bcopy(s,d,l)
-# else
-# if defined(HAS_MEMCPY) && defined(HAS_SAFE_MEMCPY)
-# define memmove(d,s,l) memcpy(d,s,l)
-# else
-# define memmove(d,s,l) my_bcopy(s,d,l)
-# endif
-# endif
-#endif
-
-#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
+#endif /* !HAS_BCMP */
#ifdef I_NETINET_IN
# include <netinet/in.h>
@@ -286,10 +388,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))
@@ -318,10 +418,8 @@
# define SETERRNO(errcode,vmserrcode) STMT_START {set_errno(errcode); set_vaxc_errno(vmserrcode);} STMT_END
#endif
-#ifndef MSDOS
-# ifndef errno
+#ifndef errno
extern int errno; /* ANSI allows errno to be an lvalue expr */
-# endif
#endif
#ifdef HAS_STRERROR
@@ -510,6 +608,19 @@
#undef UV
#endif
+/* XXX QUAD stuff is not currently supported on most systems.
+ Specifically, perl internals don't support long long. Among
+ the many problems is that some compilers support long long,
+ but the underlying library functions (such as sprintf) don't.
+ Some things do work (such as quad pack/unpack on convex);
+ also some systems use long long for the fpos_t typedef. That
+ seems to work too.
+
+ The IV type is supposed to be long enough to hold any integral
+ value or a pointer.
+ --Andy Dougherty August 1996
+*/
+
#ifdef HAS_QUAD
# ifdef cray
# define Quad_t int
@@ -522,9 +633,198 @@
# endif
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;
@@ -560,6 +860,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;
@@ -597,13 +898,15 @@ typedef I32 (*filter_t) _((int, SV *, int));
# endif
# endif
#endif
-
-#ifndef SH_PATH /* May be a variable. */
-# define SH_PATH BIN_SH
-#endif
-
-#ifndef HAS_PAUSE
-#define pause() sleep((32767<<16)+32767)
+
+/* 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
@@ -706,7 +1009,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)))
@@ -717,11 +1026,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
@@ -748,7 +1063,7 @@ Gid_t getegid _((void));
#ifdef DEBUGGING
#ifndef Perl_debug_log
-#define Perl_debug_log stderr
+#define Perl_debug_log PerlIO_stderr()
#endif
#define YYDEBUG 1
#define DEB(a) a
@@ -791,12 +1106,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*));
@@ -839,7 +1156,11 @@ 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
char *getenv _((const char*));
Off_t lseek _((int,Off_t,int));
char *getlogin _((void));
@@ -865,6 +1186,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
@@ -916,6 +1245,7 @@ EXT U32 origalen;
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 */
@@ -1029,8 +1359,10 @@ EXT SV * psig_ptr[];
EXT SV * psig_name[];
#endif
+/* fast case folding tables */
+
#ifdef DOINIT
-EXT unsigned char fold[] = { /* fast case folding table */
+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,
@@ -1069,6 +1401,45 @@ EXT unsigned char fold[];
#endif
#ifdef DOINIT
+EXT unsigned char fold_locale[] = {
+ 0, 1, 2, 3, 4, 5, 6, 7,
+ 8, 9, 10, 11, 12, 13, 14, 15,
+ 16, 17, 18, 19, 20, 21, 22, 23,
+ 24, 25, 26, 27, 28, 29, 30, 31,
+ 32, 33, 34, 35, 36, 37, 38, 39,
+ 40, 41, 42, 43, 44, 45, 46, 47,
+ 48, 49, 50, 51, 52, 53, 54, 55,
+ 56, 57, 58, 59, 60, 61, 62, 63,
+ 64, 'a', 'b', 'c', 'd', 'e', 'f', 'g',
+ 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
+ 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
+ 'x', 'y', 'z', 91, 92, 93, 94, 95,
+ 96, 'A', 'B', 'C', 'D', 'E', 'F', 'G',
+ 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
+ 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
+ 'X', 'Y', 'Z', 123, 124, 125, 126, 127,
+ 128, 129, 130, 131, 132, 133, 134, 135,
+ 136, 137, 138, 139, 140, 141, 142, 143,
+ 144, 145, 146, 147, 148, 149, 150, 151,
+ 152, 153, 154, 155, 156, 157, 158, 159,
+ 160, 161, 162, 163, 164, 165, 166, 167,
+ 168, 169, 170, 171, 172, 173, 174, 175,
+ 176, 177, 178, 179, 180, 181, 182, 183,
+ 184, 185, 186, 187, 188, 189, 190, 191,
+ 192, 193, 194, 195, 196, 197, 198, 199,
+ 200, 201, 202, 203, 204, 205, 206, 207,
+ 208, 209, 210, 211, 212, 213, 214, 215,
+ 216, 217, 218, 219, 220, 221, 222, 223,
+ 224, 225, 226, 227, 228, 229, 230, 231,
+ 232, 233, 234, 235, 236, 237, 238, 239,
+ 240, 241, 242, 243, 244, 245, 246, 247,
+ 248, 249, 250, 251, 252, 253, 254, 255
+};
+#else
+EXT unsigned char fold_locale[];
+#endif
+
+#ifdef DOINIT
EXT 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,
@@ -1160,7 +1531,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;
@@ -1210,7 +1581,7 @@ EXT U32 hints; /* various compilation flags */
#define HINT_BLOCK_SCOPE 0x00000100
#define HINT_STRICT_SUBS 0x00000200
#define HINT_STRICT_VARS 0x00000400
-#define HINT_STRICT_UNTIE 0x00000800
+#define HINT_LOCALE 0x00000800
/**************************************************************************/
/* This regexp stuff is global since it always happens within 1 expr eval */
@@ -1235,6 +1606,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 */
/***********************************************/
@@ -1282,17 +1656,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(1); /* 0=none, 1=full, 2=full with checks */
/* magical thingies */
IEXT Time_t Ibasetime; /* $^T */
@@ -1455,20 +1826,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
@@ -1486,6 +1843,7 @@ extern "C" {
/* The following must follow proto.h */
#ifdef DOINIT
+
EXT MGVTBL vtbl_sv = {magic_get,
magic_set,
magic_len,
@@ -1519,21 +1877,33 @@ 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,
0, 0, 0};
EXT MGVTBL vtbl_vec = {0, magic_setvec,
0, 0, 0};
+EXT MGVTBL vtbl_vivary = {0, magic_setvivary,
+ 0, 0, magic_freevivary};
EXT MGVTBL vtbl_pos = {magic_getpos,
magic_setpos,
0, 0, 0};
EXT MGVTBL vtbl_bm = {0, magic_setbm,
0, 0, 0};
+EXT MGVTBL vtbl_fm = {0, magic_setfm,
+ 0, 0, 0};
EXT MGVTBL vtbl_uvar = {magic_getuvar,
magic_setuvar,
0, 0, 0};
+#ifdef USE_LOCALE_COLLATE
+EXT MGVTBL vtbl_collxfrm = {0,
+ magic_setcollxfrm,
+ 0, 0, 0};
+#endif
+
#ifdef OVERLOAD
EXT MGVTBL vtbl_amagic = {0, magic_setamagic,
0, 0, magic_setamagic};
@@ -1541,7 +1911,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;
@@ -1555,19 +1926,26 @@ 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_vivary;
EXT MGVTBL vtbl_pos;
EXT MGVTBL vtbl_bm;
+EXT MGVTBL vtbl_fm;
EXT MGVTBL vtbl_uvar;
+#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;
@@ -1654,4 +2032,46 @@ enum {
};
#endif /* OVERLOAD */
+#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/perl_exp.SH b/perl_exp.SH
index d941b0eb31..49e8119591 100755
--- a/perl_exp.SH
+++ b/perl_exp.SH
@@ -5,6 +5,9 @@
# Create the export list for perl.
# Needed by AIX to do dynamic linking.
+# NOTE: If you're using 'old_embed.pl', don't use this script!
+# Use 'old_perl_exp.SH' instead.
+
# 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.
@@ -17,17 +20,35 @@ echo "Extracting perl.exp"
rm -f perl.exp
echo "#!" > perl.exp
-sed -n '/^[A-Za-z]/ s/^/Perl_/p' global.sym >> perl.exp
-
-# 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
+case "$bincompat3" in
+y*)
+ global=/tmp/exp$$g
+ interp=/tmp/exp$$i
+ compat3=/tmp/exp$$c
+ trap 'rm -f $global $interp $compat3' 0
+ trap 'exit 1' 1 2 3 13 15
+ 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_/p' >> perl.exp
+ comm -12 $global $compat3 >> perl.exp
+ comm -12 $interp $compat3 | sed 's/^/Perl_/p' >> perl.exp
+ comm -23 $interp $compat3 >> perl.exp
+ ;;
+*)
+ sed -n '/^[A-Za-z]/ s/^/Perl_/p' global.sym interp.sym >> perl.exp
+ ;;
+esac
# 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
@@ -43,8 +64,4 @@ perl_call_pv
perl_call_method
perl_call_sv
perl_requirepv
-safecalloc
-safemalloc
-saferealloc
-safefree
END
diff --git a/perlio.c b/perlio.c
new file mode 100644
index 0000000000..a1e6ff0f5d
--- /dev/null
+++ b/perlio.c
@@ -0,0 +1,643 @@
+/* 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;
+char *ptr;
+int cnt;
+{
+#ifdef FILE_bufsiz
+ char *e = (char *)(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) = (STDCHAR *) 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
+char *
+PerlIO_get_ptr(f)
+PerlIO *f;
+{
+#ifdef FILE_ptr
+ return (char *) FILE_ptr(f);
+#else
+ croak("Cannot get 'ptr' of FILE * on this system");
+ return NULL;
+#endif
+}
+
+#undef PerlIO_get_base
+char *
+PerlIO_get_base(f)
+PerlIO *f;
+{
+#ifdef FILE_base
+ return (char *) 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");
+#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
+ setvbuf(f, Nullch, _IOLBF, 0);
+#endif
+}
+
+#undef PerlIO_putc
+int
+PerlIO_putc(f,ch)
+PerlIO *f;
+int ch;
+{
+ putc(ch,f);
+}
+
+#undef PerlIO_ungetc
+int
+PerlIO_ungetc(f,ch)
+PerlIO *f;
+int ch;
+{
+ ungetc(ch,f);
+}
+
+#undef PerlIO_read
+int
+PerlIO_read(f,buf,count)
+PerlIO *f;
+void *buf;
+size_t count;
+{
+ return fread(buf,1,count,f);
+}
+
+#undef PerlIO_write
+int
+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(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/perlio.h b/perlio.h
new file mode 100644
index 0000000000..a11750442d
--- /dev/null
+++ b/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 int PerlIO_read _((PerlIO *,void *,size_t));
+#endif
+#ifndef PerlIO_write
+extern int 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 char * 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 *,char *,int));
+#endif
+#ifndef PerlIO_get_base
+extern char * 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/perlsdio.h b/perlsdio.h
new file mode 100644
index 0000000000..c3714410d6
--- /dev/null
+++ b/perlsdio.h
@@ -0,0 +1,297 @@
+/*
+ * 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_read(f,buf,count) fread(buf,1,count,f)
+#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) && 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
+#define PerlIO_getc(f) getc(f)
+#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(),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(),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/perlsfio.h b/perlsfio.h
new file mode 100644
index 0000000000..8c9387fbd0
--- /dev/null
+++ b/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/perly.c b/perly.c
index 2735893005..8f1de62a77 100644
--- a/perly.c
+++ b/perly.c
@@ -12,1105 +12,1055 @@ 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,
+ 40, 0, 7, 5, 8, 6, 9, 9, 9, 10,
+ 10, 10, 10, 22, 22, 22, 22, 22, 22, 13,
+ 13, 13, 12, 12, 12, 12, 37, 37, 11, 11,
+ 11, 11, 11, 11, 11, 11, 11, 24, 24, 25,
+ 25, 26, 27, 28, 29, 30, 39, 39, 1, 1,
+ 1, 1, 3, 3, 41, 41, 36, 36, 4, 42,
+ 42, 43, 14, 14, 14, 23, 23, 23, 34, 34,
+ 34, 34, 34, 34, 34, 34, 35, 35, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 31, 31, 32, 32, 32, 2, 2, 38,
+ 21, 16, 17, 18, 19, 20, 33, 33, 33, 33,
};
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, 6, 3, 3, 1, 2, 3, 1,
- 3, 5, 6, 3, 5, 2, 4, 4, 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, 4, 4, 0, 2, 8, 8,
+ 5, 5, 10, 9, 8, 11, 3, 0, 1, 0,
+ 1, 1, 1, 1, 1, 1, 0, 1, 1, 1,
+ 1, 1, 4, 3, 5, 5, 0, 1, 0, 3,
+ 2, 6, 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,
- 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,
+ 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, 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, 48, 59, 59, 0, 59, 8, 49,
+ 9, 11, 0, 50, 51, 52, 0, 0, 0, 61,
+ 0, 14, 4, 151, 0, 0, 126, 0, 146, 0,
+ 59, 59, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 158, 159, 0,
+ 0, 0, 0, 0, 0, 0, 0, 12, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 10, 0, 0,
+ 0, 0, 116, 118, 0, 0, 0, 0, 152, 0,
+ 54, 0, 60, 0, 7, 167, 170, 169, 168, 0,
+ 0, 0, 0, 0, 0, 4, 0, 4, 0, 4,
+ 0, 4, 0, 4, 4, 0, 0, 0, 0, 0,
+ 141, 0, 0, 0, 0, 74, 0, 165, 0, 132,
+ 0, 0, 0, 0, 0, 161, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 106, 0, 162, 163,
+ 164, 166, 0, 0, 37, 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, 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, 0, 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, 54, 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, 0, 0, 0, 0, 0, 98, 99, 0, 0,
+ 0, 0, 0, 0, 0, 0, 13, 0, 53, 58,
+ 0, 0, 0, 72, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 4, 145,
+ 147, 0, 0, 0, 0, 0, 0, 0, 108, 0,
+ 130, 0, 0, 105, 28, 0, 0, 19, 0, 0,
+ 0, 63, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 77, 0,
+ 78, 0, 0, 0, 0, 0, 0, 0, 128, 0,
+ 0, 56, 55, 0, 3, 0, 149, 0, 76, 109,
+ 0, 45, 0, 31, 46, 0, 32, 0, 0, 0,
+ 0, 25, 0, 26, 160, 0, 0, 39, 44, 0,
+ 0, 0, 148, 157, 75, 0, 133, 0, 135, 0,
+ 107, 0, 0, 0, 0, 0, 0, 0, 115, 0,
+ 113, 0, 124, 0, 129, 62, 73, 0, 0, 0,
+ 0, 6, 21, 0, 0, 0, 0, 0, 0, 70,
+ 134, 136, 123, 0, 121, 0, 0, 114, 0, 119,
+ 125, 111, 150, 0, 0, 0, 7, 0, 0, 0,
+ 0, 0, 0, 122, 120, 71, 29, 30, 23, 0,
+ 0, 24, 0, 35, 0, 0, 5, 0, 0, 0,
+ 34, 22, 33, 0, 36,
};
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, 17, 85, 337, 88, 313, 3, 11,
+ 12, 68, 272, 268, 70, 71, 72, 73, 74, 75,
+ 76, 278, 78, 279, 262, 265, 269, 281, 263, 266,
+ 116, 204, 90, 79, 242, 181, 145, 276, 13, 2,
+ 14, 15, 16,
};
short yysindex[] = { 0,
- 0, 0, 303, 0, 0, 0, -53, 0, 0, 0,
- 0, 0, 607, 0, 0, 0, -111, -242, -32, 0,
- -216, 0, 0, 0, 149, 149, 0, 8, 0, 2109,
- 0, 0, -15, -8, 4, 6, 32, 2109, 13, 20,
- 57, 149, 994, 2109, 1057, -206, 149, 2109, 938, 1291,
- 2109, 2109, 2109, 2109, 2109, 1347, 0, 2109, 2109, 1403,
- 149, 149, 149, 149, -203, 0, 68, 664, 491, -67,
- -52, 0, 0, -21, 73, 65, 0, 7, 0, -135,
- 0, -126, 0, 0, 0, 0, 0, 2109, 92, 2109,
- 491, 7, -135, 2109, 7, 2109, 7, 2109, 7, 2109,
- 7, 1466, 101, 491, 112, 1700, 938, 0, 102, 0,
- 1228, -22, 1228, 39, -58, 2109, 0, 68, 0, 68,
- -67, 0, 2109, 0, 1228, 472, 472, 472, -88, -88,
- 78, -10, 472, 472, 0, -85, 0, 0, 0, 0,
- 7, 0, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109,
- 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109,
- 2109, 2109, 2109, 2109, 0, 0, -29, 2109, 2109, 2109,
- 2109, 2109, 2109, 1756, 0, 0, 0, -46, 2109, 391,
- 0, 2109, -25, 2109, 7, -214, 129, -203, -5, -203,
- 1, -167, 9, -167, 117, 52, 0, 2109, 0, 0,
- 23, 60, 132, 2109, 1812, 1875, 0, 53, 0, 68,
- 2109, 86, 0, 0, 491, -214, -214, -214, -214, -147,
- 0, -54, 382, 1228, 1090, 771, 115, 491, 2942, 1523,
- 314, 1554, 392, 677, 472, 472, 2109, 0, 2109, 0,
- 141, 89, -42, 99, 46, 114, 64, 0, 26, 0,
- 0, 124, 0, 143, 0, 2109, 0, 0, 7, 0,
- 7, 0, 7, 7, 146, 0, 7, 0, 2109, 7,
- 35, 0, 0, 0, 37, 0, 49, 0, 55, 0,
- 130, 2109, 63, 2109, 67, 166, 2109, 0, 66, 0,
- 71, 0, 74, 0, 0, 0, 1170, -203, -203, -167,
- 0, 2109, -167, 131, -203, 7, 0, 0, 0, 0,
- 185, 0, 1119, 76, 0, 161, 0, 0, 0, 0,
- 0, 0, 0, 58, 0, 1466, 0, -203, 0, 0,
- 0, 7, 162, 0, -167, 7, 0, 0,
+ 0, 0, -178, 0, 0, 0, -49, 0, 0, 0,
+ 0, 0, 616, 0, 0, 0, -108, -233, 3, 0,
+ -230, 0, 0, 0, -24, -24, 0, 28, 0, 1899,
+ 0, 0, -17, -12, -11, -10, -35, 1899, 39, 54,
+ 60, 992, 936, -24, 1055, 1319, -217, 0, 0, -24,
+ 1899, 1899, 1899, 1899, 1899, 1899, 1375, 0, 1899, 1899,
+ 1431, -24, -24, -24, -24, 1899, -161, 0, 277, 3829,
+ -69, -42, 0, 0, -4, 88, 89, 97, 0, 24,
+ 0, -107, 0, -105, 0, 0, 0, 0, 0, 1899,
+ 114, 1899, 328, 24, -107, 0, 24, 0, 24, 0,
+ 24, 0, 24, 0, 0, 115, 3829, 133, 1490, 936,
+ 0, 328, 0, -69, 97, 0, 1899, 0, 137, 0,
+ 328, -19, 56, 19, 1899, 0, 97, 98, 98, 98,
+ -82, -82, 93, -21, 98, 98, 0, -87, 0, 0,
+ 0, 0, 328, 24, 0, 1899, 1899, 1899, 1899, 1899,
+ 1899, 1899, 1899, 1899, 1899, 1899, 1899, 1899, 1899, 1899,
+ 1899, 1899, 1899, 1899, 1899, 1899, 0, 0, -32, 1899,
+ 1899, 1899, 1899, 1899, 1899, 1665, 0, 1899, 0, 0,
+ -8, 1899, 357, 0, 1899, 82, 1899, 24, 1899, -161,
+ 1899, -161, 1899, -234, 1899, -234, 144, 1724, 0, 0,
+ 0, 4, 11, 138, 1899, 97, 1780, 1836, 0, 61,
+ 0, 1899, 96, 0, 0, -176, -176, 0, -176, -176,
+ -95, 0, 21, 1092, 328, 373, 434, 92, 3829, 1204,
+ 3238, 3721, 2430, 815, 419, 98, 98, 1899, 0, 1899,
+ 0, 173, -80, 55, -68, 57, -54, 68, 0, 6,
+ 3829, 0, 0, 157, 0, 178, 0, 1899, 0, 0,
+ -176, 0, 181, 0, 0, 183, 0, -176, 190, 112,
+ 209, 0, 231, 0, 0, 210, 277, 0, 0, 237,
+ 224, 1899, 0, 0, 0, 9, 0, 15, 0, 17,
+ 0, 105, 1899, 163, 1899, 81, 119, 1899, 0, 168,
+ 0, 175, 0, 185, 0, 0, 0, 1146, 112, 112,
+ 112, 0, 0, 1899, 112, 1899, 112, 1899, 279, 0,
+ 0, 0, 0, 143, 0, 3863, 202, 0, 300, 0,
+ 0, 0, 0, -161, -161, -234, 0, 321, -234, 326,
+ -161, 309, 112, 0, 0, 0, 0, 0, 0, 398,
+ 112, 0, 112, 0, 1724, -161, 0, -234, -161, 336,
+ 0, 0, 0, 112, 0,
};
short yyrindex[] = { 0,
- 0, 0, 269, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 220, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 2241, 1964, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 2857, 2901,
+ 0, 0, 0, 0, 0, 0, 0, 2159, 1989, 0,
+ 0, 2799, 2867, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 107, 0, 360, -1, 62, 3027,
- 3078, 0, 0, 2286, 2020, 0, 0, 0, 0, -12,
- 0, 0, 0, 0, 0, 0, 0, 2415, 0, 0,
- 1251, 0, 82, 173, 0, 0, 0, 0, 0, 0,
- 0, 157, 0, 1661, 0, 0, 178, 0, 2150, 0,
- 3927, 3027, 3958, 0, 0, 2415, 0, 2537, 454, 2581,
- 548, 0, 0, 0, 3989, 3384, 3425, 3461, 3122, 3163,
- 2636, 0, 3497, 3533, 0, 0, 0, 0, 0, 0,
- 0, 0, 2680, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 65, 0, -25, 193,
+ 2910, 2954, 0, 0, 2225, 2048, 0, 333, 0, 0,
+ 0, 2, 0, 0, 0, 0, 0, 0, 0, 2284,
+ 0, 0, 3575, 0, 257, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 3017, 0, 0, 348,
+ 0, 3642, 496, 557, 2395, 0, 0, 0, 2111, 0,
+ 3695, 2910, 0, 0, 2284, 0, 2520, 3065, 3103, 3190,
+ 659, 2997, 2563, 0, 3301, 3354, 0, 0, 0, 0,
+ 0, 0, 3741, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 163, 882,
- 0, 178, 0, 2415, 0, 2, 0, 107, 0, 107,
- 0, 175, 0, 175, 0, 165, 0, 0, 0, 0,
- 0, 180, 0, 0, 0, 0, 0, 0, 0, 2723,
- 0, 2985, 0, 0, 2785, 11, 14, 33, 59, 833,
- 0, 0, -30, 4020, 4036, 3817, 3850, 3275, 0, 1611,
- 4179, 4114, 4098, 3894, 3569, 3646, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 2631, 0, 0,
+ 0, 331, 880, 0, 348, 0, 2284, 0, 352, 65,
+ 0, 65, 0, 164, 0, 164, 0, 338, 0, 0,
+ 0, 0, 358, 0, 0, 2674, 0, 0, 0, 0,
+ 0, 0, 2718, 0, 0, -22, 36, 0, 91, 110,
+ -33, 0, 0, 2573, 1267, 1531, 3476, 3521, 3675, 0,
+ -27, 3826, 3794, 1587, -6, 3392, 3440, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 3787, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 134, 0, 0, 0, 0, 0, 0, 359, 0, 0,
+ 0, 0, 0, 0, 0, 0, 155, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 168, 0,
+ 0, 0, 0, 0, 0, 0, 0, 348, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 178, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 107, 107, 175,
- 0, 0, 175, 0, 107, 0, 0, 0, 0, 0,
- 0, 0, 2462, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 190, 0, 107, 0, 0,
- 0, 0, 0, 0, 175, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 349, 0, 0,
+ 0, 0, 0, 0, 0, 1953, 0, 0, 0, 0,
+ 0, 0, 0, 65, 65, 164, 0, 0, 164, 0,
+ 65, 0, 0, 0, 0, 0, 0, 0, 0, 880,
+ 0, 0, 0, 0, 368, 65, 0, 164, 65, 0,
+ 0, 0, 0, 0, 0,
};
short yygindex[] = { 0,
- 0, 0, 0, 148, -13, 106, 0, 0, 0, -91,
- -184, 452, -11, 4373, 886, 0, 0, 0, 0, 0,
- 234, -62, -173, 460, -20, 0, 0, 174, 0, -131,
- 0, 0, 0, 0,
+ 0, 0, 0, 136, -29, 0, 4145, 680, -78, 0,
+ 0, 0, -193, -13, 3266, 519, 0, 0, 0, 0,
+ 0, 400, 885, 0, 0, 267, -196, 63, 124, 250,
+ -16, -167, 20, 0, 0, 320, 356, 0, 0, 0,
+ 0, 0, 0,
};
-#define YYTABLESIZE 4657
-short yytable[] = { 65,
- 208, 68, 168, 79, 283, 20, 61, 213, 254, 268,
- 80, 23, 250, 80, 80, 255, 289, 206, 256, 95,
- 97, 99, 101, 170, 94, 181, 81, 80, 80, 110,
- 212, 96, 80, 115, 150, 261, 124, 157, 172, 13,
- 82, 263, 38, 98, 132, 100, 49, 90, 136, 267,
- 116, 16, 105, 209, 17, 169, 260, 13, 262, 106,
- 38, 239, 80, 272, 176, 168, 294, 61, 170, 16,
- 171, 102, 17, 14, 141, 306, 23, 307, 184, 148,
- 149, 188, 186, 190, 189, 192, 191, 194, 193, 308,
- 196, 14, 270, 237, 201, 309, 107, 150, 332, 15,
- 169, 173, 60, 273, 291, 60, 25, 23, 264, 265,
- 49, 143, 174, 316, 23, 323, 252, 15, 325, 60,
- 60, 257, 293, 175, 177, 314, 23, 214, 23, 23,
- 179, 182, 216, 217, 218, 219, 220, 221, 222, 25,
- 198, 205, 25, 25, 25, 78, 25, 149, 25, 25,
- 337, 25, 199, 18, 60, 21, 242, 243, 244, 245,
- 246, 247, 249, 207, 251, 25, 321, 322, 211, 259,
- 25, 258, 274, 327, 18, 269, 282, 280, 92, 93,
- 287, 288, 295, 296, 61, 302, 271, 312, 180, 326,
- 317, 290, 275, 277, 279, 318, 334, 25, 319, 281,
- 330, 331, 336, 19, 49, 168, 292, 18, 148, 149,
- 18, 18, 18, 37, 18, 35, 18, 18, 147, 18,
- 148, 145, 310, 13, 167, 285, 37, 286, 238, 25,
- 35, 25, 25, 18, 333, 148, 149, 150, 18, 148,
- 149, 80, 80, 80, 80, 298, 76, 299, 304, 300,
- 301, 148, 149, 303, 0, 151, 305, 186, 315, 152,
- 153, 154, 155, 80, 80, 18, 185, 80, 2, 0,
- 311, 23, 156, 158, 159, 160, 161, 329, 162, 163,
- 0, 0, 164, 148, 149, 165, 166, 167, 148, 149,
- 324, 0, 328, 0, 148, 149, 0, 18, 0, 18,
- 18, 39, 148, 149, 39, 39, 39, 0, 39, 0,
- 39, 39, 0, 39, 68, 0, 148, 149, 335, 148,
- 149, 0, 338, 144, 145, 146, 147, 39, 148, 149,
- 148, 149, 39, 60, 60, 60, 60, 0, 0, 148,
- 149, 0, 148, 149, 0, 148, 149, 0, 148, 149,
- 0, 148, 149, 148, 149, 60, 60, 148, 149, 39,
- 148, 149, 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, 0, 25, 25,
- 25, 39, 148, 149, 39, 25, 25, 25, 25, 25,
- 57, 154, 25, 25, 168, 84, 0, 148, 149, 25,
- 85, 0, 0, 25, 0, 25, 25, 0, 57, 163,
- 0, 0, 164, 148, 149, 165, 166, 167, 0, 0,
- 18, 18, 18, 18, 18, 18, 150, 18, 18, 18,
- 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
- 0, 0, 57, 18, 18, 0, 18, 18, 18, 148,
- 149, 0, 0, 18, 18, 18, 18, 18, 0, 0,
- 18, 18, 168, 0, 0, 0, 0, 18, 148, 149,
- 0, 18, 168, 18, 18, 89, 156, 0, 0, 156,
- 156, 156, 0, 156, 143, 156, 156, 143, 156, 118,
- 120, 108, 0, 0, 150, 0, 117, 0, 123, 0,
- 0, 143, 143, 0, 150, 253, 143, 156, 0, 0,
- 137, 138, 139, 140, 39, 39, 39, 39, 39, 39,
- 0, 39, 39, 39, 0, 0, 0, 39, 0, 120,
- 39, 39, 39, 39, 143, 0, 143, 39, 39, 0,
- 39, 39, 39, 157, 0, 0, 0, 39, 39, 39,
- 39, 39, 168, 0, 39, 39, 204, 120, 4, 5,
- 6, 39, 7, 8, 210, 39, 143, 39, 39, 156,
- 157, 168, 0, 157, 157, 157, 0, 157, 102, 157,
- 157, 102, 157, 0, 150, 0, 0, 0, 152, 153,
- 154, 155, 0, 0, 0, 102, 102, 0, 0, 0,
- 102, 157, 0, 150, 160, 161, 0, 162, 163, 0,
- 0, 164, 0, 0, 165, 166, 167, 0, 0, 0,
- 120, 57, 57, 57, 57, 120, 0, 0, 0, 51,
- 102, 0, 61, 63, 47, 0, 56, 0, 64, 59,
- 0, 58, 0, 57, 57, 0, 4, 5, 6, 0,
- 7, 8, 0, 0, 0, 57, 152, 153, 154, 155,
- 62, 0, 0, 157, 0, 0, 152, 153, 154, 155,
- 158, 159, 160, 161, 0, 162, 163, 0, 0, 164,
- 0, 0, 165, 166, 167, 162, 163, 60, 0, 164,
- 0, 0, 165, 166, 167, 0, 0, 0, 0, 0,
- 156, 156, 156, 156, 156, 0, 156, 156, 156, 0,
- 0, 0, 156, 0, 0, 143, 143, 143, 143, 23,
- 0, 0, 52, 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, 168, 0, 0,
- 0, 151, 0, 0, 0, 152, 153, 154, 155, 164,
- 0, 0, 165, 166, 167, 0, 0, 0, 156, 158,
- 159, 160, 161, 0, 162, 163, 0, 0, 164, 150,
- 0, 165, 166, 167, 157, 157, 157, 157, 157, 0,
- 157, 157, 157, 0, 0, 0, 157, 0, 0, 102,
- 102, 102, 102, 0, 0, 0, 0, 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, 168, 22, 24, 25, 26, 27, 28, 0, 29,
- 30, 31, 0, 56, 0, 32, 56, 0, 33, 34,
- 35, 36, 0, 0, 0, 37, 38, 0, 39, 40,
- 41, 56, 0, 150, 0, 42, 43, 44, 45, 46,
- 0, 0, 48, 49, 0, 0, 0, 0, 0, 50,
- 87, 87, 0, 53, 39, 54, 55, 39, 39, 39,
- 0, 39, 103, 39, 39, 56, 39, 87, 112, 0,
- 0, 0, 87, 0, 121, 144, 145, 146, 147, 0,
- 39, 0, 0, 0, 0, 39, 87, 87, 87, 87,
- 0, 0, 0, 0, 0, 0, 0, 148, 149, 0,
- 0, 0, 0, 154, 155, 0, 0, 0, 0, 0,
- 51, 0, 39, 61, 63, 47, 0, 56, 0, 64,
- 59, 163, 58, 0, 164, 0, 0, 165, 166, 167,
- 0, 0, 121, 0, 0, 0, 0, 0, 0, 0,
- 0, 62, 0, 0, 39, 0, 0, 39, 0, 0,
- 0, 0, 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, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 240, 0, 0, 0, 0, 62, 0, 0,
- 23, 0, 0, 52, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 163, 0, 0, 164, 0,
- 0, 165, 166, 167, 60, 0, 0, 0, 0, 51,
- 0, 0, 61, 63, 47, 0, 56, 0, 64, 59,
- 0, 58, 0, 0, 56, 56, 56, 56, 0, 0,
- 0, 0, 0, 0, 0, 114, 23, 0, 0, 52,
- 62, 0, 0, 0, 0, 0, 56, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 39, 39, 39,
- 39, 39, 39, 0, 39, 39, 39, 60, 0, 0,
- 39, 0, 0, 39, 39, 39, 39, 0, 0, 0,
- 39, 39, 0, 39, 39, 39, 0, 0, 0, 0,
- 39, 39, 39, 39, 39, 0, 0, 39, 39, 0,
- 168, 157, 52, 0, 39, 0, 0, 0, 39, 0,
- 39, 39, 0, 0, 119, 25, 26, 27, 28, 85,
- 29, 30, 31, 0, 0, 0, 32, 0, 0, 168,
- 320, 0, 150, 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, 0, 0,
- 50, 150, 0, 0, 53, 0, 54, 55, 0, 0,
- 109, 25, 26, 27, 28, 0, 29, 30, 31, 0,
- 168, 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, 135, 150, 0, 135, 0, 50, 0, 0, 0,
- 53, 0, 54, 55, 0, 0, 0, 0, 135, 135,
- 0, 0, 0, 24, 25, 26, 27, 28, 168, 29,
- 30, 31, 0, 51, 0, 32, 61, 63, 47, 0,
- 56, 0, 64, 59, 0, 58, 38, 0, 39, 40,
- 41, 0, 0, 135, 0, 42, 43, 44, 45, 46,
- 150, 0, 48, 49, 62, 0, 0, 0, 0, 50,
- 0, 0, 0, 53, 0, 54, 55, 0, 0, 0,
- 0, 0, 0, 0, 152, 0, 154, 155, 0, 51,
- 0, 60, 61, 63, 47, 0, 56, 131, 64, 59,
- 0, 58, 0, 162, 163, 0, 0, 164, 0, 151,
- 165, 166, 167, 152, 153, 154, 155, 0, 0, 0,
- 62, 0, 0, 23, 0, 0, 52, 158, 159, 160,
- 161, 0, 162, 163, 0, 0, 164, 0, 0, 165,
- 166, 167, 0, 0, 0, 51, 0, 60, 61, 63,
- 47, 0, 56, 0, 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, 0, 0, 0, 0, 0,
- 0, 0, 0, 60, 0, 135, 0, 0, 51, 0,
- 0, 61, 63, 47, 0, 56, 0, 64, 59, 0,
- 58, 0, 0, 0, 154, 155, 0, 0, 0, 0,
- 0, 0, 135, 135, 135, 135, 0, 0, 52, 62,
- 0, 162, 163, 0, 0, 164, 0, 0, 165, 166,
- 167, 0, 0, 0, 135, 135, 0, 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, 0, 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, 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, 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, 130, 0, 82, 130, 50, 0, 0, 0, 53,
- 0, 54, 55, 0, 0, 0, 0, 0, 130, 130,
- 0, 22, 24, 25, 26, 27, 28, 0, 29, 30,
- 31, 0, 51, 0, 32, 61, 63, 47, 0, 56,
- 200, 64, 59, 0, 58, 38, 0, 39, 40, 41,
- 0, 0, 0, 130, 42, 43, 44, 45, 46, 0,
- 0, 48, 49, 62, 0, 0, 0, 0, 50, 0,
- 0, 0, 53, 0, 54, 55, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 51, 0,
- 60, 61, 63, 47, 0, 56, 248, 64, 59, 0,
- 58, 0, 0, 0, 0, 0, 0, 152, 153, 154,
- 155, 0, 0, 0, 0, 0, 0, 0, 0, 62,
- 0, 0, 159, 160, 161, 52, 162, 163, 0, 0,
- 164, 0, 0, 165, 166, 167, 0, 0, 152, 153,
- 154, 155, 0, 0, 51, 0, 60, 61, 63, 47,
- 0, 56, 276, 64, 59, 161, 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, 278, 64, 59, 0, 58,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 130, 130, 130, 130, 0, 52, 62, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 130, 130, 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, 136, 0, 53, 136, 54, 55,
- 0, 0, 24, 25, 26, 27, 28, 0, 29, 30,
- 31, 136, 136, 0, 32, 0, 136, 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, 136, 0, 136, 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, 136, 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, 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, 119, 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, 0, 0,
- 48, 49, 62, 0, 0, 0, 0, 50, 0, 0,
- 0, 53, 0, 54, 55, 0, 0, 0, 0, 0,
- 143, 0, 0, 143, 0, 0, 0, 0, 0, 60,
- 0, 0, 0, 0, 0, 0, 0, 143, 143, 0,
- 0, 0, 143, 0, 0, 0, 0, 0, 0, 0,
+#define YYTABLESIZE 4333
+short yytable[] = { 69,
+ 62, 280, 274, 62, 105, 214, 183, 64, 170, 20,
+ 64, 62, 299, 90, 23, 15, 90, 256, 18, 213,
+ 208, 172, 96, 82, 301, 64, 84, 98, 100, 102,
+ 90, 90, 124, 15, 83, 90, 18, 83, 303, 125,
+ 152, 270, 271, 134, 283, 91, 305, 138, 174, 320,
+ 252, 83, 83, 171, 284, 321, 83, 322, 240, 64,
+ 57, 83, 117, 118, 27, 90, 189, 92, 191, 126,
+ 193, 172, 195, 184, 197, 198, 42, 210, 108, 294,
+ 173, 139, 140, 141, 142, 319, 83, 4, 5, 6,
+ 238, 7, 8, 109, 42, 202, 203, 27, 23, 110,
+ 27, 27, 27, 171, 27, 23, 27, 27, 211, 27,
+ 23, 23, 23, 300, 23, 302, 144, 338, 175, 340,
+ 150, 151, 257, 27, 57, 258, 304, 176, 27, 205,
+ 329, 16, 216, 217, 219, 220, 221, 222, 223, 327,
+ 178, 18, 349, 21, 159, 352, 23, 177, 80, 16,
+ 17, 182, 180, 185, 199, 27, 243, 244, 245, 246,
+ 247, 248, 250, 20, 362, 254, 94, 95, 17, 282,
+ 259, 203, 170, 200, 41, 261, 207, 217, 285, 62,
+ 209, 217, 170, 212, 277, 291, 293, 27, 170, 27,
+ 27, 286, 41, 288, 290, 43, 20, 323, 292, 20,
+ 20, 20, 151, 20, 152, 20, 20, 19, 20, 150,
+ 151, 328, 298, 15, 152, 306, 150, 151, 307, 2,
+ 152, 309, 20, 310, 296, 239, 297, 20, 150, 151,
+ 311, 169, 86, 68, 312, 344, 68, 87, 64, 64,
+ 64, 64, 150, 151, 90, 90, 90, 90, 314, 316,
+ 68, 68, 47, 90, 20, 47, 47, 47, 350, 47,
+ 104, 47, 47, 64, 47, 83, 83, 83, 83, 90,
+ 90, 315, 90, 90, 83, 150, 151, 317, 47, 324,
+ 83, 83, 318, 47, 203, 68, 20, 325, 20, 20,
+ 83, 83, 330, 83, 83, 83, 83, 83, 83, 331,
+ 150, 151, 150, 151, 261, 150, 151, 150, 151, 332,
+ 47, 150, 151, 150, 151, 150, 151, 150, 151, 343,
+ 27, 27, 27, 27, 27, 27, 345, 27, 27, 27,
+ 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+ 346, 69, 47, 27, 27, 47, 27, 27, 27, 27,
+ 27, 150, 151, 150, 151, 27, 27, 27, 27, 27,
+ 27, 351, 153, 27, 150, 151, 353, 355, 154, 155,
+ 156, 157, 27, 65, 27, 27, 364, 150, 151, 57,
+ 156, 158, 160, 161, 162, 163, 164, 165, 155, 153,
+ 166, 65, 40, 167, 168, 169, 38, 165, 156, 43,
+ 166, 150, 151, 167, 168, 169, 166, 40, 38, 167,
+ 168, 169, 77, 218, 188, 150, 151, 360, 170, 20,
+ 20, 20, 20, 20, 20, 65, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 150,
+ 151, 342, 20, 20, 273, 20, 20, 20, 20, 20,
+ 152, 0, 0, 0, 20, 20, 20, 20, 20, 20,
+ 0, 0, 20, 170, 68, 68, 68, 68, 0, 0,
+ 0, 20, 0, 20, 20, 47, 47, 47, 47, 47,
+ 47, 255, 47, 47, 47, 0, 0, 0, 47, 68,
+ 68, 47, 47, 47, 47, 152, 0, 0, 47, 47,
+ 0, 47, 47, 47, 47, 47, 0, 0, 0, 170,
+ 47, 47, 47, 47, 47, 47, 0, 0, 47, 0,
+ 0, 0, 357, 0, 170, 0, 0, 47, 167, 47,
+ 47, 167, 167, 167, 0, 167, 151, 167, 167, 151,
+ 167, 152, 0, 89, 89, 264, 0, 267, 146, 147,
+ 148, 149, 0, 151, 151, 106, 152, 0, 151, 167,
+ 0, 114, 89, 122, 0, 0, 0, 0, 89, 0,
+ 0, 0, 0, 150, 151, 0, 0, 0, 0, 0,
+ 89, 89, 89, 89, 0, 0, 151, 0, 151, 168,
+ 0, 0, 168, 168, 168, 0, 168, 110, 168, 168,
+ 110, 168, 0, 0, 65, 65, 65, 65, 0, 0,
+ 0, 0, 0, 0, 110, 110, 156, 157, 151, 110,
+ 168, 167, 4, 5, 6, 0, 7, 8, 114, 65,
+ 65, 0, 164, 165, 0, 0, 166, 0, 0, 167,
+ 168, 169, 0, 0, 0, 0, 0, 0, 52, 110,
+ 0, 62, 64, 50, 0, 57, 0, 65, 60, 154,
+ 59, 156, 157, 4, 5, 6, 0, 7, 8, 0,
+ 0, 0, 0, 0, 58, 0, 0, 164, 165, 63,
+ 0, 166, 168, 0, 167, 168, 169, 241, 0, 347,
+ 348, 0, 0, 0, 0, 0, 354, 0, 0, 100,
+ 0, 0, 100, 0, 0, 0, 61, 156, 157, 0,
+ 0, 361, 0, 0, 363, 275, 100, 100, 0, 0,
+ 0, 100, 0, 0, 165, 0, 0, 166, 0, 0,
+ 167, 168, 169, 0, 0, 0, 0, 0, 23, 165,
+ 0, 53, 166, 0, 0, 167, 168, 169, 0, 0,
+ 0, 100, 167, 167, 167, 167, 167, 0, 167, 167,
+ 167, 0, 0, 0, 167, 0, 0, 151, 151, 151,
+ 151, 0, 0, 0, 0, 167, 151, 167, 167, 167,
+ 167, 167, 151, 151, 151, 151, 167, 167, 167, 167,
+ 167, 167, 151, 151, 167, 151, 151, 151, 151, 151,
+ 151, 151, 0, 167, 151, 167, 167, 151, 151, 151,
+ 0, 0, 0, 168, 168, 168, 168, 168, 0, 168,
+ 168, 168, 0, 0, 0, 168, 0, 0, 110, 110,
+ 110, 110, 0, 0, 0, 0, 168, 110, 168, 168,
+ 168, 168, 168, 110, 110, 110, 110, 168, 168, 168,
+ 168, 168, 168, 110, 110, 168, 110, 110, 110, 110,
+ 110, 110, 110, 0, 168, 110, 168, 168, 110, 110,
+ 110, 22, 24, 25, 26, 27, 28, 0, 29, 30,
+ 31, 0, 0, 0, 32, 0, 0, 33, 34, 35,
+ 36, 0, 0, 0, 37, 38, 0, 39, 40, 41,
+ 42, 43, 0, 0, 0, 170, 44, 45, 46, 47,
+ 48, 49, 47, 0, 51, 47, 47, 47, 0, 47,
+ 0, 47, 47, 54, 47, 55, 56, 115, 0, 0,
+ 100, 100, 100, 100, 0, 127, 0, 152, 47, 100,
+ 0, 0, 0, 47, 0, 100, 100, 100, 100, 0,
+ 0, 0, 0, 0, 0, 100, 100, 0, 100, 100,
+ 100, 100, 100, 100, 100, 0, 0, 100, 52, 0,
+ 47, 62, 64, 50, 115, 57, 0, 65, 60, 0,
+ 59, 0, 0, 0, 0, 0, 0, 0, 334, 335,
+ 336, 0, 0, 0, 339, 0, 341, 0, 0, 63,
+ 0, 206, 47, 0, 0, 47, 0, 0, 0, 115,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 52, 136, 136, 136, 136, 0,
- 143, 0, 143, 0, 136, 0, 0, 0, 136, 136,
- 136, 136, 0, 0, 0, 0, 0, 136, 136, 0,
- 0, 136, 136, 136, 136, 136, 0, 136, 136, 0,
- 0, 136, 143, 0, 136, 136, 136, 0, 0, 0,
- 0, 129, 0, 0, 129, 0, 0, 0, 0, 0,
- 0, 119, 119, 119, 119, 0, 0, 0, 129, 129,
- 119, 0, 0, 129, 119, 119, 119, 119, 0, 0,
- 0, 0, 0, 119, 119, 0, 0, 119, 119, 119,
- 119, 119, 0, 119, 119, 0, 104, 119, 0, 104,
- 119, 119, 119, 129, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 104, 104, 0, 0, 0, 104, 0,
+ 0, 0, 356, 0, 52, 0, 61, 62, 64, 50,
+ 358, 57, 359, 65, 60, 0, 59, 0, 0, 0,
+ 0, 0, 0, 365, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 63, 0, 0, 23, 0,
+ 0, 53, 0, 0, 0, 0, 115, 0, 0, 0,
+ 0, 115, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 61, 0, 0, 0, 0, 52, 0, 0,
+ 62, 64, 50, 0, 57, 0, 65, 60, 0, 59,
+ 0, 154, 155, 156, 157, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 23, 0, 0, 53, 63, 164,
+ 165, 0, 0, 166, 0, 0, 167, 168, 169, 0,
+ 0, 0, 0, 0, 0, 47, 47, 47, 47, 47,
+ 47, 0, 47, 47, 47, 61, 0, 0, 47, 0,
+ 0, 47, 47, 47, 47, 0, 0, 0, 47, 47,
+ 0, 47, 47, 47, 47, 47, 0, 0, 0, 0,
+ 47, 47, 47, 47, 47, 47, 0, 23, 47, 0,
+ 53, 0, 170, 0, 0, 0, 333, 47, 0, 47,
+ 47, 0, 113, 25, 26, 27, 28, 87, 29, 30,
+ 31, 0, 0, 0, 32, 0, 0, 0, 159, 0,
+ 0, 0, 0, 0, 152, 38, 0, 39, 40, 41,
+ 42, 43, 0, 0, 0, 0, 44, 45, 46, 47,
+ 48, 49, 0, 0, 51, 0, 170, 0, 0, 0,
+ 0, 0, 0, 54, 0, 55, 56, 0, 24, 25,
+ 26, 27, 28, 0, 29, 30, 31, 0, 0, 0,
+ 32, 295, 0, 0, 0, 0, 159, 0, 152, 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, 170, 0, 0, 0, 0, 54,
+ 0, 55, 56, 0, 0, 0, 0, 84, 0, 0,
+ 84, 119, 25, 26, 27, 28, 0, 29, 30, 31,
+ 0, 0, 0, 32, 84, 84, 152, 0, 0, 84,
+ 0, 0, 0, 0, 38, 0, 39, 40, 41, 42,
+ 43, 0, 0, 0, 0, 44, 45, 46, 47, 48,
+ 49, 52, 0, 51, 62, 64, 50, 0, 57, 84,
+ 65, 60, 54, 59, 55, 56, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 123, 154, 155,
+ 156, 157, 63, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 160, 161, 162, 163, 164, 165, 0, 0,
+ 166, 0, 0, 167, 168, 169, 0, 52, 0, 61,
+ 62, 64, 50, 0, 57, 133, 65, 60, 0, 59,
+ 0, 0, 0, 0, 0, 0, 153, 0, 0, 0,
+ 0, 0, 154, 155, 156, 157, 0, 0, 63, 0,
+ 0, 0, 0, 0, 53, 158, 160, 161, 162, 163,
+ 164, 165, 0, 0, 166, 0, 0, 167, 168, 169,
+ 0, 0, 0, 52, 0, 61, 62, 64, 50, 0,
+ 57, 0, 65, 60, 0, 59, 0, 0, 0, 0,
+ 0, 0, 0, 0, 153, 0, 0, 0, 0, 0,
+ 154, 155, 156, 157, 63, 0, 0, 0, 0, 0,
+ 53, 0, 0, 158, 160, 161, 162, 163, 164, 165,
+ 0, 0, 166, 0, 0, 167, 168, 169, 0, 0,
+ 0, 61, 52, 137, 0, 62, 64, 50, 0, 57,
+ 201, 65, 60, 0, 59, 0, 0, 0, 84, 84,
+ 84, 84, 0, 0, 0, 0, 0, 84, 0, 0,
+ 0, 0, 0, 63, 84, 0, 53, 0, 0, 0,
+ 0, 0, 0, 84, 84, 0, 84, 84, 84, 84,
+ 84, 85, 0, 0, 85, 24, 25, 26, 27, 28,
+ 61, 29, 30, 31, 0, 0, 0, 32, 85, 85,
+ 0, 0, 0, 85, 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, 85, 0, 0, 54, 86, 55, 56,
+ 86, 24, 25, 26, 27, 28, 0, 29, 30, 31,
+ 0, 0, 0, 32, 86, 86, 0, 0, 0, 86,
+ 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, 86,
+ 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, 249, 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, 85, 85, 85, 85, 0, 0, 0, 0,
+ 0, 85, 52, 0, 61, 62, 64, 50, 0, 57,
+ 287, 65, 60, 0, 59, 0, 0, 85, 85, 0,
+ 85, 85, 85, 85, 85, 0, 0, 0, 0, 0,
+ 0, 0, 0, 63, 0, 0, 0, 0, 0, 53,
+ 0, 0, 0, 0, 0, 0, 0, 0, 86, 86,
+ 86, 86, 0, 0, 0, 0, 0, 86, 52, 0,
+ 61, 62, 64, 50, 0, 57, 289, 65, 60, 0,
+ 59, 0, 0, 86, 86, 0, 86, 86, 86, 86,
+ 86, 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, 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, 0, 0, 53, 0, 54, 55, 0,
- 0, 143, 143, 143, 143, 0, 0, 0, 0, 0,
- 143, 0, 0, 0, 143, 143, 143, 143, 0, 0,
- 0, 0, 0, 143, 143, 0, 0, 143, 143, 143,
- 143, 143, 0, 143, 143, 145, 0, 143, 145, 0,
- 143, 143, 143, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 145, 145, 0, 0, 0, 145, 0, 0,
+ 0, 24, 25, 26, 27, 28, 61, 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, 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, 91, 0, 0, 91, 0, 0, 0,
+ 0, 0, 0, 38, 0, 39, 40, 41, 42, 43,
+ 91, 91, 0, 0, 44, 45, 46, 47, 48, 49,
+ 0, 0, 51, 0, 53, 0, 0, 0, 0, 144,
+ 0, 54, 144, 55, 56, 0, 24, 25, 26, 27,
+ 28, 0, 29, 30, 31, 91, 144, 144, 32, 0,
+ 0, 144, 0, 0, 0, 0, 0, 0, 0, 38,
+ 0, 39, 40, 41, 42, 43, 0, 0, 0, 0,
+ 44, 45, 46, 47, 48, 49, 0, 0, 51, 144,
+ 0, 144, 0, 0, 0, 0, 0, 54, 127, 55,
+ 56, 127, 24, 25, 26, 27, 28, 0, 29, 30,
+ 31, 0, 0, 0, 32, 127, 127, 0, 0, 0,
+ 127, 144, 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, 127, 0,
+ 127, 0, 0, 54, 0, 55, 56, 0, 0, 0,
+ 0, 151, 0, 0, 151, 24, 25, 26, 27, 28,
+ 0, 29, 30, 31, 0, 0, 0, 32, 151, 151,
+ 127, 0, 0, 151, 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, 137,
+ 0, 151, 137, 151, 0, 0, 54, 0, 55, 56,
+ 0, 0, 0, 0, 0, 0, 137, 137, 0, 0,
+ 0, 137, 0, 0, 91, 91, 91, 91, 0, 0,
+ 0, 0, 0, 151, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 91,
+ 91, 137, 91, 0, 0, 0, 0, 0, 0, 0,
+ 144, 144, 144, 144, 0, 112, 0, 0, 112, 144,
+ 0, 0, 0, 0, 0, 144, 144, 144, 144, 0,
+ 0, 137, 112, 112, 0, 144, 144, 112, 144, 144,
+ 144, 144, 144, 144, 144, 0, 0, 144, 0, 0,
+ 144, 144, 144, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 112, 0, 112, 0, 127,
+ 127, 127, 127, 0, 153, 0, 0, 153, 127, 0,
+ 0, 0, 0, 0, 127, 127, 127, 127, 0, 0,
+ 0, 153, 153, 0, 127, 127, 153, 127, 127, 127,
+ 127, 127, 127, 127, 0, 0, 127, 0, 0, 127,
+ 127, 127, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 153, 0, 0, 0,
+ 0, 0, 151, 151, 151, 151, 0, 0, 0, 0,
+ 0, 151, 0, 0, 0, 0, 0, 151, 151, 151,
+ 151, 0, 0, 0, 0, 0, 153, 151, 151, 0,
+ 151, 151, 151, 151, 151, 151, 151, 0, 0, 151,
+ 0, 0, 151, 151, 151, 0, 0, 0, 0, 0,
+ 137, 137, 137, 137, 0, 154, 0, 0, 0, 137,
+ 0, 0, 0, 0, 0, 137, 137, 137, 137, 0,
+ 0, 0, 154, 154, 0, 137, 137, 154, 137, 137,
+ 137, 137, 137, 137, 137, 0, 0, 137, 0, 0,
+ 137, 137, 137, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 154, 0, 154, 0, 0,
+ 0, 0, 0, 0, 0, 0, 112, 112, 112, 112,
+ 0, 0, 0, 0, 0, 112, 0, 0, 0, 0,
+ 0, 112, 112, 112, 112, 0, 0, 154, 0, 0,
+ 170, 112, 112, 0, 112, 112, 112, 112, 112, 112,
+ 112, 0, 0, 112, 0, 0, 112, 112, 112, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 152, 0, 0, 153, 153, 153, 153, 0,
+ 139, 0, 0, 0, 153, 0, 0, 0, 0, 0,
+ 153, 153, 153, 153, 0, 0, 0, 139, 139, 0,
+ 153, 153, 139, 153, 153, 153, 153, 153, 153, 153,
+ 0, 0, 153, 0, 0, 153, 153, 153, 0, 0,
+ 0, 0, 0, 104, 0, 0, 104, 0, 0, 0,
+ 139, 0, 139, 88, 0, 0, 88, 0, 0, 0,
+ 104, 104, 0, 0, 0, 104, 0, 0, 0, 0,
+ 88, 88, 0, 0, 0, 88, 0, 0, 0, 0,
+ 0, 0, 139, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 104, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 88, 154, 154, 154, 154,
+ 0, 66, 0, 0, 66, 154, 0, 0, 0, 0,
+ 0, 154, 154, 154, 154, 104, 0, 0, 66, 66,
+ 0, 154, 154, 66, 154, 154, 154, 154, 154, 154,
+ 154, 0, 0, 154, 0, 0, 154, 154, 154, 0,
+ 0, 0, 0, 0, 69, 0, 154, 155, 156, 157,
+ 0, 0, 0, 66, 0, 0, 0, 0, 0, 0,
+ 0, 69, 69, 163, 164, 165, 69, 0, 166, 0,
+ 0, 167, 168, 169, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 66, 0, 0, 0, 0, 103, 0,
+ 0, 103, 0, 0, 69, 0, 69, 0, 0, 0,
+ 0, 0, 0, 0, 0, 103, 103, 0, 0, 0,
+ 103, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 139, 139, 139, 139, 0, 69, 0, 0, 0,
+ 139, 0, 0, 0, 0, 0, 139, 139, 139, 139,
+ 103, 0, 0, 0, 0, 0, 139, 139, 0, 139,
+ 139, 139, 139, 139, 139, 139, 0, 0, 139, 0,
+ 0, 139, 139, 139, 104, 104, 104, 104, 0, 140,
+ 103, 0, 140, 104, 88, 88, 88, 88, 0, 104,
+ 104, 104, 104, 0, 0, 0, 140, 140, 0, 104,
+ 104, 140, 104, 104, 104, 104, 104, 104, 104, 88,
+ 88, 104, 88, 0, 104, 104, 104, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 83, 0, 0, 83, 0, 145, 0, 0,
- 0, 0, 129, 129, 129, 129, 0, 0, 0, 83,
- 83, 129, 0, 0, 0, 129, 129, 129, 129, 0,
- 0, 0, 0, 0, 129, 129, 0, 145, 129, 129,
- 129, 129, 129, 0, 129, 129, 0, 0, 129, 0,
- 0, 129, 129, 129, 83, 0, 0, 104, 104, 104,
- 104, 0, 0, 0, 0, 0, 104, 0, 0, 0,
- 104, 104, 104, 104, 0, 0, 0, 131, 0, 104,
- 104, 0, 0, 104, 104, 104, 104, 104, 0, 104,
- 104, 0, 0, 104, 131, 131, 104, 104, 104, 131,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 146, 0, 0, 0, 0, 0, 131, 0, 131,
- 0, 0, 0, 0, 0, 0, 0, 0, 146, 146,
- 0, 0, 0, 146, 0, 0, 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, 146, 0, 146, 0, 0, 96, 0, 0, 96,
- 0, 0, 0, 0, 0, 0, 145, 145, 145, 145,
- 0, 0, 0, 96, 96, 145, 0, 0, 96, 145,
- 145, 145, 145, 146, 0, 0, 0, 0, 145, 145,
- 0, 0, 145, 145, 145, 145, 145, 0, 145, 145,
- 58, 0, 145, 58, 0, 145, 145, 145, 96, 0,
- 0, 0, 0, 83, 83, 83, 83, 58, 58, 0,
- 0, 0, 58, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 83, 83, 0, 96, 83,
- 0, 0, 0, 61, 0, 0, 0, 0, 0, 0,
- 0, 0, 58, 0, 0, 0, 0, 0, 0, 0,
- 61, 61, 0, 0, 0, 61, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 58, 0, 0, 0, 0, 0, 131, 131,
- 131, 131, 0, 61, 0, 61, 0, 131, 0, 0,
- 0, 131, 131, 131, 131, 59, 0, 0, 59, 0,
- 131, 131, 0, 0, 131, 131, 131, 131, 131, 0,
- 131, 131, 59, 59, 131, 61, 0, 131, 131, 131,
- 0, 0, 146, 146, 146, 146, 0, 0, 0, 0,
- 0, 146, 0, 0, 0, 146, 146, 146, 146, 0,
- 0, 0, 0, 0, 146, 146, 0, 59, 146, 146,
- 146, 146, 146, 0, 146, 146, 0, 0, 146, 0,
- 0, 146, 146, 146, 0, 0, 0, 145, 0, 0,
- 145, 0, 0, 0, 0, 0, 0, 96, 96, 96,
- 96, 0, 0, 0, 145, 145, 96, 0, 0, 145,
- 96, 96, 96, 96, 0, 0, 0, 0, 0, 96,
- 96, 0, 0, 96, 96, 96, 96, 96, 0, 96,
- 96, 132, 0, 96, 132, 0, 96, 96, 96, 145,
- 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, 61, 61, 61, 61, 0, 284,
- 0, 0, 0, 61, 157, 0, 0, 61, 61, 61,
- 61, 0, 0, 0, 0, 0, 61, 61, 0, 0,
- 61, 61, 61, 61, 61, 95, 61, 61, 95, 0,
- 61, 0, 168, 61, 61, 61, 0, 0, 0, 0,
+ 0, 140, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 66, 66, 66, 66, 0, 153, 0, 0,
+ 153, 66, 0, 0, 0, 0, 0, 66, 66, 66,
+ 66, 0, 0, 0, 153, 153, 0, 66, 66, 153,
+ 66, 66, 66, 66, 66, 66, 66, 0, 0, 66,
+ 0, 0, 66, 66, 66, 69, 69, 69, 69, 0,
+ 110, 0, 0, 110, 69, 0, 0, 0, 0, 153,
+ 69, 69, 69, 69, 0, 0, 0, 110, 110, 0,
+ 69, 69, 110, 69, 69, 69, 69, 69, 69, 69,
+ 0, 0, 69, 0, 0, 69, 69, 69, 0, 103,
+ 103, 103, 103, 0, 117, 0, 0, 117, 103, 0,
+ 0, 0, 110, 0, 103, 103, 103, 103, 0, 0,
+ 0, 117, 117, 0, 103, 103, 117, 103, 103, 103,
+ 103, 103, 103, 103, 0, 0, 103, 0, 0, 103,
+ 103, 103, 0, 0, 0, 0, 0, 101, 0, 0,
+ 101, 0, 0, 0, 0, 0, 117, 0, 0, 0,
+ 0, 0, 0, 0, 101, 101, 0, 138, 0, 101,
+ 138, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 140, 140, 140, 140, 138, 138, 0, 0, 0, 140,
+ 0, 0, 0, 0, 0, 140, 140, 140, 140, 101,
+ 0, 0, 0, 0, 0, 140, 140, 0, 140, 140,
+ 140, 140, 140, 140, 140, 95, 0, 140, 95, 138,
+ 140, 140, 140, 0, 0, 0, 0, 0, 0, 0,
0, 0, 95, 95, 0, 0, 0, 95, 0, 0,
- 0, 0, 0, 0, 0, 0, 59, 59, 59, 59,
- 0, 0, 0, 0, 150, 0, 0, 102, 0, 0,
- 102, 0, 0, 0, 0, 0, 0, 95, 59, 59,
- 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, 95, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 109, 102,
- 0, 109, 0, 0, 0, 0, 0, 0, 145, 145,
- 145, 145, 0, 0, 0, 109, 109, 145, 0, 0,
- 109, 145, 145, 145, 145, 0, 0, 0, 0, 0,
- 145, 145, 0, 0, 145, 145, 145, 145, 145, 0,
- 145, 145, 92, 0, 145, 92, 0, 145, 145, 145,
- 109, 0, 132, 132, 132, 132, 0, 0, 0, 92,
- 92, 132, 0, 0, 92, 132, 132, 132, 132, 0,
- 0, 0, 0, 0, 132, 132, 0, 0, 132, 132,
- 132, 132, 132, 93, 132, 132, 93, 0, 132, 0,
- 0, 132, 132, 132, 92, 0, 0, 0, 0, 0,
- 93, 93, 151, 0, 0, 93, 152, 153, 154, 155,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 156,
- 158, 159, 160, 161, 0, 162, 163, 0, 0, 164,
- 0, 0, 165, 166, 167, 93, 95, 95, 95, 95,
- 0, 0, 0, 0, 0, 95, 0, 0, 0, 95,
- 95, 95, 95, 0, 0, 0, 0, 0, 95, 95,
- 0, 0, 95, 95, 95, 95, 95, 0, 95, 95,
- 0, 0, 95, 0, 0, 95, 95, 95, 102, 102,
- 102, 102, 0, 0, 0, 0, 0, 102, 0, 0,
- 0, 102, 102, 102, 102, 71, 0, 0, 71, 0,
- 102, 102, 0, 0, 102, 102, 102, 102, 102, 0,
- 102, 102, 71, 71, 102, 0, 0, 102, 102, 102,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 109,
- 109, 109, 109, 0, 0, 0, 0, 0, 109, 0,
- 0, 0, 109, 109, 109, 109, 0, 71, 0, 0,
- 0, 109, 109, 0, 0, 109, 109, 109, 109, 109,
- 0, 109, 109, 0, 0, 109, 0, 0, 109, 109,
- 109, 0, 0, 92, 92, 92, 92, 0, 0, 0,
- 0, 0, 92, 0, 0, 0, 92, 92, 92, 92,
- 0, 0, 0, 0, 0, 92, 92, 0, 0, 92,
- 92, 92, 92, 92, 87, 92, 92, 87, 0, 92,
- 0, 0, 0, 0, 93, 93, 93, 93, 0, 0,
- 0, 87, 87, 93, 0, 0, 87, 93, 93, 93,
- 93, 0, 0, 0, 0, 0, 93, 93, 0, 0,
- 93, 93, 93, 93, 93, 88, 93, 93, 88, 0,
- 93, 0, 0, 0, 0, 0, 87, 0, 0, 0,
- 0, 0, 88, 88, 0, 0, 0, 88, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 89, 0, 0, 89, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 88, 89, 89,
- 0, 0, 0, 89, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 85, 0, 0,
- 85, 0, 0, 0, 0, 0, 71, 71, 71, 71,
- 0, 0, 0, 89, 85, 85, 0, 0, 0, 85,
- 0, 0, 0, 0, 0, 0, 0, 0, 71, 71,
- 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, 84,
- 0, 0, 84, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 86, 84, 84, 0, 0,
- 0, 84, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 87, 87, 87, 87, 0,
- 0, 84, 0, 0, 87, 0, 0, 0, 87, 87,
- 87, 87, 0, 0, 0, 0, 0, 87, 87, 0,
- 0, 87, 87, 87, 87, 87, 72, 87, 87, 72,
- 0, 0, 0, 0, 0, 0, 88, 88, 88, 88,
- 0, 0, 0, 72, 72, 88, 0, 0, 72, 88,
- 88, 88, 88, 0, 0, 0, 0, 0, 88, 88,
- 0, 0, 88, 88, 88, 88, 88, 0, 88, 88,
- 0, 0, 89, 89, 89, 89, 0, 0, 72, 0,
- 0, 89, 0, 0, 0, 89, 89, 89, 89, 0,
- 0, 0, 0, 0, 89, 89, 0, 0, 89, 89,
- 89, 89, 89, 0, 89, 89, 0, 0, 85, 85,
- 85, 85, 0, 0, 0, 0, 0, 85, 0, 0,
- 0, 85, 85, 85, 85, 0, 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, 0, 0, 0, 0, 0, 86, 86, 0, 0,
- 86, 86, 86, 86, 86, 0, 86, 86, 0, 0,
- 84, 84, 84, 84, 0, 0, 0, 0, 0, 84,
- 0, 0, 0, 84, 84, 84, 84, 73, 0, 0,
- 73, 0, 84, 84, 0, 0, 84, 84, 84, 84,
- 84, 0, 84, 84, 73, 73, 0, 0, 0, 73,
+ 0, 0, 0, 0, 0, 0, 0, 0, 153, 153,
+ 153, 153, 0, 96, 0, 0, 96, 153, 0, 0,
+ 0, 0, 0, 153, 153, 153, 153, 95, 0, 0,
+ 96, 96, 0, 153, 153, 96, 153, 153, 153, 153,
+ 153, 153, 153, 0, 0, 153, 0, 0, 153, 153,
+ 153, 110, 110, 110, 110, 0, 0, 0, 0, 0,
+ 110, 0, 0, 0, 0, 96, 110, 110, 110, 110,
+ 0, 0, 0, 0, 0, 0, 110, 110, 0, 110,
+ 110, 110, 110, 110, 110, 110, 0, 0, 110, 0,
+ 0, 110, 110, 110, 0, 117, 117, 117, 117, 0,
+ 97, 0, 0, 97, 117, 0, 0, 0, 0, 0,
+ 117, 117, 117, 117, 0, 0, 0, 97, 97, 0,
+ 117, 117, 97, 117, 117, 117, 117, 117, 117, 117,
+ 0, 0, 117, 0, 0, 117, 117, 117, 101, 101,
+ 101, 101, 0, 0, 0, 0, 0, 101, 0, 0,
+ 0, 0, 97, 101, 101, 101, 101, 0, 138, 138,
+ 138, 138, 0, 101, 101, 93, 101, 101, 101, 101,
+ 101, 101, 101, 107, 0, 101, 0, 112, 0, 0,
+ 121, 0, 0, 138, 138, 0, 0, 128, 129, 130,
+ 131, 132, 0, 0, 135, 136, 0, 0, 170, 0,
+ 0, 143, 0, 0, 0, 0, 95, 95, 95, 95,
+ 0, 93, 0, 0, 93, 95, 0, 0, 0, 0,
+ 0, 95, 95, 95, 95, 0, 0, 186, 93, 93,
+ 152, 95, 95, 93, 95, 95, 95, 95, 95, 95,
+ 95, 0, 0, 0, 96, 96, 96, 96, 0, 0,
+ 0, 0, 0, 96, 0, 0, 0, 0, 0, 96,
+ 96, 96, 96, 93, 94, 0, 0, 94, 0, 96,
+ 96, 0, 96, 96, 96, 96, 96, 96, 96, 0,
+ 0, 94, 94, 0, 0, 0, 94, 0, 224, 225,
+ 226, 227, 228, 229, 230, 231, 232, 233, 234, 235,
+ 236, 237, 92, 0, 0, 92, 0, 0, 0, 0,
+ 0, 0, 0, 251, 0, 0, 94, 0, 0, 92,
+ 92, 0, 0, 0, 92, 0, 0, 0, 0, 0,
+ 0, 97, 97, 97, 97, 0, 0, 0, 0, 0,
+ 97, 0, 0, 0, 0, 0, 97, 97, 97, 97,
+ 80, 0, 0, 80, 92, 0, 97, 97, 0, 97,
+ 97, 97, 97, 97, 97, 97, 0, 80, 80, 0,
+ 0, 0, 80, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 81, 0, 0, 81,
+ 0, 0, 0, 308, 154, 155, 156, 157, 0, 0,
+ 0, 0, 80, 81, 81, 0, 0, 0, 81, 161,
+ 162, 163, 164, 165, 0, 0, 166, 0, 0, 167,
+ 168, 169, 0, 0, 0, 0, 0, 0, 0, 0,
+ 326, 82, 0, 0, 82, 0, 0, 0, 81, 0,
+ 0, 0, 93, 93, 93, 93, 0, 0, 82, 82,
+ 0, 93, 0, 82, 0, 0, 0, 93, 93, 93,
+ 93, 0, 0, 0, 0, 0, 0, 93, 93, 0,
+ 93, 93, 93, 93, 93, 93, 93, 0, 0, 0,
+ 0, 0, 0, 82, 0, 143, 0, 0, 143, 0,
+ 0, 0, 0, 0, 0, 94, 94, 94, 94, 0,
+ 0, 0, 143, 143, 94, 0, 0, 143, 0, 0,
+ 94, 94, 94, 94, 0, 0, 0, 0, 0, 0,
+ 94, 94, 0, 94, 94, 94, 94, 94, 94, 94,
+ 0, 0, 0, 92, 92, 92, 92, 143, 0, 0,
+ 0, 0, 92, 0, 0, 0, 0, 0, 92, 92,
+ 92, 92, 142, 0, 0, 142, 0, 0, 92, 92,
+ 0, 92, 92, 92, 92, 92, 92, 92, 0, 142,
+ 142, 0, 0, 0, 142, 0, 0, 0, 0, 0,
+ 0, 80, 80, 80, 80, 79, 0, 0, 79, 0,
+ 80, 0, 0, 0, 0, 0, 80, 80, 80, 80,
+ 0, 0, 79, 79, 142, 131, 80, 80, 131, 80,
+ 80, 80, 80, 80, 80, 80, 0, 81, 81, 81,
+ 81, 0, 131, 131, 0, 0, 81, 131, 0, 0,
+ 0, 0, 81, 81, 81, 81, 0, 79, 0, 0,
+ 0, 0, 81, 81, 0, 81, 81, 81, 81, 81,
+ 81, 102, 0, 0, 102, 0, 0, 131, 0, 0,
+ 0, 0, 82, 82, 82, 82, 0, 0, 102, 102,
+ 0, 82, 0, 102, 0, 0, 0, 82, 82, 0,
+ 82, 170, 0, 0, 0, 0, 0, 82, 82, 0,
+ 82, 82, 82, 82, 82, 82, 0, 67, 0, 0,
+ 67, 0, 0, 102, 87, 0, 0, 87, 0, 0,
+ 0, 0, 0, 152, 67, 67, 143, 143, 143, 143,
+ 0, 87, 87, 0, 0, 143, 87, 0, 0, 0,
+ 0, 143, 143, 0, 0, 0, 89, 0, 0, 89,
+ 0, 143, 143, 0, 143, 143, 143, 143, 143, 67,
+ 0, 0, 0, 89, 89, 0, 87, 0, 89, 0,
+ 0, 159, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 74, 0, 0, 74, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 74, 74, 73,
- 0, 0, 74, 0, 0, 0, 0, 72, 72, 72,
- 72, 0, 0, 0, 0, 0, 72, 0, 0, 0,
- 72, 72, 72, 72, 75, 0, 0, 75, 0, 72,
- 72, 0, 74, 72, 72, 72, 72, 72, 0, 72,
- 72, 75, 75, 0, 0, 0, 75, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 123, 0, 0,
- 123, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 123, 123, 75, 0, 0, 123,
- 0, 0, 0, 0, 0, 0, 0, 0, 94, 0,
- 0, 94, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 94, 94, 0, 0, 123,
- 94, 0, 0, 0, 0, 0, 0, 0, 0, 134,
- 0, 0, 134, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 134, 134, 0, 0,
- 94, 134, 0, 0, 0, 0, 0, 0, 0, 0,
- 76, 0, 0, 76, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 77, 76, 76, 77,
- 0, 134, 76, 0, 0, 0, 0, 0, 73, 73,
- 73, 73, 0, 77, 77, 0, 0, 73, 77, 0,
- 0, 73, 73, 73, 73, 0, 0, 0, 0, 0,
- 73, 73, 76, 0, 73, 73, 73, 73, 73, 0,
- 73, 74, 74, 74, 74, 0, 0, 0, 77, 0,
- 74, 0, 0, 0, 74, 74, 0, 74, 78, 0,
- 0, 78, 0, 74, 74, 0, 0, 74, 74, 74,
- 74, 74, 0, 74, 79, 78, 78, 79, 0, 0,
- 78, 0, 0, 0, 0, 75, 75, 75, 75, 0,
- 0, 79, 79, 0, 75, 0, 79, 0, 75, 75,
- 0, 0, 0, 0, 0, 0, 0, 75, 75, 0,
- 78, 75, 75, 75, 75, 75, 0, 75, 123, 123,
- 123, 123, 0, 0, 0, 0, 79, 123, 0, 0,
- 0, 123, 123, 0, 0, 0, 0, 0, 0, 81,
- 123, 123, 81, 0, 123, 123, 123, 123, 123, 94,
- 94, 94, 94, 0, 0, 0, 81, 81, 94, 0,
- 0, 81, 94, 94, 0, 0, 0, 0, 0, 0,
- 0, 94, 94, 0, 0, 94, 94, 94, 94, 94,
- 134, 134, 134, 134, 0, 0, 0, 0, 0, 134,
- 0, 81, 0, 134, 134, 0, 0, 0, 0, 0,
- 0, 0, 134, 134, 0, 0, 134, 134, 134, 134,
- 134, 76, 76, 76, 76, 0, 0, 0, 0, 0,
- 76, 0, 0, 0, 0, 76, 0, 77, 77, 77,
- 77, 0, 0, 76, 76, 0, 77, 76, 76, 76,
- 76, 76, 0, 0, 0, 0, 0, 0, 0, 77,
- 77, 0, 0, 77, 77, 77, 77, 77, 0, 0,
+ 0, 0, 0, 142, 142, 142, 142, 0, 89, 170,
+ 0, 0, 142, 0, 0, 159, 0, 0, 142, 142,
+ 0, 0, 0, 0, 0, 0, 0, 0, 142, 142,
+ 0, 142, 142, 142, 142, 142, 79, 79, 79, 79,
+ 0, 152, 0, 170, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 131, 131, 131, 131,
+ 0, 79, 79, 0, 0, 131, 0, 0, 0, 0,
+ 0, 131, 131, 0, 0, 152, 0, 0, 0, 0,
+ 0, 131, 131, 0, 131, 131, 131, 131, 131, 0,
+ 0, 0, 0, 0, 0, 0, 0, 154, 155, 156,
+ 157, 0, 102, 102, 102, 102, 0, 0, 0, 0,
+ 0, 102, 0, 162, 163, 164, 165, 102, 102, 166,
+ 0, 0, 167, 168, 169, 0, 0, 102, 102, 0,
+ 102, 102, 102, 102, 102, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 67, 67,
+ 67, 67, 0, 0, 0, 87, 87, 87, 87, 0,
+ 0, 0, 0, 0, 87, 0, 0, 0, 0, 0,
+ 0, 0, 0, 67, 67, 0, 0, 0, 0, 0,
+ 87, 87, 0, 87, 87, 87, 87, 89, 89, 89,
+ 89, 0, 0, 0, 0, 0, 89, 0, 0, 153,
+ 0, 0, 0, 0, 0, 154, 155, 156, 157, 0,
+ 0, 0, 89, 89, 0, 89, 89, 89, 158, 160,
+ 161, 162, 163, 164, 165, 0, 0, 166, 0, 0,
+ 167, 168, 169, 153, 0, 0, 0, 0, 0, 154,
+ 155, 156, 157, 0, 0, 0, 0, 67, 0, 0,
+ 0, 81, 0, 160, 161, 162, 163, 164, 165, 0,
+ 0, 166, 0, 0, 167, 168, 169, 97, 99, 101,
+ 103, 0, 0, 0, 0, 0, 111, 0, 0, 120,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 78,
- 78, 78, 78, 0, 0, 0, 0, 0, 78, 0,
- 0, 0, 0, 0, 0, 79, 79, 79, 79, 0,
- 0, 78, 78, 0, 79, 78, 78, 78, 78, 78,
- 0, 0, 91, 0, 0, 0, 0, 79, 79, 0,
- 104, 79, 79, 79, 79, 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,
- 81, 81, 81, 81, 0, 0, 0, 0, 0, 81,
- 0, 0, 183, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 81, 81, 0, 0, 81, 81, 81, 0,
+ 0, 0, 0, 0, 179, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 187, 0,
+ 0, 190, 0, 192, 0, 194, 0, 196, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 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, 215, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 297, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 313,
+ 0, 0, 0, 0, 0, 253, 0, 0, 0, 0,
+ 0, 0, 260,
};
short yycheck[] = { 13,
- 59, 13, 91, 17, 59, 59, 36, 93, 182, 194,
- 41, 123, 59, 44, 257, 41, 59, 40, 44, 33,
- 34, 35, 36, 91, 40, 88, 59, 58, 59, 43,
- 41, 40, 63, 45, 123, 41, 50, 63, 91, 41,
- 257, 41, 41, 40, 56, 40, 59, 40, 60, 41,
- 257, 41, 40, 116, 41, 123, 188, 59, 190, 40,
- 59, 91, 93, 41, 78, 91, 41, 36, 91, 59,
- 123, 40, 59, 41, 278, 41, 123, 41, 92, 294,
- 295, 95, 94, 97, 96, 99, 98, 101, 100, 41,
- 102, 59, 41, 123, 106, 41, 40, 123, 41, 41,
- 123, 123, 41, 44, 59, 44, 0, 123, 276, 277,
- 123, 44, 40, 287, 123, 300, 179, 59, 303, 58,
- 59, 184, 59, 59, 260, 59, 123, 141, 123, 123,
- 257, 40, 144, 145, 146, 147, 148, 149, 150, 33,
- 40, 40, 36, 37, 38, 257, 40, 295, 42, 43,
- 335, 45, 41, 6, 93, 8, 168, 169, 170, 171,
- 172, 173, 174, 125, 178, 59, 298, 299, 91, 41,
- 64, 185, 41, 305, 0, 59, 91, 125, 31, 32,
- 40, 93, 59, 41, 36, 40, 198, 125, 83, 59,
- 125, 93, 204, 205, 206, 125, 328, 91, 125, 211,
- 125, 41, 41, 257, 123, 91, 93, 33, 294, 295,
- 36, 37, 38, 41, 40, 59, 42, 43, 41, 45,
- 41, 59, 93, 59, 313, 237, 59, 239, 258, 123,
- 41, 125, 126, 59, 326, 294, 295, 123, 64, 294,
- 295, 272, 273, 274, 275, 259, 13, 261, 269, 263,
- 264, 294, 295, 267, -1, 281, 270, 269, 93, 285,
- 286, 287, 288, 294, 295, 91, 93, 298, 0, -1,
- 282, 123, 298, 299, 300, 301, 302, 93, 304, 305,
- -1, -1, 308, 294, 295, 311, 312, 313, 294, 295,
- 302, -1, 306, -1, 294, 295, -1, 123, -1, 125,
- 126, 33, 294, 295, 36, 37, 38, -1, 40, -1,
- 42, 43, -1, 45, 326, -1, 294, 295, 332, 294,
- 295, -1, 336, 272, 273, 274, 275, 59, 294, 295,
- 294, 295, 64, 272, 273, 274, 275, -1, -1, 294,
- 295, -1, 294, 295, -1, 294, 295, -1, 294, 295,
- -1, 294, 295, 294, 295, 294, 295, 294, 295, 91,
- 294, 295, 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, 123, 294, 295, 126, 289, 290, 291, 292, 293,
- 41, 287, 296, 297, 91, 257, -1, 294, 295, 303,
- 262, -1, -1, 307, -1, 309, 310, -1, 59, 305,
- -1, -1, 308, 294, 295, 311, 312, 313, -1, -1,
- 256, 257, 258, 259, 260, 261, 123, 263, 264, 265,
+ 36, 198, 196, 36, 40, 93, 85, 41, 91, 59,
+ 44, 36, 93, 41, 123, 41, 44, 185, 41, 41,
+ 40, 91, 40, 257, 93, 59, 257, 40, 40, 40,
+ 58, 59, 46, 59, 41, 63, 59, 44, 93, 257,
+ 123, 276, 277, 57, 41, 26, 41, 61, 91, 41,
+ 59, 58, 59, 123, 44, 41, 63, 41, 91, 93,
+ 59, 59, 43, 44, 0, 93, 96, 40, 98, 50,
+ 100, 91, 102, 90, 104, 105, 41, 59, 40, 59,
+ 123, 62, 63, 64, 65, 282, 93, 266, 267, 268,
+ 123, 270, 271, 40, 59, 109, 110, 33, 123, 40,
+ 36, 37, 38, 123, 40, 123, 42, 43, 125, 45,
+ 123, 123, 123, 59, 123, 59, 278, 314, 123, 316,
+ 297, 298, 41, 59, 123, 44, 59, 40, 64, 110,
+ 298, 41, 146, 147, 148, 149, 150, 151, 152, 59,
+ 44, 6, 336, 8, 63, 339, 123, 59, 257, 59,
+ 41, 257, 260, 40, 40, 91, 170, 171, 172, 173,
+ 174, 175, 176, 0, 358, 182, 31, 32, 59, 199,
+ 187, 185, 91, 41, 41, 189, 40, 191, 41, 36,
+ 125, 195, 91, 91, 198, 125, 91, 123, 91, 125,
+ 126, 205, 59, 207, 208, 41, 33, 93, 212, 36,
+ 37, 38, 298, 40, 123, 42, 43, 257, 45, 297,
+ 298, 93, 40, 59, 123, 59, 297, 298, 41, 0,
+ 123, 41, 59, 41, 238, 258, 240, 64, 297, 298,
+ 41, 314, 257, 41, 123, 93, 44, 262, 272, 273,
+ 274, 275, 297, 298, 272, 273, 274, 275, 40, 40,
+ 58, 59, 33, 281, 91, 36, 37, 38, 337, 40,
+ 296, 42, 43, 297, 45, 272, 273, 274, 275, 297,
+ 298, 41, 300, 301, 281, 297, 298, 41, 59, 293,
+ 287, 288, 59, 64, 298, 93, 123, 125, 125, 126,
+ 297, 298, 125, 300, 301, 302, 303, 304, 305, 125,
+ 297, 298, 297, 298, 318, 297, 298, 297, 298, 125,
+ 91, 297, 298, 297, 298, 297, 298, 297, 298, 41,
+ 256, 257, 258, 259, 260, 261, 125, 263, 264, 265,
266, 267, 268, 269, 270, 271, 272, 273, 274, 275,
- -1, -1, 93, 279, 280, -1, 282, 283, 284, 294,
- 295, -1, -1, 289, 290, 291, 292, 293, -1, -1,
- 296, 297, 91, -1, -1, -1, -1, 303, 294, 295,
- -1, 307, 91, 309, 310, 26, 33, -1, -1, 36,
- 37, 38, -1, 40, 41, 42, 43, 44, 45, 48,
- 49, 42, -1, -1, 123, -1, 47, -1, 49, -1,
- -1, 58, 59, -1, 123, 125, 63, 64, -1, -1,
- 61, 62, 63, 64, 256, 257, 258, 259, 260, 261,
- -1, 263, 264, 265, -1, -1, -1, 269, -1, 88,
- 272, 273, 274, 275, 91, -1, 93, 279, 280, -1,
- 282, 283, 284, 63, -1, -1, -1, 289, 290, 291,
- 292, 293, 91, -1, 296, 297, 107, 116, 266, 267,
- 268, 303, 270, 271, 123, 307, 123, 309, 310, 126,
- 33, 91, -1, 36, 37, 38, -1, 40, 41, 42,
- 43, 44, 45, -1, 123, -1, -1, -1, 285, 286,
- 287, 288, -1, -1, -1, 58, 59, -1, -1, -1,
- 63, 64, -1, 123, 301, 302, -1, 304, 305, -1,
- -1, 308, -1, -1, 311, 312, 313, -1, -1, -1,
- 179, 272, 273, 274, 275, 184, -1, -1, -1, 33,
- 93, -1, 36, 37, 38, -1, 40, -1, 42, 43,
- -1, 45, -1, 294, 295, -1, 266, 267, 268, -1,
- 270, 271, -1, -1, -1, 59, 285, 286, 287, 288,
- 64, -1, -1, 126, -1, -1, 285, 286, 287, 288,
- 299, 300, 301, 302, -1, 304, 305, -1, -1, 308,
- -1, -1, 311, 312, 313, 304, 305, 91, -1, 308,
- -1, -1, 311, 312, 313, -1, -1, -1, -1, -1,
- 257, 258, 259, 260, 261, -1, 263, 264, 265, -1,
- -1, -1, 269, -1, -1, 272, 273, 274, 275, 123,
- -1, -1, 126, 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, 91, -1, -1,
- -1, 281, -1, -1, -1, 285, 286, 287, 288, 308,
- -1, -1, 311, 312, 313, -1, -1, -1, 298, 299,
- 300, 301, 302, -1, 304, 305, -1, -1, 308, 123,
- -1, 311, 312, 313, 257, 258, 259, 260, 261, -1,
- 263, 264, 265, -1, -1, -1, 269, -1, -1, 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, 91, 256, 257, 258, 259, 260, 261, -1, 263,
- 264, 265, -1, 41, -1, 269, 44, -1, 272, 273,
- 274, 275, -1, -1, -1, 279, 280, -1, 282, 283,
- 284, 59, -1, 123, -1, 289, 290, 291, 292, 293,
- -1, -1, 296, 297, -1, -1, -1, -1, -1, 303,
- 25, 26, -1, 307, 33, 309, 310, 36, 37, 38,
- -1, 40, 37, 42, 43, 93, 45, 42, 43, -1,
- -1, -1, 47, -1, 49, 272, 273, 274, 275, -1,
- 59, -1, -1, -1, -1, 64, 61, 62, 63, 64,
- -1, -1, -1, -1, -1, -1, -1, 294, 295, -1,
- -1, -1, -1, 287, 288, -1, -1, -1, -1, -1,
- 33, -1, 91, 36, 37, 38, -1, 40, -1, 42,
- 43, 305, 45, -1, 308, -1, -1, 311, 312, 313,
- -1, -1, 107, -1, -1, -1, -1, -1, -1, -1,
- -1, 64, -1, -1, 123, -1, -1, 126, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -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, 167, -1, -1, -1, -1, 64, -1, -1,
- 123, -1, -1, 126, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 305, -1, -1, 308, -1,
- -1, 311, 312, 313, 91, -1, -1, -1, -1, 33,
- -1, -1, 36, 37, 38, -1, 40, -1, 42, 43,
- -1, 45, -1, -1, 272, 273, 274, 275, -1, -1,
- -1, -1, -1, -1, -1, 59, 123, -1, -1, 126,
- 64, -1, -1, -1, -1, -1, 294, -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, -1, -1, -1,
- 289, 290, 291, 292, 293, -1, -1, 296, 297, -1,
- 91, 63, 126, -1, 303, -1, -1, -1, 307, -1,
- 309, 310, -1, -1, 257, 258, 259, 260, 261, 262,
- 263, 264, 265, -1, -1, -1, 269, -1, -1, 91,
- 41, -1, 123, -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, -1, -1,
- 303, 123, -1, -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, 41, 123, -1, 44, -1, 303, -1, -1, -1,
- 307, -1, 309, 310, -1, -1, -1, -1, 58, 59,
- -1, -1, -1, 257, 258, 259, 260, 261, 91, 263,
- 264, 265, -1, 33, -1, 269, 36, 37, 38, -1,
- 40, -1, 42, 43, -1, 45, 280, -1, 282, 283,
- 284, -1, -1, 93, -1, 289, 290, 291, 292, 293,
- 123, -1, 296, 297, 64, -1, -1, -1, -1, 303,
- -1, -1, -1, 307, -1, 309, 310, -1, -1, -1,
- -1, -1, -1, -1, 285, -1, 287, 288, -1, 33,
- -1, 91, 36, 37, 38, -1, 40, 41, 42, 43,
- -1, 45, -1, 304, 305, -1, -1, 308, -1, 281,
- 311, 312, 313, 285, 286, 287, 288, -1, -1, -1,
- 64, -1, -1, 123, -1, -1, 126, 299, 300, 301,
- 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
- 312, 313, -1, -1, -1, 33, -1, 91, 36, 37,
- 38, -1, 40, -1, 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, -1, -1, -1, -1, -1,
- -1, -1, -1, 91, -1, 93, -1, -1, 33, -1,
- -1, 36, 37, 38, -1, 40, -1, 42, 43, -1,
- 45, -1, -1, -1, 287, 288, -1, -1, -1, -1,
- -1, -1, 272, 273, 274, 275, -1, -1, 126, 64,
- -1, 304, 305, -1, -1, 308, -1, -1, 311, 312,
- 313, -1, -1, -1, 294, 295, -1, 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, -1, -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, 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, 41, -1, 93, 44, 303, -1, -1, -1, 307,
- -1, 309, 310, -1, -1, -1, -1, -1, 58, 59,
- -1, 256, 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,
- -1, -1, -1, 93, 289, 290, 291, 292, 293, -1,
- -1, 296, 297, 64, -1, -1, -1, -1, 303, -1,
- -1, -1, 307, -1, 309, 310, -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, -1, -1, -1, -1, -1, 285, 286, 287,
- 288, -1, -1, -1, -1, -1, -1, -1, -1, 64,
- -1, -1, 300, 301, 302, 126, 304, 305, -1, -1,
- 308, -1, -1, 311, 312, 313, -1, -1, 285, 286,
- 287, 288, -1, -1, 33, -1, 91, 36, 37, 38,
- -1, 40, 41, 42, 43, 302, 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, 272, 273, 274, 275, -1, 126, 64, -1,
+ 41, 355, 123, 279, 280, 126, 282, 283, 284, 285,
+ 286, 297, 298, 297, 298, 291, 292, 293, 294, 295,
+ 296, 41, 281, 299, 297, 298, 41, 59, 287, 288,
+ 289, 290, 308, 41, 310, 311, 41, 297, 298, 123,
+ 289, 300, 301, 302, 303, 304, 305, 306, 41, 59,
+ 309, 59, 41, 312, 313, 314, 59, 306, 41, 41,
+ 309, 297, 298, 312, 313, 314, 309, 59, 41, 312,
+ 313, 314, 13, 147, 95, 297, 298, 355, 91, 256,
+ 257, 258, 259, 260, 261, 93, 263, 264, 265, 266,
+ 267, 268, 269, 270, 271, 272, 273, 274, 275, 297,
+ 298, 318, 279, 280, 195, 282, 283, 284, 285, 286,
+ 123, -1, -1, -1, 291, 292, 293, 294, 295, 296,
+ -1, -1, 299, 91, 272, 273, 274, 275, -1, -1,
+ -1, 308, -1, 310, 311, 256, 257, 258, 259, 260,
+ 261, 125, 263, 264, 265, -1, -1, -1, 269, 297,
+ 298, 272, 273, 274, 275, 123, -1, -1, 279, 280,
+ -1, 282, 283, 284, 285, 286, -1, -1, -1, 91,
+ 291, 292, 293, 294, 295, 296, -1, -1, 299, -1,
+ -1, -1, 125, -1, 91, -1, -1, 308, 33, 310,
+ 311, 36, 37, 38, -1, 40, 41, 42, 43, 44,
+ 45, 123, -1, 25, 26, 190, -1, 192, 272, 273,
+ 274, 275, -1, 58, 59, 37, 123, -1, 63, 64,
+ -1, 43, 44, 45, -1, -1, -1, -1, 50, -1,
+ -1, -1, -1, 297, 298, -1, -1, -1, -1, -1,
+ 62, 63, 64, 65, -1, -1, 91, -1, 93, 33,
+ -1, -1, 36, 37, 38, -1, 40, 41, 42, 43,
+ 44, 45, -1, -1, 272, 273, 274, 275, -1, -1,
+ -1, -1, -1, -1, 58, 59, 289, 290, 123, 63,
+ 64, 126, 266, 267, 268, -1, 270, 271, 110, 297,
+ 298, -1, 305, 306, -1, -1, 309, -1, -1, 312,
+ 313, 314, -1, -1, -1, -1, -1, -1, 33, 93,
+ -1, 36, 37, 38, -1, 40, -1, 42, 43, 287,
+ 45, 289, 290, 266, 267, 268, -1, 270, 271, -1,
+ -1, -1, -1, -1, 59, -1, -1, 305, 306, 64,
+ -1, 309, 126, -1, 312, 313, 314, 169, -1, 334,
+ 335, -1, -1, -1, -1, -1, 341, -1, -1, 41,
+ -1, -1, 44, -1, -1, -1, 91, 289, 290, -1,
+ -1, 356, -1, -1, 359, 197, 58, 59, -1, -1,
+ -1, 63, -1, -1, 306, -1, -1, 309, -1, -1,
+ 312, 313, 314, -1, -1, -1, -1, -1, 123, 306,
+ -1, 126, 309, -1, -1, 312, 313, 314, -1, -1,
+ -1, 93, 257, 258, 259, 260, 261, -1, 263, 264,
+ 265, -1, -1, -1, 269, -1, -1, 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, 306, -1, 308, 309, 310, 311, 312, 313, 314,
+ -1, -1, -1, 257, 258, 259, 260, 261, -1, 263,
+ 264, 265, -1, -1, -1, 269, -1, -1, 272, 273,
+ 274, 275, -1, -1, -1, -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, 306, -1, 308, 309, 310, 311, 312, 313,
+ 314, 256, 257, 258, 259, 260, 261, -1, 263, 264,
+ 265, -1, -1, -1, 269, -1, -1, 272, 273, 274,
+ 275, -1, -1, -1, 279, 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, 43, -1, -1,
+ 272, 273, 274, 275, -1, 51, -1, 123, 59, 281,
+ -1, -1, -1, 64, -1, 287, 288, 289, 290, -1,
+ -1, -1, -1, -1, -1, 297, 298, -1, 300, 301,
+ 302, 303, 304, 305, 306, -1, -1, 309, 33, -1,
+ 91, 36, 37, 38, 90, 40, -1, 42, 43, -1,
+ 45, -1, -1, -1, -1, -1, -1, -1, 309, 310,
+ 311, -1, -1, -1, 315, -1, 317, -1, -1, 64,
+ -1, 117, 123, -1, -1, 126, -1, -1, -1, 125,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 294, 295, 257, 258, 259, 260,
+ -1, -1, 343, -1, 33, -1, 91, 36, 37, 38,
+ 351, 40, 353, 42, 43, -1, 45, -1, -1, -1,
+ -1, -1, -1, 364, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 64, -1, -1, 123, -1,
+ -1, 126, -1, -1, -1, -1, 182, -1, -1, -1,
+ -1, 187, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 91, -1, -1, -1, -1, 33, -1, -1,
+ 36, 37, 38, -1, 40, -1, 42, 43, -1, 45,
+ -1, 287, 288, 289, 290, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 123, -1, -1, 126, 64, 305,
+ 306, -1, -1, 309, -1, -1, 312, 313, 314, -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, -1,
- 42, 43, -1, 45, 280, -1, 282, 283, 284, -1,
- -1, -1, -1, 289, 290, 291, 292, 293, -1, -1,
- 296, 297, 64, -1, -1, -1, -1, 303, -1, -1,
- -1, 307, -1, 309, 310, -1, -1, -1, -1, -1,
- 41, -1, -1, 44, -1, -1, -1, -1, -1, 91,
- -1, -1, -1, -1, -1, -1, -1, 58, 59, -1,
- -1, -1, 63, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 126, 272, 273, 274, 275, -1,
- 91, -1, 93, -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, 123, -1, 311, 312, 313, -1, -1, -1,
- -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, 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, -1, -1, 307, -1, 309, 310, -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, -1, -1, -1, -1, -1,
- -1, -1, 58, 59, -1, -1, -1, 63, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -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, -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, 93, -1, -1, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
- 285, 286, 287, 288, -1, -1, -1, 41, -1, 294,
- 295, -1, -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, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 41, -1, -1, -1, -1, -1, 91, -1, 93,
- -1, -1, -1, -1, -1, -1, -1, -1, 58, 59,
- -1, -1, -1, 63, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 123,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 91, -1, 93, -1, -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, 123, -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,
- -1, -1, -1, 272, 273, 274, 275, 58, 59, -1,
- -1, -1, 63, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 294, 295, -1, 123, 298,
- -1, -1, -1, 41, -1, -1, -1, -1, -1, -1,
- -1, -1, 93, -1, -1, -1, -1, -1, -1, -1,
- 58, 59, -1, -1, -1, 63, -1, -1, -1, -1,
+ -1, 272, 273, 274, 275, -1, -1, -1, 279, 280,
+ -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
+ 291, 292, 293, 294, 295, 296, -1, 123, 299, -1,
+ 126, -1, 91, -1, -1, -1, 41, 308, -1, 310,
+ 311, -1, 257, 258, 259, 260, 261, 262, 263, 264,
+ 265, -1, -1, -1, 269, -1, -1, -1, 63, -1,
+ -1, -1, -1, -1, 123, 280, -1, 282, 283, 284,
+ 285, 286, -1, -1, -1, -1, 291, 292, 293, 294,
+ 295, 296, -1, -1, 299, -1, 91, -1, -1, -1,
+ -1, -1, -1, 308, -1, 310, 311, -1, 257, 258,
+ 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
+ 269, 58, -1, -1, -1, -1, 63, -1, 123, -1,
+ -1, 280, -1, 282, 283, 284, 285, 286, -1, -1,
+ -1, -1, 291, 292, 293, 294, 295, 296, -1, -1,
+ 299, -1, -1, -1, 91, -1, -1, -1, -1, 308,
+ -1, 310, 311, -1, -1, -1, -1, 41, -1, -1,
+ 44, 257, 258, 259, 260, 261, -1, 263, 264, 265,
+ -1, -1, -1, 269, 58, 59, 123, -1, -1, 63,
+ -1, -1, -1, -1, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
+ 296, 33, -1, 299, 36, 37, 38, -1, 40, 93,
+ 42, 43, 308, 45, 310, 311, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 59, 287, 288,
+ 289, 290, 64, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 301, 302, 303, 304, 305, 306, -1, -1,
+ 309, -1, -1, 312, 313, 314, -1, 33, -1, 91,
+ 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
+ -1, -1, -1, -1, -1, -1, 281, -1, -1, -1,
+ -1, -1, 287, 288, 289, 290, -1, -1, 64, -1,
+ -1, -1, -1, -1, 126, 300, 301, 302, 303, 304,
+ 305, 306, -1, -1, 309, -1, -1, 312, 313, 314,
+ -1, -1, -1, 33, -1, 91, 36, 37, 38, -1,
+ 40, -1, 42, 43, -1, 45, -1, -1, -1, -1,
+ -1, -1, -1, -1, 281, -1, -1, -1, -1, -1,
+ 287, 288, 289, 290, 64, -1, -1, -1, -1, -1,
+ 126, -1, -1, 300, 301, 302, 303, 304, 305, 306,
+ -1, -1, 309, -1, -1, 312, 313, 314, -1, -1,
+ -1, 91, 33, 93, -1, 36, 37, 38, -1, 40,
+ 41, 42, 43, -1, 45, -1, -1, -1, 272, 273,
+ 274, 275, -1, -1, -1, -1, -1, 281, -1, -1,
+ -1, -1, -1, 64, 288, -1, 126, -1, -1, -1,
+ -1, -1, -1, 297, 298, -1, 300, 301, 302, 303,
+ 304, 41, -1, -1, 44, 257, 258, 259, 260, 261,
+ 91, 263, 264, 265, -1, -1, -1, 269, 58, 59,
+ -1, -1, -1, 63, -1, -1, -1, -1, 280, -1,
+ 282, 283, 284, 285, 286, -1, -1, -1, -1, 291,
+ 292, 293, 294, 295, 296, 126, -1, 299, -1, -1,
+ -1, -1, -1, 93, -1, -1, 308, 41, 310, 311,
+ 44, 257, 258, 259, 260, 261, -1, 263, 264, 265,
+ -1, -1, -1, 269, 58, 59, -1, -1, -1, 63,
+ -1, -1, -1, -1, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
+ 296, -1, -1, 299, -1, -1, -1, -1, -1, 93,
+ -1, -1, 308, -1, 310, 311, -1, 257, 258, 259,
+ 260, 261, -1, 263, 264, 265, -1, 33, -1, 269,
+ 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
+ 280, -1, 282, 283, 284, 285, 286, -1, -1, -1,
+ -1, 291, 292, 293, 294, 295, 296, -1, 64, 299,
+ -1, -1, -1, -1, -1, -1, -1, -1, 308, -1,
+ 310, 311, -1, -1, -1, -1, 257, 258, 259, 260,
+ 261, -1, 263, 264, 265, 91, 33, -1, 269, 36,
+ 37, 38, -1, 40, -1, 42, 43, -1, 45, 280,
+ -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
+ 291, 292, 293, 294, 295, 296, -1, 64, 299, -1,
+ 126, -1, -1, -1, -1, -1, -1, 308, -1, 310,
+ 311, -1, 272, 273, 274, 275, -1, -1, -1, -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, 272, 273,
+ 274, 275, -1, -1, -1, -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, -1, 123, -1, -1, -1, -1, -1, 272, 273,
- 274, 275, -1, 91, -1, 93, -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, 308, 123, -1, 311, 312, 313,
+ -1, 257, 258, 259, 260, 261, 91, 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, 126, 64, 299, -1, -1, -1, -1, -1, -1,
+ -1, -1, 308, -1, 310, 311, -1, -1, -1, 256,
+ 257, 258, 259, 260, 261, -1, 263, 264, 265, 91,
+ -1, -1, 269, 41, -1, -1, 44, -1, -1, -1,
+ -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
+ 58, 59, -1, -1, 291, 292, 293, 294, 295, 296,
+ -1, -1, 299, -1, 126, -1, -1, -1, -1, 41,
+ -1, 308, 44, 310, 311, -1, 257, 258, 259, 260,
+ 261, -1, 263, 264, 265, 93, 58, 59, 269, -1,
+ -1, 63, -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, 91,
+ -1, 93, -1, -1, -1, -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, 123, -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,
+ 93, -1, -1, 308, -1, 310, 311, -1, -1, -1,
+ -1, 41, -1, -1, 44, 257, 258, 259, 260, 261,
+ -1, 263, 264, 265, -1, -1, -1, 269, 58, 59,
+ 123, -1, -1, 63, -1, -1, -1, -1, 280, -1,
+ 282, 283, 284, 285, 286, -1, -1, -1, -1, 291,
+ 292, 293, 294, 295, 296, -1, -1, 299, -1, 41,
+ -1, 91, 44, 93, -1, -1, 308, -1, 310, 311,
+ -1, -1, -1, -1, -1, -1, 58, 59, -1, -1,
+ -1, 63, -1, -1, 272, 273, 274, 275, -1, -1,
+ -1, -1, -1, 123, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 297,
+ 298, 93, 300, -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, -1,
+ -1, 123, 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, 91, -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, -1, -1, 309, -1, -1, 312,
+ 313, 314, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 93, -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, 93, 298, 299,
- 300, 301, 302, -1, 304, 305, -1, -1, 308, -1,
- -1, 311, 312, 313, -1, -1, -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, 41, -1, 308, 44, -1, 311, 312, 313, 93,
- -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, 58,
- -1, -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,
- 308, -1, 91, 311, 312, 313, -1, -1, -1, -1,
- -1, -1, 58, 59, -1, -1, -1, 63, -1, -1,
+ -1, 281, -1, -1, -1, -1, -1, 287, 288, 289,
+ 290, -1, -1, -1, -1, -1, 123, 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, -1, 281,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
+ -1, -1, 58, 59, -1, 297, 298, 63, 300, 301,
+ 302, 303, 304, 305, 306, -1, -1, 309, -1, -1,
+ 312, 313, 314, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 91, -1, 93, -1, -1,
-1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, -1, 123, -1, -1, 41, -1, -1,
- 44, -1, -1, -1, -1, -1, -1, 93, 294, 295,
- -1, -1, -1, -1, 58, 59, -1, -1, -1, 63,
+ -1, -1, -1, -1, -1, 281, -1, -1, -1, -1,
+ -1, 287, 288, 289, 290, -1, -1, 123, -1, -1,
+ 91, 297, 298, -1, 300, 301, 302, 303, 304, 305,
+ 306, -1, -1, 309, -1, -1, 312, 313, 314, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 123, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 41, 93,
- -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, 41, -1, 308, 44, -1, 311, 312, 313,
- 93, -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, 41, 304, 305, 44, -1, 308, -1,
- -1, 311, 312, 313, 93, -1, -1, -1, -1, -1,
- 58, 59, 281, -1, -1, 63, 285, 286, 287, 288,
- -1, -1, -1, -1, -1, -1, -1, -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, -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, -1, -1, 311, 312, 313, 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, 308, -1, -1, 311, 312, 313,
- -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, 93, -1, -1,
- -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
- -1, 304, 305, -1, -1, 308, -1, -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, -1, 298,
- 299, 300, 301, 302, 41, 304, 305, 44, -1, 308,
- -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, 41, 304, 305, 44, -1,
- 308, -1, -1, -1, -1, -1, 93, -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, 63, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
- 44, -1, -1, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, 93, 58, 59, -1, -1, -1, 63,
- -1, -1, -1, -1, -1, -1, -1, -1, 294, 295,
+ -1, -1, 123, -1, -1, 272, 273, 274, 275, -1,
+ 41, -1, -1, -1, 281, -1, -1, -1, -1, -1,
+ 287, 288, 289, 290, -1, -1, -1, 58, 59, -1,
+ 297, 298, 63, 300, 301, 302, 303, 304, 305, 306,
+ -1, -1, 309, -1, -1, 312, 313, 314, -1, -1,
-1, -1, -1, 41, -1, -1, 44, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 93,
+ 91, -1, 93, 41, -1, -1, 44, -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, 63, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- -1, 93, -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, 305, 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, 272, 273, 274, 275, -1, -1, 93, -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, 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, 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,
- 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,
+ 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, 93, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 93, 272, 273, 274, 275,
+ -1, 41, -1, -1, 44, 281, -1, -1, -1, -1,
+ -1, 287, 288, 289, 290, 123, -1, -1, 58, 59,
+ -1, 297, 298, 63, 300, 301, 302, 303, 304, 305,
+ 306, -1, -1, 309, -1, -1, 312, 313, 314, -1,
+ -1, -1, -1, -1, 41, -1, 287, 288, 289, 290,
+ -1, -1, -1, 93, -1, -1, -1, -1, -1, -1,
+ -1, 58, 59, 304, 305, 306, 63, -1, 309, -1,
+ -1, 312, 313, 314, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 123, -1, -1, -1, -1, 41, -1,
+ -1, 44, -1, -1, 91, -1, 93, -1, -1, -1,
+ -1, -1, -1, -1, -1, 58, 59, -1, -1, -1,
+ 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 272, 273, 274, 275, -1, 123, -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, 272, 273, 274, 275, -1, 41,
+ 123, -1, 44, 281, 272, 273, 274, 275, -1, 287,
+ 288, 289, 290, -1, -1, -1, 58, 59, -1, 297,
+ 298, 63, 300, 301, 302, 303, 304, 305, 306, 297,
+ 298, 309, 300, -1, 312, 313, 314, -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, -1, 58, 59, 93,
- -1, -1, 63, -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, 93, 298, 299, 300, 301, 302, -1, 304,
- 305, 58, 59, -1, -1, -1, 63, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
+ -1, 93, -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, -1, -1, -1, 58, 59, -1, 297, 298, 63,
+ 300, 301, 302, 303, 304, 305, 306, -1, -1, 309,
+ -1, -1, 312, 313, 314, 272, 273, 274, 275, -1,
+ 41, -1, -1, 44, 281, -1, -1, -1, -1, 93,
+ 287, 288, 289, 290, -1, -1, -1, 58, 59, -1,
+ 297, 298, 63, 300, 301, 302, 303, 304, 305, 306,
+ -1, -1, 309, -1, -1, 312, 313, 314, -1, 272,
+ 273, 274, 275, -1, 41, -1, -1, 44, 281, -1,
+ -1, -1, 93, -1, 287, 288, 289, 290, -1, -1,
+ -1, 58, 59, -1, 297, 298, 63, 300, 301, 302,
+ 303, 304, 305, 306, -1, -1, 309, -1, -1, 312,
+ 313, 314, -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, 41, -1, 63,
44, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 58, 59, 93, -1, -1, 63,
- -1, -1, -1, -1, -1, -1, -1, -1, 41, -1,
- -1, 44, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 58, 59, -1, -1, 93,
- 63, -1, -1, -1, -1, -1, -1, -1, -1, 41,
- -1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 58, 59, -1, -1,
- 93, 63, -1, -1, -1, -1, -1, -1, -1, -1,
- 41, -1, -1, 44, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 41, 58, 59, 44,
- -1, 93, 63, -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, 93, -1, 298, 299, 300, 301, 302, -1,
- 304, 272, 273, 274, 275, -1, -1, -1, 93, -1,
- 281, -1, -1, -1, 285, 286, -1, 288, 41, -1,
- -1, 44, -1, 294, 295, -1, -1, 298, 299, 300,
- 301, 302, -1, 304, 41, 58, 59, 44, -1, -1,
- 63, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- -1, 58, 59, -1, 281, -1, 63, -1, 285, 286,
- -1, -1, -1, -1, -1, -1, -1, 294, 295, -1,
- 93, 298, 299, 300, 301, 302, -1, 304, 272, 273,
- 274, 275, -1, -1, -1, -1, 93, 281, -1, -1,
- -1, 285, 286, -1, -1, -1, -1, -1, -1, 41,
- 294, 295, 44, -1, 298, 299, 300, 301, 302, 272,
- 273, 274, 275, -1, -1, -1, 58, 59, 281, -1,
- -1, 63, 285, 286, -1, -1, -1, -1, -1, -1,
- -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
- 272, 273, 274, 275, -1, -1, -1, -1, -1, 281,
- -1, 93, -1, 285, 286, -1, -1, -1, -1, -1,
- -1, -1, 294, 295, -1, -1, 298, 299, 300, 301,
- 302, 272, 273, 274, 275, -1, -1, -1, -1, -1,
- 281, -1, -1, -1, -1, 286, -1, 272, 273, 274,
- 275, -1, -1, 294, 295, -1, 281, 298, 299, 300,
- 301, 302, -1, -1, -1, -1, -1, -1, -1, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, -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, 272,
- 273, 274, 275, -1, -1, -1, -1, -1, 281, -1,
+ 272, 273, 274, 275, 58, 59, -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, 41, -1, 309, 44, 93,
+ 312, 313, 314, -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, 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, 272, 273, 274, 275, -1, -1, -1, -1, -1,
+ 281, -1, -1, -1, -1, 93, 287, 288, 289, 290,
+ -1, -1, -1, -1, -1, -1, 297, 298, -1, 300,
+ 301, 302, 303, 304, 305, 306, -1, -1, 309, -1,
+ -1, 312, 313, 314, -1, 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, 272, 273,
+ 274, 275, -1, -1, -1, -1, -1, 281, -1, -1,
+ -1, -1, 93, 287, 288, 289, 290, -1, 272, 273,
+ 274, 275, -1, 297, 298, 30, 300, 301, 302, 303,
+ 304, 305, 306, 38, -1, 309, -1, 42, -1, -1,
+ 45, -1, -1, 297, 298, -1, -1, 52, 53, 54,
+ 55, 56, -1, -1, 59, 60, -1, -1, 91, -1,
+ -1, 66, -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, 92, 58, 59,
+ 123, 297, 298, 63, 300, 301, 302, 303, 304, 305,
+ 306, -1, -1, -1, 272, 273, 274, 275, -1, -1,
+ -1, -1, -1, 281, -1, -1, -1, -1, -1, 287,
+ 288, 289, 290, 93, 41, -1, -1, 44, -1, 297,
+ 298, -1, 300, 301, 302, 303, 304, 305, 306, -1,
+ -1, 58, 59, -1, -1, -1, 63, -1, 153, 154,
+ 155, 156, 157, 158, 159, 160, 161, 162, 163, 164,
+ 165, 166, 41, -1, -1, 44, -1, -1, -1, -1,
+ -1, -1, -1, 178, -1, -1, 93, -1, -1, 58,
+ 59, -1, -1, -1, 63, -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,
+ 41, -1, -1, 44, 93, -1, 297, 298, -1, 300,
+ 301, 302, 303, 304, 305, 306, -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, 258, 287, 288, 289, 290, -1, -1,
+ -1, -1, 93, 58, 59, -1, -1, -1, 63, 302,
+ 303, 304, 305, 306, -1, -1, 309, -1, -1, 312,
+ 313, 314, -1, -1, -1, -1, -1, -1, -1, -1,
+ 295, 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, -1, -1, -1,
+ -1, -1, -1, 93, -1, 41, -1, -1, 44, -1,
-1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- -1, 294, 295, -1, 281, 298, 299, 300, 301, 302,
- -1, -1, 30, -1, -1, -1, -1, 294, 295, -1,
- 38, 298, 299, 300, 301, 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,
- 272, 273, 274, 275, -1, -1, -1, -1, -1, 281,
- -1, -1, 90, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 294, 295, -1, -1, 298, 299, 300, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 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, 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, -1, 272, 273, 274, 275, 93, -1, -1,
+ -1, -1, 281, -1, -1, -1, -1, -1, 287, 288,
+ 289, 290, 41, -1, -1, 44, -1, -1, 297, 298,
+ -1, 300, 301, 302, 303, 304, 305, 306, -1, 58,
+ 59, -1, -1, -1, 63, -1, -1, -1, -1, -1,
+ -1, 272, 273, 274, 275, 41, -1, -1, 44, -1,
+ 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
+ -1, -1, 58, 59, 93, 41, 297, 298, 44, 300,
+ 301, 302, 303, 304, 305, 306, -1, 272, 273, 274,
+ 275, -1, 58, 59, -1, -1, 281, 63, -1, -1,
+ -1, -1, 287, 288, 289, 290, -1, 93, -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, 91, -1, -1, -1, -1, -1, 297, 298, -1,
+ 300, 301, 302, 303, 304, 305, -1, 41, -1, -1,
+ 44, -1, -1, 93, 41, -1, -1, 44, -1, -1,
+ -1, -1, -1, 123, 58, 59, 272, 273, 274, 275,
+ -1, 58, 59, -1, -1, 281, 63, -1, -1, -1,
+ -1, 287, 288, -1, -1, -1, 41, -1, -1, 44,
+ -1, 297, 298, -1, 300, 301, 302, 303, 304, 93,
+ -1, -1, -1, 58, 59, -1, 93, -1, 63, -1,
+ -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, 93, 91,
+ -1, -1, 281, -1, -1, 63, -1, -1, 287, 288,
+ -1, -1, -1, -1, -1, -1, -1, -1, 297, 298,
+ -1, 300, 301, 302, 303, 304, 272, 273, 274, 275,
+ -1, 123, -1, 91, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
+ -1, 297, 298, -1, -1, 281, -1, -1, -1, -1,
+ -1, 287, 288, -1, -1, 123, -1, -1, -1, -1,
+ -1, 297, 298, -1, 300, 301, 302, 303, 304, -1,
+ -1, -1, -1, -1, -1, -1, -1, 287, 288, 289,
+ 290, -1, 272, 273, 274, 275, -1, -1, -1, -1,
+ -1, 281, -1, 303, 304, 305, 306, 287, 288, 309,
+ -1, -1, 312, 313, 314, -1, -1, 297, 298, -1,
+ 300, 301, 302, 303, 304, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 272, 273,
+ 274, 275, -1, -1, -1, 272, 273, 274, 275, -1,
+ -1, -1, -1, -1, 281, -1, -1, -1, -1, -1,
+ -1, -1, -1, 297, 298, -1, -1, -1, -1, -1,
+ 297, 298, -1, 300, 301, 302, 303, 272, 273, 274,
+ 275, -1, -1, -1, -1, -1, 281, -1, -1, 281,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
+ -1, -1, 297, 298, -1, 300, 301, 302, 300, 301,
+ 302, 303, 304, 305, 306, -1, -1, 309, -1, -1,
+ 312, 313, 314, 281, -1, -1, -1, -1, -1, 287,
+ 288, 289, 290, -1, -1, -1, -1, 13, -1, -1,
+ -1, 17, -1, 301, 302, 303, 304, 305, 306, -1,
+ -1, 309, -1, -1, 312, 313, 314, 33, 34, 35,
+ 36, -1, -1, -1, -1, -1, 42, -1, -1, 45,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 80, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 94, -1,
+ -1, 97, -1, 99, -1, 101, -1, 103, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 144, -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, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 284,
+ -1, -1, -1, -1, -1, 181, -1, -1, -1, -1,
+ -1, -1, 188,
};
#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,
@@ -1123,9 +1073,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",
};
@@ -1135,6 +1085,8 @@ char *yyrule[] = {
"prog : $$1 lineseq",
"block : '{' remember lineseq '}'",
"remember :",
+"mblock : '{' mremember lineseq '}'",
+"mremember :",
"lineseq :",
"lineseq : lineseq decl",
"lineseq : lineseq line",
@@ -1147,28 +1099,34 @@ 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",
+"else : ELSE mblock",
+"else : ELSIF '(' mexpr ')' mblock else",
+"cond : IF '(' remember mexpr ')' mblock else",
+"cond : UNLESS '(' remember miexpr ')' mblock else",
"cond : IF block block else",
"cond : UNLESS block block else",
"cont :",
"cont : CONTINUE block",
-"loop : label WHILE '(' texpr ')' block cont",
-"loop : label UNTIL '(' expr ')' block cont",
+"loop : label WHILE '(' remember mtexpr ')' mblock cont",
+"loop : label UNTIL '(' remember miexpr ')' mblock 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 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",
@@ -1224,7 +1182,7 @@ char *yyrule[] = {
"term : term POSTDEC",
"term : PREINC term",
"term : PREDEC term",
-"term : LOCAL term",
+"term : local term",
"term : '(' expr ')'",
"term : '(' ')'",
"term : '[' expr ']'",
@@ -1280,6 +1238,9 @@ char *yyrule[] = {
"listexprcom :",
"listexprcom : expr",
"listexprcom : expr ','",
+"local : LOCAL",
+"local : MY",
+"my_scalar : scalar",
"amper : '&' indirob",
"scalar : '$' indirob",
"ary : '@' indirob",
@@ -1312,9 +1273,9 @@ int yyerrflag;
int yychar;
YYSTYPE yyval;
YYSTYPE yylval;
-#line 571 "perly.y"
+#line 624 "perly.y"
/* PROGRAM */
-#line 1388 "y.tab.c"
+#line 1349 "perly.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
@@ -1335,15 +1296,15 @@ yydestruct(ptr)
void* ptr;
{
struct ysv* ysave = (struct ysv*)ptr;
- if (ysave->yyss) safefree((char *)ysave->yyss);
- if (ysave->yyvs) safefree((char *)ysave->yyvs);
+ if (ysave->yyss) Safefree(ysave->yyss);
+ if (ysave->yyvs) Safefree(ysave->yyvs);
yydebug = ysave->oldyydebug;
yynerrs = ysave->oldyynerrs;
yyerrflag = ysave->oldyyerrflag;
yychar = ysave->oldyychar;
yyval = ysave->oldyyval;
yylval = ysave->oldyylval;
- safefree((char *)ysave);
+ Safefree(ysave);
}
int
@@ -1406,7 +1367,7 @@ yyloop:
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate,
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
#endif
@@ -1416,7 +1377,7 @@ yyloop:
{
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log, "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)
@@ -1471,7 +1432,7 @@ yyinrecovery:
{
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log,
+ PerlIO_printf(Perl_debug_log,
"yydebug: state %d, error recovery shifting to state %d\n",
*yyssp, yytable[yyn]);
#endif
@@ -1501,7 +1462,7 @@ yyinrecovery:
{
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log,
+ PerlIO_printf(Perl_debug_log,
"yydebug: error recovery discarding state %d\n",
*yyssp);
#endif
@@ -1520,7 +1481,7 @@ yyinrecovery:
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(Perl_debug_log,
+ PerlIO_printf(Perl_debug_log,
"yydebug: state %d, error recovery discards token %d (%s)\n",
yystate, yychar, yys);
}
@@ -1531,7 +1492,7 @@ yyinrecovery:
yyreduce:
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log, "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];
@@ -1539,7 +1500,7 @@ yyreduce:
switch (yyn)
{
case 1:
-#line 84 "perly.y"
+#line 85 "perly.y"
{
#if defined(YYDEBUG) && defined(DEBUGGING)
yydebug = (debug & 1);
@@ -1548,38 +1509,50 @@ case 1:
}
break;
case 2:
-#line 91 "perly.y"
+#line 92 "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 96 "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 102 "perly.y"
+{ yyval.ival = block_start(TRUE); }
break;
case 5:
-#line 103 "perly.y"
-{ yyval.opval = Nullop; }
+#line 106 "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 112 "perly.y"
+{ yyval.ival = block_start(FALSE); }
break;
case 7:
-#line 107 "perly.y"
+#line 116 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 8:
+#line 118 "perly.y"
+{ yyval.opval = yyvsp[-1].opval; }
+break;
+case 9:
+#line 120 "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 127 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); }
break;
-case 10:
-#line 117 "perly.y"
+case 12:
+#line 130 "perly.y"
{ if (yyvsp[-1].pval != Nullch) {
yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0));
}
@@ -1589,467 +1562,501 @@ case 10:
}
expect = XSTATE; }
break;
-case 11:
-#line 126 "perly.y"
+case 13:
+#line 139 "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 144 "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 146 "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 148 "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 150 "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 152 "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 154 "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 158 "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 160 "perly.y"
+{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 22:
-#line 159 "perly.y"
+#line 162 "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"
+#line 169 "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 173 "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 177 "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); }
break;
-case 24:
-#line 167 "perly.y"
+case 26:
+#line 181 "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); }
break;
-case 25:
-#line 174 "perly.y"
-{ yyval.opval = Nullop; }
-break;
-case 26:
-#line 176 "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 188 "perly.y"
+{ yyval.opval = Nullop; }
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 190 "perly.y"
+{ yyval.opval = scope(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 194 "perly.y"
+{ copline = yyvsp[-6].ival;
+ yyval.opval = block_end(yyvsp[-4].ival,
+ newSTATEOP(0, yyvsp[-7].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ 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 200 "perly.y"
+{ copline = yyvsp[-6].ival;
+ yyval.opval = block_end(yyvsp[-4].ival,
+ newSTATEOP(0, yyvsp[-7].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ 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 206 "perly.y"
+{ copline = yyvsp[-3].ival;
+ deprecate("while BLOCK BLOCK");
+ yyval.opval = newSTATEOP(0, yyvsp[-4].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ scope(yyvsp[-2].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 212 "perly.y"
+{ copline = yyvsp[-3].ival;
+ deprecate("until BLOCK BLOCK");
+ yyval.opval = newSTATEOP(0, yyvsp[-4].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ invert(scalar(scope(yyvsp[-2].opval))),
+ yyvsp[-1].opval, yyvsp[0].opval)); }
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 219 "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 34:
-#line 213 "perly.y"
+#line 222 "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 35:
+#line 226 "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 36:
+#line 230 "perly.y"
+{ copline = yyvsp[-9].ival;
+ yyval.opval = block_end(yyvsp[-7].ival,
+ append_elem(OP_LINESEQ, scalar(yyvsp[-6].opval),
+ newSTATEOP(0, yyvsp[-10].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ scalar(yyvsp[-4].opval),
+ yyvsp[0].opval, scalar(yyvsp[-2].opval))))); }
+break;
+case 37:
+#line 238 "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"
+case 38:
+#line 244 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 37:
-#line 224 "perly.y"
+case 40:
+#line 249 "perly.y"
{ (void)scan_num("1"); yyval.opval = yylval.opval; }
break;
-case 39:
-#line 229 "perly.y"
+case 42:
+#line 254 "perly.y"
+{ yyval.opval = invert(scalar(yyvsp[0].opval)); }
+break;
+case 43:
+#line 258 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 44:
+#line 262 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 45:
+#line 266 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 46:
+#line 270 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 47:
+#line 274 "perly.y"
{ yyval.pval = Nullch; }
break;
-case 41:
-#line 234 "perly.y"
+case 49:
+#line 279 "perly.y"
{ yyval.ival = 0; }
break;
-case 42:
-#line 236 "perly.y"
+case 50:
+#line 281 "perly.y"
{ yyval.ival = 0; }
break;
-case 43:
-#line 238 "perly.y"
+case 51:
+#line 283 "perly.y"
{ yyval.ival = 0; }
break;
-case 44:
-#line 240 "perly.y"
+case 52:
+#line 285 "perly.y"
{ yyval.ival = 0; }
break;
-case 45:
-#line 244 "perly.y"
+case 53:
+#line 289 "perly.y"
{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
-case 46:
-#line 246 "perly.y"
+case 54:
+#line 291 "perly.y"
{ newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); }
break;
-case 47:
-#line 250 "perly.y"
+case 55:
+#line 295 "perly.y"
{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
-case 48:
-#line 252 "perly.y"
+case 56:
+#line 297 "perly.y"
{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, Nullop); expect = XSTATE; }
break;
-case 49:
-#line 256 "perly.y"
+case 57:
+#line 301 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 51:
-#line 261 "perly.y"
+case 59:
+#line 306 "perly.y"
{ yyval.ival = start_subparse(); }
break;
-case 52:
-#line 265 "perly.y"
+case 60:
+#line 310 "perly.y"
{ package(yyvsp[-1].opval); }
break;
-case 53:
-#line 267 "perly.y"
+case 61:
+#line 312 "perly.y"
{ package(Nullop); }
break;
-case 54:
-#line 271 "perly.y"
+case 62:
+#line 316 "perly.y"
{ utilize(yyvsp[-5].ival, yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
-case 55:
-#line 275 "perly.y"
+case 63:
+#line 320 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 56:
-#line 277 "perly.y"
+case 64:
+#line 322 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 58:
-#line 282 "perly.y"
+case 66:
+#line 327 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
-case 59:
-#line 284 "perly.y"
+case 67:
+#line 329 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 61:
-#line 289 "perly.y"
+case 69:
+#line 334 "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 70:
+#line 337 "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 71:
+#line 340 "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 72:
+#line 345 "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 73:
+#line 350 "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 74:
+#line 355 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 67:
-#line 312 "perly.y"
+case 75:
+#line 357 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
-case 68:
-#line 314 "perly.y"
+case 76:
+#line 359 "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)); }
break;
-case 71:
-#line 325 "perly.y"
+case 79:
+#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 80:
+#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 81:
+#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 82:
+#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 83:
+#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 84:
+#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 85:
+#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 86:
+#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 87:
+#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 88:
+#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 89:
+#line 392 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 82:
-#line 349 "perly.y"
+case 90:
+#line 394 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 83:
-#line 351 "perly.y"
+case 91:
+#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 92:
+#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 93:
+#line 401 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
-case 86:
-#line 358 "perly.y"
+case 94:
+#line 403 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 87:
-#line 360 "perly.y"
+case 95:
+#line 405 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
-case 88:
-#line 362 "perly.y"
+case 96:
+#line 407 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
-case 89:
-#line 364 "perly.y"
+case 97:
+#line 409 "perly.y"
{ yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
break;
-case 90:
-#line 366 "perly.y"
+case 98:
+#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 99:
+#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 100:
+#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 101:
+#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 102:
+#line 423 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
-case 95:
-#line 380 "perly.y"
+case 103:
+#line 425 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
-case 96:
-#line 382 "perly.y"
+case 104:
+#line 427 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
-case 97:
-#line 384 "perly.y"
+case 105:
+#line 429 "perly.y"
{ yyval.opval = newANONLIST(yyvsp[-1].opval); }
break;
-case 98:
-#line 386 "perly.y"
+case 106:
+#line 431 "perly.y"
{ yyval.opval = newANONLIST(Nullop); }
break;
-case 99:
-#line 388 "perly.y"
+case 107:
+#line 433 "perly.y"
{ yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
-case 100:
-#line 390 "perly.y"
+case 108:
+#line 435 "perly.y"
{ yyval.opval = newANONHASH(Nullop); }
break;
-case 101:
-#line 392 "perly.y"
+case 109:
+#line 437 "perly.y"
{ yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
-case 102:
-#line 394 "perly.y"
+case 110:
+#line 439 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 103:
-#line 396 "perly.y"
+case 111:
+#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 112:
+#line 443 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 105:
-#line 400 "perly.y"
+case 113:
+#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 114:
+#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 115:
+#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 116:
+#line 455 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 109:
-#line 412 "perly.y"
+case 117:
+#line 457 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 110:
-#line 414 "perly.y"
+case 118:
+#line 459 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
-case 111:
-#line 416 "perly.y"
+case 119:
+#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 120:
+#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 121:
+#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 122:
+#line 474 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
-case 115:
-#line 431 "perly.y"
+case 123:
+#line 476 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
-case 116:
-#line 433 "perly.y"
+case 124:
+#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 125:
+#line 484 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
@@ -2057,38 +2064,38 @@ case 117:
ref(oopsHV(yyvsp[-4].opval), OP_HSLICE)));
expect = XOPERATOR; }
break;
-case 118:
-#line 446 "perly.y"
+case 126:
+#line 491 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 119:
-#line 448 "perly.y"
+case 127:
+#line 493 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
break;
-case 120:
-#line 450 "perly.y"
+case 128:
+#line 495 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
-case 121:
-#line 452 "perly.y"
+case 129:
+#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 130:
+#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 131:
+#line 503 "perly.y"
{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); }
break;
-case 124:
-#line 460 "perly.y"
+case 132:
+#line 505 "perly.y"
{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
break;
-case 125:
-#line 462 "perly.y"
+case 133:
+#line 507 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
@@ -2097,8 +2104,8 @@ case 125:
scalar(yyvsp[-2].opval)
)),Nullop)); dep();}
break;
-case 126:
-#line 470 "perly.y"
+case 134:
+#line 515 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
append_elem(OP_LIST,
@@ -2108,139 +2115,151 @@ case 126:
scalar(yyvsp[-3].opval)
)))); dep();}
break;
-case 127:
-#line 479 "perly.y"
+case 135:
+#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 136:
+#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 137:
+#line 533 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
hints |= HINT_BLOCK_SCOPE; }
break;
-case 130:
-#line 491 "perly.y"
+case 138:
+#line 536 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
-case 131:
-#line 493 "perly.y"
+case 139:
+#line 538 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
-case 132:
-#line 495 "perly.y"
+case 140:
+#line 540 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
-case 133:
-#line 497 "perly.y"
+case 141:
+#line 542 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 134:
-#line 499 "perly.y"
+case 142:
+#line 544 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 135:
-#line 501 "perly.y"
+case 143:
+#line 546 "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 144:
+#line 549 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
-case 137:
-#line 506 "perly.y"
+case 145:
+#line 551 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
-case 138:
-#line 508 "perly.y"
+case 146:
+#line 553 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0,
scalar(yyvsp[0].opval)); }
break;
-case 139:
-#line 511 "perly.y"
+case 147:
+#line 556 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
-case 140:
-#line 513 "perly.y"
+case 148:
+#line 558 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
-case 141:
-#line 515 "perly.y"
+case 149:
+#line 560 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
-case 142:
-#line 517 "perly.y"
+case 150:
+#line 562 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
-case 145:
-#line 523 "perly.y"
+case 153:
+#line 568 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 146:
-#line 525 "perly.y"
+case 154:
+#line 570 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 147:
-#line 529 "perly.y"
+case 155:
+#line 574 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 148:
-#line 531 "perly.y"
+case 156:
+#line 576 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 149:
-#line 533 "perly.y"
+case 157:
+#line 578 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
-case 150:
-#line 537 "perly.y"
+case 158:
+#line 581 "perly.y"
+{ yyval.ival = 0; }
+break;
+case 159:
+#line 582 "perly.y"
+{ yyval.ival = 1; }
+break;
+case 160:
+#line 586 "perly.y"
+{ in_my = 0; yyval.opval = my(yyvsp[0].opval); }
+break;
+case 161:
+#line 590 "perly.y"
{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
break;
-case 151:
-#line 541 "perly.y"
+case 162:
+#line 594 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
-case 152:
-#line 545 "perly.y"
+case 163:
+#line 598 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
-case 153:
-#line 549 "perly.y"
+case 164:
+#line 602 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
-case 154:
-#line 553 "perly.y"
+case 165:
+#line 606 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
-case 155:
-#line 557 "perly.y"
+case 166:
+#line 610 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
-case 156:
-#line 561 "perly.y"
+case 167:
+#line 614 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
-case 157:
-#line 563 "perly.y"
+case 168:
+#line 616 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
-case 158:
-#line 565 "perly.y"
+case 169:
+#line 618 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
-case 159:
-#line 568 "perly.y"
+case 170:
+#line 621 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-#line 2230 "y.tab.c"
+#line 2249 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
@@ -2250,7 +2269,7 @@ break;
{
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log,
+ PerlIO_printf(Perl_debug_log,
"yydebug: after reduction, shifting from state 0 to state %d\n",
YYFINAL);
#endif
@@ -2266,7 +2285,7 @@ break;
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
#endif
@@ -2281,7 +2300,7 @@ break;
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log,
+ PerlIO_printf(Perl_debug_log,
"yydebug: after reduction, shifting from state %d to state %d\n",
*yyssp, yystate);
#endif
diff --git a/perly.c.diff b/perly.c.diff
index 61b4cffd7c..a3472508b8 100644
--- a/perly.c.diff
+++ b/perly.c.diff
@@ -1,82 +1,84 @@
-*** perly.c.orig Sun Jul 7 23:27:45 1996
---- perly.c Sun Jul 7 23:27:46 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 ----
***************
-*** 1375,1387 ****
- int yynerrs;
+*** 1337,1347 ****
int yyerrflag;
int yychar;
- short *yyssp;
@@ -86,14 +88,12 @@
- short yyss[YYSTACKSIZE];
- YYSTYPE yyvs[YYSTACKSIZE];
- #define yystacksize YYSTACKSIZE
- #line 571 "perly.y"
+ #line 624 "perly.y"
/* PROGRAM */
- #line 1388 "y.tab.c"
---- 1310,1317 ----
+--- 1272,1277 ----
***************
-*** 1388,1401 ****
---- 1318,1376 ----
- #define YYABORT goto yyabort
+*** 1350,1361 ****
+--- 1280,1336 ----
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
+
@@ -113,15 +113,15 @@
+ void* ptr;
+ {
+ struct ysv* ysave = (struct ysv*)ptr;
-+ if (ysave->yyss) safefree((char *)ysave->yyss);
-+ if (ysave->yyvs) safefree((char *)ysave->yyvs);
++ if (ysave->yyss) Safefree(ysave->yyss);
++ if (ysave->yyvs) Safefree(ysave->yyvs);
+ yydebug = ysave->oldyydebug;
+ yynerrs = ysave->oldyynerrs;
+ yyerrflag = ysave->oldyyerrflag;
+ yychar = ysave->oldyychar;
+ yyval = ysave->oldyyval;
+ yylval = ysave->oldyylval;
-+ safefree((char *)ysave);
++ Safefree(ysave);
+ }
+
int
@@ -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;
***************
-*** 1408,1413 ****
---- 1383,1396 ----
- yyerrflag = 0;
+*** 1370,1373 ****
+--- 1345,1356 ----
yychar = (-1);
+ /*
@@ -168,27 +166,21 @@
+
yyssp = yyss;
yyvsp = yyvs;
- *yyssp = yystate = 0;
***************
-*** 1423,1429 ****
- yys = 0;
+*** 1385,1389 ****
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! printf("yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
- #endif
---- 1406,1412 ----
- yys = 0;
+--- 1368,1372 ----
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
- #endif
***************
-*** 1433,1444 ****
- {
+*** 1395,1404 ****
#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;
---- 1416,1441 ----
- {
+--- 1378,1401 ----
#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;
***************
-*** 1474,1485 ****
- {
+*** 1436,1445 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: state %d, error recovery shifting\
@@ -240,9 +228,7 @@
! goto yyoverflow;
}
*++yyssp = yystate = yytable[yyn];
- *++yyvsp = yylval;
---- 1471,1497 ----
- {
+--- 1433,1457 ----
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
@@ -268,19 +254,15 @@
! yyvsp = yyvs + yypv_index;
}
*++yyssp = yystate = yytable[yyn];
- *++yyvsp = yylval;
***************
-*** 1489,1496 ****
- {
+*** 1451,1456 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: error recovery discarding state %d\n",
! *yyssp);
#endif
if (yyssp <= yyss) goto yyabort;
- --yyssp;
---- 1501,1509 ----
- {
+--- 1463,1469 ----
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
@@ -288,19 +270,15 @@
! *yyssp);
#endif
if (yyssp <= yyss) goto yyabort;
- --yyssp;
***************
-*** 1507,1514 ****
- yys = 0;
+*** 1469,1474 ****
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);
---- 1520,1528 ----
- yys = 0;
+--- 1482,1488 ----
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(stderr,
@@ -308,36 +286,28 @@
! yystate, yychar, yys);
}
#endif
- yychar = (-1);
***************
-*** 1517,1523 ****
- yyreduce:
+*** 1479,1483 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
- yym = yylen[yyn];
---- 1531,1537 ----
- yyreduce:
+--- 1493,1497 ----
#if YYDEBUG
if (yydebug)
! fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
- yym = yylen[yyn];
***************
-*** 2236,2243 ****
- {
+*** 2256,2261 ****
#if YYDEBUG
if (yydebug)
! printf("yydebug: after reduction, shifting from state 0 to\
! state %d\n", YYFINAL);
#endif
yystate = YYFINAL;
- *++yyssp = YYFINAL;
---- 2250,2258 ----
- {
+--- 2270,2276 ----
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
@@ -345,27 +315,21 @@
! YYFINAL);
#endif
yystate = YYFINAL;
- *++yyssp = YYFINAL;
***************
-*** 2251,2257 ****
- yys = 0;
+*** 2271,2275 ****
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! printf("yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
- #endif
---- 2266,2272 ----
- yys = 0;
+--- 2286,2290 ----
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
- #endif
***************
-*** 2266,2285 ****
- yystate = yydgoto[yym];
+*** 2286,2295 ****
#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);
- }
---- 2281,2315 ----
- yystate = yydgoto[yym];
+--- 2301,2325 ----
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
@@ -412,7 +366,17 @@
! yyvsp = yyvs + yypv_index;
}
*++yyssp = yystate;
- *++yyvsp = yyval;
+***************
+*** 2297,2304 ****
+ goto yyloop;
+ yyoverflow:
+! yyerror("yacc stack overflow");
+ yyabort:
+! return (1);
+ yyaccept:
+! return (0);
+ }
+--- 2327,2334 ----
goto yyloop;
yyoverflow:
! yyerror("Out of memory for yacc stack");
diff --git a/perly.h b/perly.h
index 43f9d04978..9907727001 100644
--- a/perly.h
+++ b/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;
@@ -62,3 +63,4 @@ typedef union {
GV *gvval;
} YYSTYPE;
extern YYSTYPE yylval;
+extern YYSTYPE yylval;
diff --git a/perly.y b/perly.y
index 57c9630f0b..5ee78f8210 100644
--- a/perly.y
+++ b/perly.y
@@ -41,22 +41,23 @@ 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 remember mremember '&'
+%type <opval> block mblock lineseq line loop cond else
%type <opval> expr term scalar ary hsh arylen star amper sideff
+%type <opval> argexpr nexpr texpr iexpr mexpr mnexpr mtexpr miexpr
%type <opval> listexpr listexprcom indirob
-%type <opval> texpr listop method proto
+%type <opval> listop method proto 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 +68,7 @@ dep()
%left <ival> BITANDOP
%nonassoc EQOP
%nonassoc RELOP
-%nonassoc <ival> UNIOP
+%nonassoc UNIOP UNIOPSUB
%left <ival> SHIFTOP
%left ADDOP
%left MULOP
@@ -92,11 +93,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,28 +150,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
+cond : IF '(' remember mexpr ')' mblock else
{ copline = $1;
- $$ = newCONDOP(0, $3, scope($5), $6); }
- | UNLESS '(' expr ')' block else
+ $$ = block_end($3,
+ newCONDOP(0, $4, scope($6), $7)); }
+ | UNLESS '(' remember miexpr ')' mblock else
{ copline = $1;
- $$ = newCONDOP(0,
- invert(scalar($3)), scope($5), $6); }
+ $$ = block_end($3,
+ newCONDOP(0, $4, scope($6), $7)); }
| IF block block else
{ copline = $1;
deprecate("if BLOCK BLOCK");
@@ -176,39 +190,50 @@ cont : /* NULL */
{ $$ = scope($2); }
;
-loop : label WHILE '(' texpr ')' block cont
+loop : label WHILE '(' remember mtexpr ')' mblock cont
{ copline = $2;
- $$ = newSTATEOP(0, $1,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- $4, $6, $7) ); }
- | label UNTIL '(' expr ')' block cont
+ $$ = block_end($4,
+ newSTATEOP(0, $1,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ $5, $7, $8))); }
+ | label UNTIL '(' remember miexpr ')' mblock cont
{ copline = $2;
- $$ = newSTATEOP(0, $1,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- invert(scalar($4)), $6, $7) ); }
+ $$ = block_end($4,
+ newSTATEOP(0, $1,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ $5, $7, $8))); }
| label WHILE block block cont
{ copline = $2;
+ deprecate("while BLOCK BLOCK");
$$ = newSTATEOP(0, $1,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- scope($3), $4, $5) ); }
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ scope($3), $4, $5)); }
| label UNTIL block block cont
{ copline = $2;
+ deprecate("until BLOCK BLOCK");
$$ = 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
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ invert(scalar(scope($3))),
+ $4, $5)); }
+ | 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,
- newWHILEOP(0, 1, (LOOP*)Nullop,
- scalar($6), $10, scalar($8)) )); }
+ { copline = $2;
+ $$ = block_end($4,
+ append_elem(OP_LINESEQ, scalar($5),
+ newSTATEOP(0, $1,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ scalar($7),
+ $11, scalar($9))))); }
| label block cont /* a block is a loop that happens once */
{ $$ = newSTATEOP(0,
$1, newWHILEOP(0, 1, (LOOP*)Nullop,
@@ -225,6 +250,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
@@ -294,7 +339,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,
@@ -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); }
@@ -533,6 +578,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/plan9/buildinfo b/plan9/buildinfo
index 52bc5a1709..4fcbae698f 100644
--- a/plan9/buildinfo
+++ b/plan9/buildinfo
@@ -1 +1 @@
-p9pvers = 5.00301
+p9pvers = 5.003_08
diff --git a/plan9/config.plan9 b/plan9/config.plan9
index d59a75933b..b10c75852f 100644
--- a/plan9/config.plan9
+++ b/plan9/config.plan9
@@ -1,22 +1,14 @@
-/* This file (config_H) is a sample config.h file. If you are unable
- to successfully run Configure, copy this file to config.h and
- edit it to suit your system.
-*/
/*
- * This file was produced by running the config_h.SH script, which
- * gets its values from config.sh, which is generally produced by
- * running Configure.
- *
- * Feel free to modify any of this as the need arises. Note, however,
- * that running config_h.SH again will wipe out any changes you've made.
- * For a more permanent change edit config.sh and rerun config_h.SH.
- *
- * $Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $
- */
+ * 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: Thu Feb 8 17:15:11 EST 1996
- * Configured by: doughera
- * Target system: sunos fractal 5.4 generic_101946-29 i86pc i386
+/* Configuration time: 21-Oct-1996 15:11
+ * Configured by: Luther Huffman, lutherh@stratcom.com
+ * Target system: Plan 9
*/
#ifndef _config_h_
@@ -43,7 +35,15 @@
* This symbol contains the number of bytes required to align a
* double. Usual values are 2, 4 and 8.
*/
-#define MEM_ALIGNBYTES 8 /* config-skip */
+#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
@@ -117,9 +117,9 @@
* 2 = couldn't cast >= 0x80000000
* 4 = couldn't cast in argument expression list
*/
-#define CASTNEGFLOAT /**/
+#undef CASTNEGFLOAT /**/
#if _P9P_OBJTYPE == 386
-# define CASTFLAGS 2 /**/ /* config-skip */
+# define CASTFLAGS 3 /**/ /* config-skip */
#else
# define CASTFLAGS 0 /**/ /* config-skip */
#endif
@@ -273,7 +273,12 @@
* 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)
@@ -586,8 +591,14 @@
* 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)
@@ -748,6 +759,15 @@
#define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
#endif
+/* FILE_filbuf:
+ * This macro is used to access the internal stdio _filbuf function
+ * (or equivalent), if STDIO_CNT_LVALUE and STDIO_PTR_LVALUE
+ * are defined. It is typically either _filbuf or __filbuf.
+ * This macro will only be defined if both STDIO_CNT_LVALUE and
+ * STDIO_PTR_LVALUE are defined.
+ */
+#undef FILE_filbuf
+
/* HAS_STRCHR:
* This symbol is defined to indicate that the strchr()/strrchr()
* functions are available for string searching. If not, try the
@@ -1305,7 +1325,7 @@
#define OSNAME "plan9"
-#define BIN_SH "/bin/rc"
+#define BIN_SH "/bin/rc" /* config-skip */
/* MYMALLOC:
* This symbol, if defined, indicates that we're using our own malloc.
@@ -1313,7 +1333,7 @@
#undef MYMALLOC /**/
-#undef VMS
+#undef VMS /* config-skip */
/* LOC_SED:
* This symbol holds the complete pathname to the sed program.
@@ -1325,12 +1345,17 @@
* 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"
/* BYTEORDER:
* This symbol hold the hexadecimal constant defined in byteorder,
* i.e. 0x1234 or 0x4321, etc...
*/
-#define BYTEORDER 0x1234 /* large digits for MSB */
+#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.
@@ -1488,12 +1513,14 @@
* 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
@@ -1531,12 +1558,14 @@
* 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
@@ -1545,6 +1574,54 @@
*/
#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:
diff --git a/plan9/exclude b/plan9/exclude
index 5b52d96d24..7d9fc3c8af 100644
--- a/plan9/exclude
+++ b/plan9/exclude
@@ -1,29 +1,18 @@
comp/cpp.t
-comp/script.t
-io/argv.t
io/dup.t
io/fs.t
-io/inplace.t
-io/pipe.t
lib/anydbm.t
-lib/dirhand.t
-lib/filehand.t
+lib/complex.t
+lib/filefind.t
lib/io_dup.t
lib/io_pipe.t
lib/io_sock.t
-lib/io_tell.t
lib/io_udp.t
lib/posix.t
-lib/safe1.t
-lib/safe2.t
lib/socket.t
-op/eval.t
op/exec.t
op/goto.t
-op/magic.t
op/misc.t
op/oct.t
-op/readdir.t
op/split.t
op/stat.t
-op/tie.t
diff --git a/plan9/fndvers b/plan9/fndvers
index c45c42bdf9..a848de2b6d 100644
--- a/plan9/fndvers
+++ b/plan9/fndvers
@@ -2,8 +2,13 @@
. plan9/buildinfo
-ed config.plan9 <<!
+ed plan9/config.plan9 <<!
g/_P9P_VERSION/s//$p9pvers/g
g/_P9P_OBJTYPE/s//$objtype/g
-w $1
+w config.h
+!
+
+ed plan9/genconfig.pl<<!
+g/_P9P_VERSION/s//$p9pvers/g
+w plan9/genconfig.pl
!
diff --git a/plan9/genconfig.pl b/plan9/genconfig.pl
index 2ab6295884..c23bd885b6 100644
--- a/plan9/genconfig.pl
+++ b/plan9/genconfig.pl
@@ -10,7 +10,7 @@
#
#==== Locations of installed Perl components
-$p9pvers="5.00301";
+$p9pvers="_P9P_VERSION";
$prefix='';
$p9p_objtype=$ENV{'objtype'};
$builddir="/sys/src/cmd/perl/$p9pvers";
@@ -82,7 +82,6 @@ eunicefix=':'
hint='none'
hintfile=''
intsize='4'
-alignbytes='8'
shrplib='define'
usemymalloc='n'
usevfork='true'
@@ -127,24 +126,26 @@ 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';
-}
-print OUT "obj_ext='$objext'\n";
-
-if ($p9p_objtype eq '386') {
- $cstflags = 2;
-}
-else {
+ $alignbytes = '4';
$cstflags = 0;
}
+print OUT "obj_ext='$objext'\n";
+print OUT "alignbytes='$alignbytes'\n";
print OUT "castflags='$cstflags'\n";
$myname = $ENV{'site'} ;
diff --git a/plan9/mkfile b/plan9/mkfile
index 65568b2b16..938b8e6a6d 100644
--- a/plan9/mkfile
+++ b/plan9/mkfile
@@ -1,6 +1,3 @@
-Content-type: text/plain; charset="us-ascii"
-Content-disposition: attachment; filename="mkfile"
-
APE=/sys/src/ape
< $APE/config
<plan9/buildinfo
@@ -11,7 +8,7 @@ archlib = /$objtype/lib/perl/$p9pvers
sitelib = $privlib/site_perl
sitearch = $archlib/site_perl
-CFLAGS = -B -D_POSIX_SOURCE -D_BSD_EXTENSION -DNO_EMBED
+CFLAGS = -B -D_POSIX_SOURCE -D_BSD_EXTENSION -DMY_UV_MAX=0x7fffffffUL
LDFLAGS = -B
CCCMD = $CC -c $CFLAGS
@@ -34,7 +31,7 @@ ext_xs = IO.xs Socket.xs Opcode.xs dl_none.xs Fcntl.xs FileHandle.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
+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
@@ -42,7 +39,8 @@ 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/aperl
+ 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
@@ -68,8 +66,8 @@ perlmain.$O: config.h perlmain.c
perlmain.c: miniperl vms/writemain.pl
./miniperl vms/writemain.pl $extensions
-config.h: config.plan9 plan9/fndvers
- plan9/fndvers config.h
+config.h: plan9/fndvers
+ plan9/fndvers
cp config.h $archlib/CORE
$perlshr(%):N: %
@@ -80,8 +78,10 @@ $perlshr: ${ext_obj:%=$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
+ 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
@@ -139,11 +139,9 @@ man:V: $perlpods pod/pod2man.PL perl
for (i in $podnames) pod/pod2man pod/$i.pod > $installman3dir/$i
pod/pod2man plan9/perlplan9.pod > $installman3dir/perlplan9
-nuke:V:
+nuke clean:V:
rm -f *.$O $extensions^.pm config.sh $perllib config.h $perlshr perlmain.c perl miniperl $archlib/Config.pm $ext_c
-
-clean:V:
- rm -f *.$O config.sh miniperl t/perl
+ rm -rf $privlib/IO
deleteman:V:
rm -f $installman1dir/perl* $installman3dir/perl*
diff --git a/plan9/perlplan9.doc b/plan9/perlplan9.doc
index 4f7a057749..d6d7df8b74 100644
--- a/plan9/perlplan9.doc
+++ b/plan9/perlplan9.doc
@@ -1,5 +1,5 @@
- PERLTEST/PLAN9/PERLPLAN9(1) (perl ) PERLTEST/PLAN9/PERLPLAN9(1)
+ PLAN9/PERLPLAN9(1) (perl 5.003, patch 05) PLAN9/PERLPLAN9(1)
NNNNAAAAMMMMEEEE
perlplan9 - Plan 9-specific documentation for Perl
@@ -22,7 +22,7 @@
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
- "aperl" instead of "perl". This will produce Acme-friendly
+ "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
@@ -34,8 +34,8 @@
Although Plan 9 Perl currently only provides static
loading, it is built with a number of useful extensions.
- These include Safe, FileHandle, Fcntl, and POSIX. Expect to
- see others (and DynaLoading!) in the future.
+ These include Opcode, FileHandle, Fcntl, and POSIX. Expect
+ to see others (and DynaLoading!) in the future.
WWWWhhhhaaaatttt''''ssss nnnnooootttt iiiinnnn PPPPllllaaaannnn 9999 PPPPeeeerrrrllll
@@ -52,9 +52,9 @@
The functions not currently implemented include:
- Page 1 4/Jul/96 (printed 7/4/96)
+ Page 1 9/Oct/96 (printed 10/9/96)
- PERLTEST/PLAN9/PERLPLAN9(1) (perl ) PERLTEST/PLAN9/PERLPLAN9(1)
+ PLAN9/PERLPLAN9(1) (perl 5.003, patch 05) PLAN9/PERLPLAN9(1)
chown, chroot, dbmclose, dbmopen, getsockopt,
setsockopt, recvmsg, sendmsg, getnetbyname,
@@ -82,10 +82,10 @@
the world . . ." - Carl Sagan
RRRReeeevvvviiiissssiiiioooonnnn ddddaaaatttteeee
- This document was revised 04-July-1996 for Perl 5.003_1.
+ This document was revised 09-October-1996 for Perl 5.003_7.
AAAAUUUUTTTTHHHHOOOORRRR
Luther Huffman, lutherh@stratcom.com
- Page 2 4/Jul/96 (printed 7/4/96)
+ Page 2 9/Oct/96 (printed 10/9/96)
diff --git a/plan9/perlplan9.pod b/plan9/perlplan9.pod
index 9f13f06e7e..fb58149440 100644
--- a/plan9/perlplan9.pod
+++ b/plan9/perlplan9.pod
@@ -21,7 +21,7 @@ such as "#!/usr/local/bin/perl". This is known as a shebang
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 "aperl"
+ Alternatively, you may invoke perl with the command "Perl"
instead of "perl". This will produce Acme-friendly error
messages of the form "filename:18".
@@ -34,7 +34,7 @@ Perl. These you won't need to be worried about.
Although Plan 9 Perl currently only provides static
loading, it is built with a number of useful extensions.
-These include Safe, FileHandle, Fcntl, and POSIX. Expect
+These include Opcode, FileHandle, Fcntl, and POSIX. Expect
to see others (and DynaLoading!) in the future.
=head2 What's not in Plan 9 Perl
@@ -80,7 +80,7 @@ world . . ." - Carl Sagan
=head1 Revision date
-This document was revised 04-July-1996 for Perl 5.003_1.
+This document was revised 09-October-1996 for Perl 5.003_7.
=head1 AUTHOR
diff --git a/plan9/setup.rc b/plan9/setup.rc
index c6ebe86fc8..dd96c1f9c7 100644
--- a/plan9/setup.rc
+++ b/plan9/setup.rc
@@ -6,10 +6,14 @@
# 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(flag a) platforms = (386 mips sparc 68020)
-if not platforms = $objtype
+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
@@ -21,7 +25,6 @@ if (test ! -d $sourcedir) mkdir $sourcedir
#Populate source directory
echo Building source directories ...
{cd $builddir ; tar c .} | { cd $sourcedir ; tar x}
-cp $builddir/plan9/config.plan9 $sourcedir/config.plan9
cp $builddir/plan9/plan9.c $builddir/plan9/plan9ish.h $builddir/plan9/mkfile $sourcedir
cd $sourcedir/lib ; rm -rf *
diff --git a/plan9/versnum b/plan9/versnum
new file mode 100644
index 0000000000..83e46826c3
--- /dev/null
+++ b/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/pod/Makefile b/pod/Makefile
index bfe6c8edad..564a63a192 100644
--- a/pod/Makefile
+++ b/pod/Makefile
@@ -1,10 +1,11 @@
-CONVERTERS = pod2html pod2latex pod2man pod2text
+CONVERTERS = pod2html pod2latex pod2man pod2text checkpods
all: $(CONVERTERS) man
PERL = ../miniperl
POD = \
perl.pod \
+ perlapio.pod \
perlbook.pod \
perlbot.pod \
perlcall.pod \
@@ -16,6 +17,7 @@ POD = \
perlform.pod \
perlfunc.pod \
perlguts.pod \
+ perli18n.pod \
perlipc.pod \
perllol.pod \
perlmod.pod \
@@ -39,6 +41,7 @@ POD = \
MAN = \
perl.man \
+ perlapio.man \
perlbook.man \
perlbot.man \
perlcall.man \
@@ -50,6 +53,7 @@ MAN = \
perlform.man \
perlfunc.man \
perlguts.man \
+ perli18n.man \
perlipc.man \
perllol.man \
perlmod.man \
@@ -73,6 +77,7 @@ MAN = \
HTML = \
perl.html \
+ perlapio.html \
perlbook.html \
perlbot.html \
perlcall.html \
@@ -84,6 +89,7 @@ HTML = \
perlform.html \
perlfunc.html \
perlguts.html \
+ perli18n.html \
perlipc.html \
perllol.html \
perlmod.html \
@@ -107,6 +113,7 @@ HTML = \
TEX = \
perl.tex \
+ perlapio.tex \
perlbook.tex \
perlbot.tex \
perlcall.tex \
@@ -118,6 +125,7 @@ TEX = \
perlform.tex \
perlfunc.tex \
perlguts.tex \
+ perli18n.tex \
perlipc.tex \
perllol.tex \
perlmod.tex \
@@ -180,6 +188,10 @@ realclean: clean
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 +204,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/pod/buildtoc b/pod/buildtoc
index 9ca5e920fd..daf26c1c57 100644
--- a/pod/buildtoc
+++ b/pod/buildtoc
@@ -2,11 +2,13 @@ use File::Find;
use Cwd;
@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
+ perl
+ perldata perlsyn perlop perlre perlrun perlfunc perlvar
+ perlsub perlmod perlform
+ perlref perldsc perllol perlobj perltie perlbot perlipc
+ perldebug perldiag perlsec perltrap perlstyle
+ perlpod perlbook
+ perlembed perlapio perlxs perlxstut perlguts perlcall
};
for (@pods) { s/$/.pod/ }
@@ -100,7 +102,7 @@ podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
=head1 AUXILIARY DOCUMENTATION
- Here should be listed all the extra program's docs, but they
+ Here should be listed all the extra programs' docs, but they
don't all have man pages yet:
=item a2p
@@ -124,7 +126,7 @@ podset( @modules[ sort { $modname[$a] cmp $modname[$b] } 0 .. $#modules ] );
=head1 AUTHOR
- Larry Wall E<lt>F<lwall\@sems.com>E<gt>, with the help of oodles
+ Larry Wall E<lt>F<larry\@wall.org>E<gt>, with the help of oodles
of other folks.
diff --git a/pod/checkpods.PL b/pod/checkpods.PL
new file mode 100644
index 0000000000..5265a19808
--- /dev/null
+++ b/pod/checkpods.PL
@@ -0,0 +1,74 @@
+#!/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)) =~ s/\.PL$//;
+$file =~ s/\.pl$//
+ if ($Config{'osname'} eq 'VMS' or
+ $Config{'osname'} eq 'OS2'); # "case-forgiving"
+
+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+$/;
+ close(ARGV) if eof;
+}
+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/pod/perl.pod b/pod/perl.pod
index 725f473d8d..e43424f26b 100644
--- a/pod/perl.pod
+++ b/pod/perl.pod
@@ -19,7 +19,8 @@ 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
+ perlnews Perl news about changes from previous version
+
perldata Perl data structures
perlsyn Perl syntax
perlop Perl operators and precedence
@@ -29,26 +30,33 @@ of sections:
perlvar Perl predefined variables
perlsub Perl subroutines
perlmod Perl modules
+ 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 how to embed perl in your C or C++ app
+ perlapio Perl internal IO abstraction interface
perlxs Perl XS application programming interface
perlxstut Perl XS tutorial
perlguts Perl internal functions for those doing extensions
perlcall Perl calling conventions from C
- 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.)
@@ -59,10 +67,10 @@ 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:
- perl -le 'use Config; print "@Config{man1dir,man3dir}"'
+ perl -V:man.dir
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
+you would need to add only F</usr/local/man> to your MANPATH. If
they are different, you'll have to add both stems.
If that doesn't work for some reason, you can still use the
@@ -75,7 +83,7 @@ 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
@@ -131,7 +139,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 +168,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,7 +193,7 @@ 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
@@ -194,6 +203,18 @@ with embedded whitespace and comments for readability. A consistent
extensibility mechanism has been added that is upwardly compatible with
all old regular expressions.
+=item * Innumerable Unbundled Modules
+
+The Comprehensive Perl Archive Network described in L<perlmod>
+contains hundreds of plug-and-play modules full of reusable
+code. See F<http://www.perl.com/CPAN> for a site near you.
+
+=item * Compilability
+
+While not yet in full production mode, a working perl-to-C compiler
+does exist. It can generate portable bytecode, simple C, or
+optimized C code.
+
=back
Ok, that's I<definitely> enough hype.
@@ -232,6 +253,12 @@ The command used to get the debugger code. If unset, uses
BEGIN { require 'perl5db.pl' }
+=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.
+
=item PERLLIB
A colon-separated list of directories in which to look for Perl library
@@ -240,6 +267,9 @@ directory. If PERL5LIB is defined, PERLLIB is not used.
=back
+Perl also has environment variables that control how Perl handles
+language-specific data. Please consult the L<perli18n> section.
+
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
@@ -252,12 +282,12 @@ honest:
=head1 AUTHOR
-Larry Wall E<lt>F<lwall@sems.com>E<gt>, with the help of oodles of other folks.
+Larry Wall E<lt>F<larry@wall.org>E<gt>, with the help of oodles of other folks.
=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 +317,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 sprintf(). The latter
+can even trigger a core dump when passed ludicrous input values.
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()
@@ -300,9 +330,9 @@ 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
+See the perl bugs database at F<http://www.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
+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/pod/perlapio.pod b/pod/perlapio.pod
new file mode 100644
index 0000000000..ae67494ce2
--- /dev/null
+++ b/pod/perlapio.pod
@@ -0,0 +1,274 @@
+=head1 NAME
+
+perlio - 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 *);
+ FILE *PerlIO_exportFILE(PerlIO *);
+ 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(s,f)>, B<PerlIO_putc(c,f)>
+
+These correspond to fputs() and fputc().
+Note that arguments have been revised to have "file" first.
+
+=item B<PerlIO_ungetc(c,f)>
+
+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/pod/perlbook.pod b/pod/perlbook.pod
index 5bb4bfb0b5..f52046b5e0 100644
--- a/pod/perlbook.pod
+++ b/pod/perlbook.pod
@@ -5,18 +5,27 @@ 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.
+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.
- Programming Perl (the Camel Book):
- ISBN 0-937175-64-1 (English)
- ISBN 4-89052-384-7 (Japanese)
+I<Programming Perl, Second Edition> is a reference work that covers
+nearly all of Perl, while I<Learning Perl> 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.
+
+ Programming Perl, Second Edition (the Camel Book):
+ ISBN 1-56592-149-6 (English)
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)
+
+ Perl 5 Desktop Reference (the reference card):
+
+ ISBN 1-56592-187-9 (brief English)
diff --git a/pod/perlbot.pod b/pod/perlbot.pod
index 0f7078f197..30d00558b4 100644
--- a/pod/perlbot.pod
+++ b/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.
@@ -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;
diff --git a/pod/perlcall.pod b/pod/perlcall.pod
index 996c9145d0..20c863cc57 100644
--- a/pod/perlcall.pod
+++ b/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>
@@ -131,26 +131,26 @@ OR'ed together.
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.
@@ -171,27 +171,27 @@ context> shows an example of this behaviour.
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 +208,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.
@@ -254,7 +254,7 @@ belongs to C<joe>.
=head2 G_EVAL
It is possible for the Perl subroutine you are calling to terminate
-abnormally, e.g. by calling I<die> explicitly or by not actually
+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 +265,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
@@ -408,7 +408,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 +458,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 +529,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 +555,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 +565,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 the L<perlguts/"XSUBs and the Argument Stack"> for details
on how the XPUSH macros work.
=item 6.
@@ -580,7 +580,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 +589,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
@@ -685,7 +685,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.
@@ -998,7 +998,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>.
@@ -1026,7 +1026,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.
@@ -1064,7 +1064,7 @@ Here is a snippet of XSUB which defines I<CallSubPV>.
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,
+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 +1079,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 +1092,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 ;
@@ -1135,7 +1135,7 @@ Similarly, with this code
$ref = 47 ;
CallSavedSub1() ;
-you can expect one of these messages (which you actually get is dependant on
+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 ...
@@ -1143,7 +1143,7 @@ the version of Perl you are using)
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
@@ -1185,7 +1185,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 +1247,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.
@@ -1346,7 +1346,7 @@ The output from that will be
=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
@@ -1441,7 +1441,7 @@ 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 +1450,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 +1524,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
@@ -1761,7 +1761,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.
@@ -1889,7 +1889,7 @@ L<perlxs>, L<perlguts>, L<perlembed>
=head1 AUTHOR
-Paul Marquess <pmarquess@bfsec.bt.co.uk>
+Paul Marquess E<lt>F<pmarquess@bfsec.bt.co.uk>E<gt>
Special thanks to the following people who assisted in the creation of
the document.
diff --git a/pod/perldata.pod b/pod/perldata.pod
index a72616ac33..407a25204f 100644
--- a/pod/perldata.pod
+++ b/pod/perldata.pod
@@ -19,9 +19,9 @@ 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, in order to locate the namespace in which to look
+packages, to locate the namespace in which to look
up the final identifier (see L<perlmod/Packages> for details).
-It's possible to substutite for a simple identifier an expression
+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>.
@@ -65,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.
@@ -80,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.)
@@ -103,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
@@ -135,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.
@@ -163,7 +163,7 @@ 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
enough to test it against both numeric 0 and also lexical "0" (although
this will cause B<-w> noises). That's because strings that aren't
-numbers count as 0, just as they do in 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";
@@ -183,7 +183,7 @@ for details on regular expressions.
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
@@ -204,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;
@@ -220,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
@@ -239,14 +239,15 @@ 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.
-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
@@ -254,7 +255,7 @@ on in the script. Variable substitution inside strings is limited to
scalar variables, arrays, and array slices. (In other words,
names beginning with $ or @, followed by an optional bracketed
expression as a subscript.) The following code segment prints out "The
-price is $100."
+price is $Z<>100."
$Price = '$100'; # not interpreted
print "The price is $Price.\n"; # interpreted
@@ -275,16 +276,16 @@ 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
+space, because single quote is a valid (though deprecated) character in
a variable name (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
+may be used only 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
+filehandle may read data from only 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__).
@@ -306,7 +307,7 @@ 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);
@@ -324,17 +325,18 @@ 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.
+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;
The price is $Price.
@@ -430,7 +432,7 @@ put the list in parentheses to avoid ambiguity. Examples:
$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];
@@ -452,7 +454,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:
@@ -511,17 +513,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
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;
@@ -529,7 +533,7 @@ 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;
@@ -539,6 +543,8 @@ This is also the way to create a local filehandle. For example:
}
$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/pod/perldebug.pod b/pod/perldebug.pod
index 32c2ebf78e..5d67ba41a6 100644
--- a/pod/perldebug.pod
+++ b/pod/perldebug.pod
@@ -11,7 +11,7 @@ First of all, have you tried using the B<-w> switch?
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
+source code, set breakpoints, get stack back-traces, 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:
@@ -62,16 +62,18 @@ it's run through your pager, as in
=item p expr
-Same as C<print DB::OUT expr> in the current package. In particular,
-since this is just Perl's own B<print> function, this means that nested
+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.
=item x expr
-Evals its expression in list context and dumps out the result
+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>
@@ -87,13 +89,15 @@ Use C<~pattern> and C<!pattern> for positive and negative regexps.
Nested data structures are printed out in a legible fashion, unlike
the C<print> function.
+The details of printout are governed by multiple C<O>ptions.
+
=item X [vars]
Same as C<V currentpackage [vars]>.
=item T
-Produce a stack backtrace. See below for details on its output.
+Produce a stack back-trace. See below for details on its output.
=item s [expr]
@@ -106,14 +110,14 @@ supplied that includes function calls, it too will be single-stepped.
Next. Executes over subroutine calls, until it reaches the beginning
of the next statement.
-=item <CR>
+=item E<lt>CRE<gt>
Repeat last C<n> or C<s> command.
-=item c [line]
+=item c [line|sub]
Continue, optionally inserting a one-time-only breakpoint
-at the specified line.
+at the specified line or subroutine.
=item l
@@ -162,7 +166,7 @@ Search backwards for pattern; final ? is optional.
=item L
-List all breakpoints and actions for the current file.
+List all breakpoints and actions.
=item S [[!]pattern]
@@ -170,7 +174,7 @@ List subroutine names [not] matching pattern.
=item t
-Toggle trace mode.
+Toggle trace mode (see also C<AutoTrace> C<O>ption).
=item t expr
@@ -194,23 +198,45 @@ Trace through execution of expr. For example:
main::foo((eval 168):2):
main::bar((eval 170):2):
42
- DB<4> q
+
+or, with the C<O>ption C<frame=2> set,
+
+ DB<4> O f=2
+ frame = '2'
+ DB<5> t print foo() * bar()
+ 3: foo() * bar()
+ entering main::foo
+ 2: sub foo { 14 };
+ exited main::foo
+ entering main::bar
+ 2: sub bar { 3 };
+ exited main::bar
+ 42
=item b [line] [condition]
Set a breakpoint. If line is omitted, sets a breakpoint on the line
that is about to be executed. If a condition is specified, it's
evaluated each time the statement is reached and a breakpoint is taken
-only if the condition is true. Breakpoints may only be set on lines
+only if the condition is true. Breakpoints may be set on only lines
that begin an executable statement. Conditions don't use B<if>:
b 237 $x > 30
+ b 237 ++$count237 < 11
b 33 /pattern/i
=item b subname [condition]
Set a breakpoint at the first line of the named subroutine.
+=item b postpone subname [condition]
+
+Set breakpoint at first line of subroutine after it is compiled.
+
+=item b load filename
+
+Set breakpoint at the first executed line of the file.
+
=item d [line]
Delete a breakpoint at the specified line. If line is omitted, deletes
@@ -276,6 +302,41 @@ Program to use for output of pager-piped commands (those
beginning with a C<|> character.) By default,
C<$ENV{PAGER}> will be used.
+=item tkRunning
+
+Run Tk while prompting (with ReadLine).
+
+=item signalLevel, warnLevel, dieLevel
+
+Level of verbosity.
+
+=item AutoTrace
+
+Where to print all the breakable points in the executed program
+(similar to C<t> command, but can be put into C<PERLDB_OPTS>).
+
+=item LineInfo
+
+File or pipe to print line number info to. If it is a
+pipe, 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<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.
+
=back
The following options affect what happens with C<V>, C<X>, and C<x>
@@ -307,26 +368,60 @@ Dump symbol tables of packages.
Change style of string dump.
-=item tkRunning
+=back
-Run Tk while prompting (with ReadLine).
+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:
-=item signalLevel, warnLevel. dieLevel
+ &parse_options("NonStop=1 LineInfo=db.out AutoTrace");
-Level of verbosity.
+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"!)
-=back
+=over 12
-The option C<PrintRet> affects printing of return value after C<r>
-command, The option C<frame> affects printing messages on entry and exit
-from subroutines. If C<frame> is 1, messages are printed on entry only;
-if it's set to more than that, they'll will be printed on exit as well,
-which may be useful if interdispersed with other messages.
+=item C<TTY>
-During startup options are initialized from $ENV{PERLDB_OPTS}.
-You can put additional initialization options C<TTY>, C<noTTY>,
-C<ReadLine>, and C<NonStop> there. Here's an example of using
-the C<$ENV{PERLDB_OPTS}> variable:
+The TTY to use for debugging I/O.
+
+=item noTTY
+
+If set, goes in C<NonStop> mode. On interrupt if TTY is not set uses the
+value of C<noTTY> or "/tmp/perldbtty$$" to find TTY using
+C<Term::Rendezvous>. Current variant is to have the name of TTY in this
+file.
+
+=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 non-interactive 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
@@ -334,20 +429,63 @@ 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.
+be uniquely abbreviated by the first letter (with exception of
+C<Dump*> options).
+
+Other examples may include
+
+ $ PERLDB_OPTS="N f A L=listing" perl -d myprogram
+
+- runs script non-interactively, 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
-See "Debugger Internals" below for more details.
+ $ sleep 1000000
-=item < command
+See L<"Debugger Internals"> below for more details.
-Set an action to happen before every debugger prompt. A multiline
+=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
+=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
-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.
+Add an action (debugger command) to happen before every debugger prompt.
+A multi-line command may be entered by backslashing the newlines.
=item ! number
@@ -374,7 +512,12 @@ 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
@@ -382,6 +525,10 @@ 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.
@@ -419,11 +566,12 @@ or even
DB<<17>>
where that number is the command number, which you'd use to access with
-the built-in B<csh>-like history mechanism, e.g. C<!17> would repeat
+the built-in 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.
+function call that itself also has a breakpoint, or you step into an
+expression via C<s/n/t expression> command.
If you want to enter a multi-line command, such as a subroutine
definition with several statements, you may escape the newline that would
@@ -440,7 +588,7 @@ normally end the debugger command with a backslash. Here's an example:
Note that this business of escaping a newline is specific to interactive
commands typed into the debugger.
-Here's an example of what a stack backtrace might look like:
+Here's an example of what a stack back-trace 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
@@ -459,7 +607,9 @@ but from line 4.
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. From your own Perl code, however, you can
+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:
@@ -472,11 +622,10 @@ having typed the C<t> command.
=head2 Debugger Customization
-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 PERL5DB environment variable to say something like this:
-
- BEGIN { require "myperl5db.pl" }
+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
@@ -487,6 +636,25 @@ like these (the last one is one people expect to be there):
$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
@@ -529,83 +697,131 @@ 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 Internals
+=head2 Debugger support in perl
When you call the B<caller> function from package DB, Perl sets the
C<@DB::args> array to contain the arguments that stack frame was called
-with. It also maintains other magical internal variables, such as
-C<@DB::dbline>, an array of the source code lines for the currently
-selected (with the debugger's C<f> command) file. Perl effectively
-inserts a call to the function C<DB::DB>(I<linenum>) in front of every
-place that can have a breakpoint. Instead of a subroutine call it calls
-C<DB::sub> setting C<$DB::sub> being the called subroutine. It also
-inserts a C<BEGIN {require 'perl5db.pl'}> before the first line.
+with.
-Note that no subroutine call is possible until C<&DB::sub> is defined
-(for subroutines defined outside this file). In fact, the same is
-true if C<$DB::deep> (how many levels of recursion deep into the
-debugger you are) is not defined.
+If perl is run with B<-d> option, the following additional features
+are enabled:
-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.
+=over
-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.
+=item *
-The following options can only be specified at startup. To set them in
-your rc file, call C<&parse_options("optionName=new_value")>.
+Perl inserts the contents of C<$ENV{PERL5DB}> (or C<BEGIN {require
+'perl5db.pl'}> if not present) before the first line of the
+application.
-=over 12
+=item *
-=item TTY
+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)>.
-The TTY to use for debugging I/O.
+=item *
-=item noTTY
+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.
-If set, goes in C<NonStop> mode. On interrupt if TTY is not set uses the
-value of C<noTTY> or "/tmp/perldbtty$$" to find TTY using
-C<Term::Rendezvous>. Current variant is to have the name of TTY in this
-file.
+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 ReadLine
+=item *
-If false, dummy ReadLine is used, so you can debug
-ReadLine applications.
+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 NonStop
+=item *
-If true, no I/O is performed until an interrupt.
+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 LineInfo
+=item *
-File or pipe to print line number info to. If it'sis a
-pipe, then a short, "emacs like" message is used.
+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).
-Example rc file:
+=item *
- &parse_options("NonStop=1 LineInfo=db.out");
- sub afterinit { $trace = 1; }
+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.
-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"!)
+=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 & 1 E<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 no subroutine call is possible until C<&DB::sub> is defined
+(for subroutines outside of package C<DB>). (In fact, for the
+standard debugger the same is true if C<$DB::deep> (how many levels of
+recursion deep into the debugger you can go before a mandatory break)
+is not defined.)
+
+=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
You did try the B<-w> switch, didn't you?
=head1 BUGS
-If your program exit()s or die()s, so too does the debugger.
-
You cannot get the stack frame information or otherwise debug functions
that were not compiled by Perl, such as C or C++ extensions.
If you alter your @_ arguments in a subroutine (such as with B<shift>
-or B<pop>, the stack backtrace will not show the original values.
-
+or B<pop>, the stack back-trace will not show the original values.
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 1b03800702..bbd699faaa 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -16,7 +16,7 @@ desperation):
(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
+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>.
@@ -37,7 +37,7 @@ if you want to localize a package variable.
(S) 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
+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.
@@ -53,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
@@ -110,25 +122,25 @@ before it could possibly have been used.
=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
+of Perl. Check the E<lt>#!E<gt> line, or manually feed your script
into Perl yourself.
=item %s: Expression syntax.
(A) You've accidentally run your script through B<csh> instead
-of Perl. Check the <#!> line, or manually feed your script
+of Perl. Check the E<lt>#!E<gt> line, or manually feed your script
into Perl yourself.
=item %s: Undefined variable.
(A) You've accidentally run your script through B<csh> instead
-of Perl. Check the <#!> line, or manually feed your script
+of Perl. Check the E<lt>#!E<gt> 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 E<lt>#!E<gt> line, or manually feed your script
into Perl yourself.
=item B<-P> not allowed for setuid/setgid script
@@ -162,7 +174,11 @@ 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 MSDOS machine.
+
+=item Allocation too large
+
+(F) You can't allocate more than 2^31+"small amount" bytes.
=item Arg too short for msgsnd
@@ -172,7 +188,7 @@ 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
@@ -210,6 +226,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 non-existent 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()
@@ -231,11 +254,17 @@ 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 use reference as lvalue in substr
+
+(W) You supplied a reference as the first argument to substr() used
+as an lvalue, which is pretty strange. Perhaps you forgot to
+dereference it first. See L<perlfunc/substr>.
+
=item Bad arg length for %s, is %d, should be %d
(F) You passed a buffer of the wrong size to one of msgctl(), semctl() or
shmctl(). In C parlance, the correct sizes are, respectively,
-S<sizeof(struct msqid_ds *)>, S<sizeof(struct semid_ds *)> and
+S<sizeof(struct msqid_ds *)>, S<sizeof(struct semid_ds *)>, and
S<sizeof(struct shmid_ds *)>.
=item Bad associative array
@@ -251,7 +280,13 @@ 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 name after %s::
@@ -282,10 +317,10 @@ 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
+of Perl. Check the E<lt>#!E<gt> line, or manually feed your script
into Perl yourself.
=item BEGIN failed--compilation aborted
@@ -313,7 +348,7 @@ exited by calling exit.
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
+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
@@ -321,7 +356,7 @@ that loops once. See L<perlfunc/last>.
(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
+the same effect though, because the inner curlies will be considered a block
that loops once. See L<perlfunc/last>.
=item Can't "redo" outside a block
@@ -329,7 +364,7 @@ that loops once. See L<perlfunc/last>.
(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
+the same effect though, because the inner curlies will be considered a block
that loops once. See L<perlfunc/last>.
=item Can't bless non-reference value
@@ -375,7 +410,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;
@@ -390,12 +425,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
@@ -404,20 +439,20 @@ 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
(S) The creation of the new file failed for the indicated reason.
-=item Can't do inplace edit without backup
+=item Can't do in-place 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
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.
@@ -449,7 +484,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>.
@@ -461,7 +496,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
@@ -487,7 +522,7 @@ 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.)
@@ -496,6 +531,14 @@ levels, the following is missing its final parenthesis:
(F) A fatal error occurred while trying to fork while opening a pipeline.
+=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 Can't get filespec - stale stat buffer?
(S) A warning peculiar to VMS. This arises because of the difference between
@@ -506,7 +549,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
@@ -527,7 +570,7 @@ 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
@@ -571,16 +614,16 @@ 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
(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
@@ -592,25 +635,25 @@ Usually this is because you don't have read permission for the file.
(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 ">",
+"open2.pl". 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)
@@ -653,7 +696,7 @@ of suidperl.
=item Can't take log of %g
-(F) Logarithms are only defined on positive real numbers.
+(F) Logarithms are defined on only positive real numbers.
=item Can't take sqrt of %g
@@ -672,11 +715,6 @@ redefined subroutine while the old routine is running. Go figure.
(F) You tried to unshift an "unreal" array that can't be unshifted, such
as the main Perl stack.
-=item Can't untie: %d inner references still exist
-
-(F) With "use strict untie" in effect, a copy of the object returned
-from C<tie> (or C<tied>) was still valid when C<untie> was called.
-
=item Can't upgrade that kind of scalar
(P) The internal sv_upgrade routine adds "members" to an SV, making
@@ -693,7 +731,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.
@@ -712,7 +750,7 @@ 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.
@@ -729,7 +767,7 @@ be a defined value. This helps to de-lurk 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.
@@ -745,7 +783,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.
@@ -753,7 +791,7 @@ 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 chmod: mode argument is missing initial 0
@@ -765,7 +803,7 @@ 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.
@@ -804,7 +842,12 @@ 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 Do you need to predeclare %s?
+=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 pre-declare %s?
(S) This is an educated guess made in conjunction with the message "%s
found where operator expected". It often means a subroutine or module
@@ -843,7 +886,7 @@ 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
@@ -855,17 +898,17 @@ case the conversion routines don't handle. Drat.
=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 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
@@ -886,19 +929,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
@@ -990,12 +1035,14 @@ 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 Name "%s::%s" used only once: possible typo
+=item Ill-formed logical name |%s| in prime_env_iter
-(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).
+(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 non-standard names,
+or it may indicate that a logical name table has been corrupted.
=item Illegal division by zero
@@ -1018,7 +1065,7 @@ of the octal number stopped before the 8 or 9.
=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,
@@ -1029,20 +1076,32 @@ 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
+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
@@ -1107,7 +1166,7 @@ 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 somehow point to a valid method. See L<overload>.
=item Might be a runaway multi-line %s string starting on line %d
@@ -1121,8 +1180,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
@@ -1150,7 +1209,7 @@ 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 }
@@ -1179,8 +1238,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
@@ -1189,10 +1255,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
@@ -1235,7 +1301,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
@@ -1244,29 +1310,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
+whither 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
@@ -1313,7 +1379,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>.
@@ -1346,7 +1412,7 @@ See also L<perlref>.
=item Not a subroutine reference in %OVERLOAD
(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
@@ -1365,9 +1431,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.
@@ -1378,7 +1450,7 @@ 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
@@ -1387,7 +1459,14 @@ that means the current directory! See L<perlfunc/require>.
=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
@@ -1400,7 +1479,7 @@ since hash lists come in key/value pairs.
=item Operation `%s' %s: no method found,
(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>.
+somehow no longer points to a valid method. See L<overload>.
=item Operator or semicolon missing before %s
@@ -1417,8 +1496,21 @@ 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
-remaining memory (or virtual memory) to satisfy the request.
+(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
@@ -1479,7 +1571,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
@@ -1565,7 +1657,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
@@ -1598,6 +1690,30 @@ 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) You probably wrote something like this:
+
+ qw( a # a comment
+ b # another comment
+ ) ;
+
+when you should have written this:
+
+ qw( a
+ b
+ ) ;
+
+=item Possible attempt to separate words with commas
+
+(W) You probably wrote something like this:
+
+ qw( a, b, c );
+
+when you should have written this:
+
+ qw( a b c );
+
=item Possible memory corruption: %s overflowed 3rd argument
(F) An ioctl() or fcntl() returned more than Perl was bargaining for.
@@ -1617,7 +1733,7 @@ is now misinterpreted as
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 "||".
+parentheses around the filehandle, or use the new "or" operator instead of "||".
=item print on closed filehandle %s
@@ -1639,10 +1755,10 @@ last argument of the previous construct, for example:
=item Prototype mismatch: (%s) vs (%s)
-(S) The subroutine being defined had a predeclared (forward) declaration
+(S) The subroutine being defined had a pre-declared (forward) declaration
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.
@@ -1701,20 +1817,20 @@ shifting or popping (for array variables). See L<perlform>.
(W) You've used an array slice (indicated by @) to select a single value 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 Script is not setuid/setgid in suidperl
(F) Oddly, the suidperl program was invoked on a script with its setuid
-or setgid bit set. This doesn't make much sense.
+or setgid bit not set. This doesn't make much sense.
=item Search pattern not terminated
@@ -1752,7 +1868,7 @@ Check your logic flow.
=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
@@ -1775,25 +1891,25 @@ in a location where the CGI server can't find it, basically, more or less.
=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<$<lt>>, and your operating system doesn't support
the setruid() system call (or equivalent), or at least Configure didn't
think so.
@@ -1837,7 +1953,7 @@ 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.
@@ -1864,7 +1980,7 @@ 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">.
+L<perlop/"Quote and Quote-like Operators">.
=item Substitution pattern not terminated
@@ -1902,7 +2018,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
@@ -1910,13 +2026,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 E<lt>#!E<gt> 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
@@ -1929,15 +2045,15 @@ Check your logic flow.
(W) You tried to use the tell() function on a filehandle that was either
never opened or has been closed since.
-=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;
@@ -1958,7 +2074,7 @@ to the probings of Configure.
(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.
@@ -1983,12 +2099,12 @@ system call to call, silly dilly.
=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
+of Perl. Check the E<lt>#!E<gt> 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
@@ -2017,13 +2133,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"
@@ -2087,13 +2203,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
@@ -2150,7 +2266,7 @@ 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
@@ -2159,20 +2275,20 @@ the line, and you really meant a "less than".
=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.
+(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 %s is deprecated
@@ -2180,7 +2296,7 @@ from C. This usually means there's a better way to do it in Perl.
because there's a better way to do it, and also because the old way has
bad side effects.
-=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.
@@ -2228,6 +2344,11 @@ a scalar context, the comma is treated like C's comma operator, which
throws away the left argument, which is not what you want. See
L<perlref> for more on this.
+=item untie attempted while %d inner references still exist
+
+(W) A copy of the object returned from C<tie> (or C<tied>) was still
+valid when C<untie> was called.
+
=item Variable "%s" is not exported
(F) While "use strict" in effect, you referred to a global variable
@@ -2239,15 +2360,20 @@ on the front of your variable.
=item Variable syntax.
(A) You've accidentally run your script through B<csh> instead
-of Perl. Check the <#!> line, or manually feed your script
+of Perl. Check the E<lt>#!E<gt> line, or manually feed your script
into Perl yourself.
+=item Warning: something's wrong.
+
+(W) You passed warn() an empty string (the equivalent of C<warn "">) or
+you called it with no args and C<$_> was empty.
+
=item Warning: unable to close filehandle %s properly.
-(S) The implicit close() done by an open() got an error indication on the
-close(). This usually indicates your filesystem ran out of disk space.
+(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 parens is ambiguous
+=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
@@ -2264,7 +2390,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
@@ -2297,7 +2423,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.
@@ -2318,18 +2444,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
@@ -2344,5 +2470,36 @@ streams, such as
}
close OUT;
+=item Got an error from DosAllocMem:
+
+(P) An error peculiar to OS/2. Most probably you use 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 non-empty 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 L<perlos2/"PERLLIB_PREFIX">.
+
+=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 L<perlos2/"PERL_SH_DIR">.
+
+=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 L<perlos2/"Process terminated by SIGTERM/SIGINT">.
+
=back
diff --git a/pod/perldsc.pod b/pod/perldsc.pod
index 6d31976852..5beaa8bbe9 100644
--- a/pod/perldsc.pod
+++ b/pod/perldsc.pod
@@ -30,7 +30,7 @@ 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
@@ -41,11 +41,11 @@ 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:
@@ -76,15 +76,15 @@ of these types of data structures.
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
@@ -102,7 +102,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:
@@ -149,7 +149,7 @@ again and again:
$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!
@@ -218,7 +218,7 @@ 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.
@@ -290,14 +290,14 @@ 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]
@@ -325,7 +325,7 @@ example, 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.
@@ -449,7 +449,7 @@ types of data structures.
# 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";
@@ -509,7 +509,7 @@ types of data structures.
# calling a function that returns a key,value list, like
# "lead","fred","daughter","pebbles"
- while ( %fields = getnextpairset() )
+ while ( %fields = getnextpairset() ) {
push @LoH, { %fields };
}
@@ -601,12 +601,6 @@ types of data structures.
}
}
- # 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) };
@@ -638,7 +632,7 @@ types of data structures.
# print the whole thing
foreach $family ( keys %HoH ) {
- print "$family: ";
+ print "$family: { ";
for $role ( keys %{ $HoH{$family} } ) {
print "$role=$HoH{$family}{$role} ";
}
@@ -647,7 +641,7 @@ types of data structures.
# print the whole thing somewhat sorted
foreach $family ( sort keys %HoH ) {
- print "$family: ";
+ print "$family: { ";
for $role ( sort keys %{ $HoH{$family} } ) {
print "$role=$HoH{$family}{$role} ";
}
@@ -657,7 +651,7 @@ types of data structures.
# print the whole thing sorted by number of members
foreach $family ( sort { keys %{$HoH{$b}} <=> keys %{$HoH{$b}} } keys %HoH ) {
- print "$family: ";
+ print "$family: { ";
for $role ( sort keys %{ $HoH{$family} } ) {
print "$role=$HoH{$family}{$role} ";
}
@@ -670,9 +664,9 @@ types of data structures.
# now print the whole thing sorted by number of members
foreach $family ( sort { keys %{$HoH{$b}} <=> keys %{$HoH{$b}} } keys %HoH ) {
- print "$family: ";
+ 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";
@@ -752,7 +746,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
@@ -762,7 +756,7 @@ many different sorts:
@members = ();
# assume this file in field=value syntax
- while () {
+ while (<>) {
%fields = split /[\s=]+/;
push @members, { %fields };
}
@@ -823,13 +817,13 @@ 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 that does partially attempt to address this need is the MLDBM
module. Check your nearest CPAN site as described in L<perlmod> 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
diff --git a/pod/perlembed.pod b/pod/perlembed.pod
index 646cd670a1..ea0e8331f2 100644
--- a/pod/perlembed.pod
+++ b/pod/perlembed.pod
@@ -16,12 +16,12 @@ Read L<perlcall> and L<perlxs>.
=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?>
-Read about L<perlfunc/do> and L<perlfunc/eval> and L<perlmod/use>
-and L<perlmod/require>.
+Read about C<do> and C<eval> in L<perlfunc/do> and L<perlfunc/eval> and C<use>
+and C<require> in L<perlmod> and L<perlfunc/require>, L<perlfunc/use>.
=item B<Use C from C?>
@@ -142,7 +142,7 @@ I<miniperlmain.c> containing the essentials of embedding:
Note that we do not use the C<env> pointer here or in any of the
following examples.
-Normally handed to C<perl_parse> as it's final argument,
+Normally handed to C<perl_parse> as its final argument,
we hand it a B<NULL> instead, in which case the current environment
is used.
@@ -226,7 +226,7 @@ L<Fiddling with the Perl stack from your C program>
=head2 Evaluating a Perl statement 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
+for evaluating 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.
@@ -236,7 +236,7 @@ ours I<perl_eval()>) that wraps around Perl's L<perlfunc/eval>.
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
+use L<perlfunc/require> or L<perlfunc/do> to include external Perl
files.
Our I<perl_eval()> lets us evaluate individual Perl strings, and then
@@ -303,14 +303,14 @@ substitutions: I<match()>, I<substitute()>, and I<matches()>.
char match(char *string, char *pattern);
-Given a string and a pattern (e.g. "m/clasp/" or "/\b\w*\b/", which in
+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/">),
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
+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.
@@ -488,9 +488,9 @@ described in L<perlcall>.
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 built-in 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 {
@@ -612,7 +612,7 @@ 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 statically link in any other extensions.
+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()>:
@@ -644,7 +644,7 @@ Consult L<perlxs> and L<perlguts> for more details.
=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.
diff --git a/pod/perlform.pod b/pod/perlform.pod
index 8c840d4cc2..4fac1a69e3 100644
--- a/pod/perlform.pod
+++ b/pod/perlform.pod
@@ -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.
@@ -147,18 +147,18 @@ 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:
@@ -198,7 +198,7 @@ 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:
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index a6af80aa78..49b77f02fc 100644
--- a/pod/perlfunc.pod
+++ b/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,7 +28,7 @@ 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
@@ -252,12 +252,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,7 +274,7 @@ 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
@@ -304,7 +304,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 +317,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
@@ -328,6 +334,25 @@ syscall() interface to access setitimer(2) if your system supports it,
or else see L</select()> below. It is not advised 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.
@@ -360,7 +385,7 @@ is taken as the name of the filehandle.
This function tells the referenced object (passed as 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.
@@ -488,11 +513,17 @@ 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.
+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
@@ -505,7 +536,7 @@ 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
+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
@@ -572,7 +603,7 @@ their own password:
print "ok\n";
}
-Of course, typing in your own password to whoever asks you
+Of course, typing in your own password to whomever asks you
for it is unwise.
=item dbmclose ASSOC_ARRAY
@@ -591,7 +622,7 @@ 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
+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).
@@ -613,15 +644,18 @@ 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
+=item defined
+
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
+or not. If EXPR is not present, $_ will be checked. 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
@@ -653,35 +687,41 @@ 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
+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.
=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
+array. 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 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.)
The following deletes all the values of an associative array:
- 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,
+the current value of C<$!> (errno). If C<$!> is 0, exits with the value of
+C<($? E<gt>E<gt> 8)> (back-tick `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.
@@ -734,7 +774,7 @@ except that it's more efficient, more concise, keeps track of the
current filename for error messages, and searches all the B<-I>
libraries if the file isn't in the current directory (see also the @INC
array in L<perlvar/Predefined Names>). It's the same, however, in that it does
-reparse the file every time you call it, so you probably don't want to
+re-parse the file every time you call it, so you probably don't want to
do this inside a loop.
Note that inclusion of library modules is better done with the
@@ -779,7 +819,7 @@ Example:
When called in a list context, returns a 2-element array consisting
of the key and value for the next element of an associative array,
so that you can iterate over it. When called in a scalar context,
-returns the key only for the next element in the associative array.
+returns the key for only the next element in the associative array.
Entries are returned in an apparently random order. When the array 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
@@ -787,7 +827,7 @@ scalar context. 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
+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:
@@ -813,7 +853,7 @@ 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.
+the pseudo file 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:
@@ -843,9 +883,11 @@ 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
@@ -853,7 +895,7 @@ 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.
-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.
@@ -890,7 +932,7 @@ being looked at when:
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
+likewise behave in the same way: they run the code E<lt>$xE<gt>, 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
@@ -898,8 +940,10 @@ 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>,
+unless the command does not exist and is executed directly instead of
+via C</bin/sh -c> (see below). Use system() instead of exec() if you
+want it to return.
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
@@ -936,7 +980,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
@@ -958,6 +1002,8 @@ See also die(). If EXPR is omitted, exits with 0 status.
=item exp EXPR
+=item exp
+
Returns I<e> (the natural logarithm base) to the power of EXPR.
If EXPR is omitted, gives C<exp($_)>.
@@ -988,7 +1034,7 @@ 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
+strategy, although it will lock only 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.
@@ -1061,7 +1107,7 @@ example:
.
$str = "widget";
- $num = $cost/$quantiy;
+ $num = $cost/$quantity;
$~ = 'Something';
write;
@@ -1083,7 +1129,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.
@@ -1109,7 +1155,7 @@ 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";
@@ -1141,10 +1187,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
@@ -1269,13 +1317,13 @@ 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 <*.*>
+would do. This is the internal function implementing the E<lt>*.*E<gt>
operator, except it's easier to use.
=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:
@@ -1330,13 +1378,15 @@ 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.
=item hex EXPR
+=item hex
+
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 $_.
@@ -1354,12 +1404,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
@@ -1445,6 +1497,21 @@ function. Here's a descending numeric sort of a hash by its values:
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 associative array. 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
@@ -1476,18 +1543,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.
+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.
+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 $_.
@@ -1504,8 +1581,8 @@ 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
+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.
But you really probably want to be using my() instead, because local() isn't
@@ -1515,7 +1592,7 @@ 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:
($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
@@ -1527,13 +1604,15 @@ the range 0..6. If EXPR is omitted, does localtime(time).
In a scalar context, prints out the ctime(3) value:
- $now_string = localtime; # e.g. "Thu Oct 13 04:54:34 1994"
+ $now_string = localtime; # e.g., "Thu Oct 13 04:54:34 1994"
Also see the F<timelocal.pl> library, and the strftime(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 $_.
@@ -1541,10 +1620,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>.
@@ -1575,7 +1658,7 @@ is just a funny way to write
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
@@ -1609,7 +1692,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
@@ -1634,6 +1717,8 @@ 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
a hex string instead.) The following will handle decimal, octal, and
@@ -1648,25 +1733,31 @@ If EXPR is omitted, uses $_.
=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 L<open2>,
+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<open2>,
L<open3>, and L<perlipc/"Bidirectional Communication"> for alternatives.)
-Opening '-' opens STDIN and opening '>-' opens STDOUT. Open returns
+Opening '-' opens STDIN and opening 'E<gt>-' opens STDOUT. Open returns
non-zero upon success, the undefined value otherwise. If the open
involved a pipe, the return value happens to be the pid of the
subprocess.
@@ -1717,11 +1808,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:
@@ -1749,16 +1841,16 @@ 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
@@ -1777,21 +1869,22 @@ 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 $?.
+wait for the child to finish, and returns the status value in C<$?>.
Note: on any operation which may do a fork, unflushed buffers remain
-unflushed in both processes, which means you may need to set $| to
+unflushed in both processes, which means you may need to set C<$|> to
avoid duplicate output.
-Using the FileHandle constructor from the FileHandle package,
+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.
@@ -1801,7 +1894,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:
@@ -1825,11 +1918,13 @@ 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 $_.
@@ -1869,12 +1964,17 @@ follows:
u A uuencoded string.
+ w A BER compressed integer. Bytes give an unsigned integer base
+ 128, most significant digit first, with as few digits as
+ possible, and with the bit 8 of each byte except the last set
+ to "1."
+
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,
@@ -1890,7 +1990,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:
@@ -1931,11 +2031,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>
@@ -1949,7 +2049,7 @@ 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">
@@ -1969,8 +2069,11 @@ 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.
=item print FILEHANDLE LIST
@@ -1983,7 +2086,7 @@ 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 L</select>). If LIST is also omitted, prints $_ to
STDOUT. To set the default output channel to something other than
@@ -1993,7 +2096,7 @@ 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:
@@ -2001,18 +2104,18 @@ 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 LIST
+=item printf FORMAT, LIST
-Equivalent to a "print FILEHANDLE sprintf(LIST)". The first argument
+Equivalent to a "print FILEHANDLE sprintf(FORMAT, LIST)". The first argument
of the list will be interpreted as the printf format.
=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 the the
-function whose prototype you want to retrieve.
+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
@@ -2038,10 +2141,14 @@ Generalized quotes. See L<perlop>.
=item quotemeta EXPR
+=item quotemeta
+
Returns the value of EXPR with with all regular expression
metacharacters backslashed. This is the internal function implementing
the \Q escape in double-quoted strings.
+If EXPR is omitted, uses $_.
+
=item rand EXPR
=item rand
@@ -2078,7 +2185,7 @@ 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: $!";
@@ -2087,9 +2194,11 @@ chdir() there, it would have been testing the wrong file.
=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 recv SOCKET,SCALAR,LEN,FLAGS
@@ -2131,8 +2240,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
@@ -2157,7 +2269,7 @@ 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
@@ -2165,7 +2277,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
@@ -2216,16 +2328,16 @@ 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 you'll probably want to use them instead. See L</my>.
@@ -2262,8 +2374,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///
@@ -2304,7 +2418,7 @@ 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.
+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:
@@ -2354,7 +2468,7 @@ methods, preferring to write the last example as:
=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 = '';
@@ -2384,19 +2498,19 @@ 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-millisecond 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
@@ -2442,7 +2556,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
@@ -2498,6 +2614,8 @@ 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 $_.
@@ -2508,7 +2626,7 @@ 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
@@ -2518,17 +2636,19 @@ 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.
+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.
@@ -2543,7 +2663,7 @@ 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
+to be ordered. (The E<lt>=E<gt> 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
@@ -2583,7 +2703,7 @@ Examples:
@sortedclass = sort byage @class;
# this sorts the %age associative arrays by value
- # instead of key using an inline function
+ # instead of key using an in-line function
@eldest = sort { $age{$b} <=> $age{$a} } keys %age;
sub backwards { $b cmp $a; }
@@ -2629,7 +2749,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
@@ -2643,6 +2763,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
@@ -2653,7 +2780,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)
@@ -2708,7 +2835,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);
@@ -2757,7 +2884,7 @@ Example:
(Note that $shell above will still have a newline on it. See L</chop>,
L</chomp>, and L</join>.)
-=item sprintf FORMAT,LIST
+=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.
@@ -2768,15 +2895,17 @@ dump core when fed ludicrous arguments.
=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,
-uses a semirandom value based on the current time and process ID, among
+uses a semi-random value based on the current time and process ID, among
other things. Of course, you'd need something much more random than that for
-cryptographic purposes, since it's easy to guess the current time.
+cryptographic purposes, because 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.
@@ -2785,9 +2914,13 @@ the comp.security.unix newsgroup.
=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)
@@ -2801,13 +2934,13 @@ meaning of the fields:
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
+ gid numeric 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
+ blksize preferred block size for file system I/O
blocks actual number of blocks allocated
(The epoch was at 00:00 January 1, 1970 GMT.)
@@ -2820,18 +2953,18 @@ 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
+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
@@ -2865,7 +2998,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;';
@@ -2876,7 +3009,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";
}
@@ -2935,7 +3068,7 @@ 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.
=item sysopen FILEHANDLE,FILENAME,MODE
@@ -2967,9 +3100,15 @@ 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.
+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 system LIST
@@ -2979,7 +3118,7 @@ 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
+the output from a command, for that you should use merely back-ticks, as
described in L<perlop/"`STRING`">.
=item syswrite FILEHANDLE,SCALAR,LENGTH,OFFSET
@@ -2989,9 +3128,13 @@ 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.
+number of bytes actually written, or undef if there was an error.
+If the length is greater than the available data, 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
+from that many bytes counting backwards from the end of the string.
=item tell FILEHANDLE
@@ -3098,28 +3241,36 @@ 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.
+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.
+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.
+omitted, returns merely the current umask.
=item undef EXPR
=item undef
-Undefines the value of EXPR, which must be an lvalue. Use only on a
+Undefines the value of EXPR, which must be an lvalue. Use on only 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
@@ -3136,6 +3287,8 @@ subroutine. Examples:
=item unlink LIST
+=item unlink
+
Deletes a list of files. Returns the number of files successfully
deleted.
@@ -3148,11 +3301,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:
@@ -3165,8 +3320,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:
@@ -3226,7 +3381,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:
@@ -3249,16 +3406,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, i.e. it calls C<unimport Module LIST> instead of C<import>.
+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
@@ -3284,16 +3443,16 @@ on the same array. 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
+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:
@@ -3307,20 +3466,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
@@ -3349,7 +3508,7 @@ 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
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
@@ -3357,9 +3516,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
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index d849fe106f..6743032dae 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -8,7 +8,7 @@ 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
+=head2 Datatypes
Perl has three typedefs that handle Perl's three main data types:
@@ -20,8 +20,8 @@ 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.
@@ -39,7 +39,7 @@ The four routines are:
SV* newSVpv(char*, int);
SV* newSVsv(SV*);
-To change the value of an I<already-existing> SV, there are five routines:
+To change the value of an *already-existing* SV, there are five routines:
void sv_setiv(SV*, IV);
void sv_setnv(SV*, double);
@@ -54,6 +54,14 @@ 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.
+All SV's 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:
SvIV(SV*)
@@ -67,9 +75,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.
+NUL's 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 simply if the scalar value is TRUE, you can use:
SvTRUE(SV*)
@@ -80,7 +88,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
+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.
@@ -118,7 +128,7 @@ 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.
@@ -146,16 +156,16 @@ Take this code:
This code tries to return a new SV (which contains the value 42) if it should
return a real value, or undef otherwise. Instead it has returned a null
pointer which, somewhere down the line, will cause a segmentation violation,
-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 the section on L<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,11 +180,11 @@ 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 just to use the C<Sv*V> macros.
=head2 Working with AV's
-There are two ways to create and load an AV. The first method just creates
+There are two ways to create and load an AV. The first method creates just
an empty AV:
AV* newAV();
@@ -200,27 +210,33 @@ 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>.
+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.
@@ -235,28 +251,36 @@ Once the HV has been created, the following operations are possible on HV's:
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 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, 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 +308,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 PERL_HASH(hash, key, klen) macro:
i = klen;
hash = 0;
@@ -301,12 +325,16 @@ The hash algorithm, for those who are interested, is:
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 the following functions:
- SV* newRV((SV*) thing);
+ SV* newRV_inc((SV*) thing);
+ SV* newRV_noinc((SV*) thing);
-The C<thing> argument can be any of an C<SV*>, C<AV*>, or C<HV*>. Once
-you have a reference, you can use the following macro to dereference the
+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 C<thing>, while C<newRV_noinc> does not. (For
+historical reasons, "newRV" is a synonym for "newRV_inc".) Once you
+have a reference, you can use the following macro to dereference the
reference:
SvRV(SV*)
@@ -318,8 +346,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, you must use the
+following macro and then check the value returned.
SvTYPE(SvRV(SV*))
@@ -328,10 +356,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
@@ -363,8 +395,8 @@ if 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 classname is non-null.
SV* sv_setref_pv(SV* rv, char* classname, PV iv);
@@ -377,102 +409,86 @@ SV is blessed if classname is non-null.
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:
+There are additional macros whose values may be bitwise OR'ed with the
+C<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.
+ GV_ADDMULTI Marks the variable as multiply defined, thus preventing the
+ "Indentifier <varname> used only once: possible typo" warning.
+ GV_ADDWARN Issues a "Had to create <varname> unexpectedly" warning if
+ the variable didn't actually exist. This is useful if
+ you expected the variable to exist already 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.
+=head2 Reference Counts and Mortality
+
+Perl uses an reference count-driven garbage collection mechanism. SV's,
+AV's, or HV's (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 they will be destroyed and their 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, as you should
+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. You create a new SV which initially has a reference count
+of one. Then you call C<newRV_inc>, passing 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 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 0 and also be destroyed, stopping
+any memory leak.
+
+There are some convenience functions available that can help with the
+destruction of old xV objects. 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 xV's have their reference count
+decremented depends on two macros, SAVETMPS and FREETMPS. Take a look
+at 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,27 +496,15 @@ 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
+The mortal routines are not for just SV's -- AV's and HV's can be made
+mortal by passing their address (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.
-
-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
+=head2 Stashes and Globs
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
@@ -517,11 +521,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 +550,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 +561,11 @@ as any other SV.
For more information on references and blessings, consult L<perlref>.
-=head1 Magic
+=head2 Magic
[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,7 +596,7 @@ 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
@@ -665,8 +667,8 @@ 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
- ------- ------ -------------------
+ mg_type MGVTBL Type of magic
+ ------- ------ ----------------------------
\0 vtbl_sv Regexp???
A vtbl_amagic Operator Overloading
a vtbl_amagicelem Operator Overloading
@@ -691,13 +693,25 @@ The current kinds of Magic Virtual Tables are:
* vtbl_glob GV???
# vtbl_arylen Array Length
. vtbl_pos $. scalar variable
- ~ Reserved for extensions, but multiple extensions may clash
+ ~ None Used by certain extensions
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
that composite type.
+The '~' magic type is 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).
+
+Note that because multiple extensions may be using ~ magic it is
+important for extensions to take extra care with it. Typically only
+using it on objects blessed into the same class as the extension
+is sufficient. 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 */
@@ -712,7 +726,7 @@ 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.
-=head1 Double-Typed SV's
+=head2 Double-Typed SV's
Scalar variables normally contain only one type of value, an integer,
double, pointer, or reference. Perl will automatically convert the
@@ -752,7 +766,58 @@ following code:
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>.
-=head1 Calling Perl Routines from within C Programs
+=head2 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 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 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. 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 +852,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
+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 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.
+
+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,7 +904,78 @@ 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).
-=head1 API LISTING
+=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 XSUB's 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 Scratchpads
+
+=head3 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]>.
+
+=head3 Scratchpads
+
+The question remains on when the SV's 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 SV's 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 OP's and I<target>s is not 1-to-1. Different
+OP's in the compile tree of the unit can use the same target, if this
+would not conflict with the expected life of the temporary.
+
+=head3 Scratchpads and recursions
+
+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.
+
+=head2 API LISTING
This is a listing of functions, macros, flags, and variables that may be
useful to extension writers or that may be found while reading other
@@ -876,8 +1016,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 +1031,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));
@@ -916,14 +1058,16 @@ Undefines the array.
=item av_unshift
-Unshift an SV onto the beginning of the array.
+Unshift an SV onto the beginning of the array. The array will grow
+automatically to accommodate the addition.
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
@@ -948,27 +1092,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 +1133,16 @@ 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 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>.
@@ -1052,7 +1219,7 @@ Clears a hash, making it empty.
=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
+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.
@@ -1061,14 +1228,14 @@ returned.
=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_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*>.
@@ -1144,7 +1311,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 +1343,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 +1358,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
@@ -1270,48 +1442,57 @@ 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
+pre-allocated 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
+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
+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
+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));
@@ -1319,15 +1500,15 @@ set to 1. If C<len> is zero then Perl will compute the length.
=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));
@@ -1544,7 +1725,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
@@ -1585,7 +1767,7 @@ C<SPAGAIN>.
=item SPAGAIN
-Refetch the stack pointer. Used after a callback. See L<perlcall>.
+Re-fetch the stack pointer. Used after a callback. See L<perlcall>.
SPAGAIN;
@@ -1659,7 +1841,7 @@ 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
+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));
@@ -1679,11 +1861,27 @@ C<len> indicates number of bytes to copy.
=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 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 +1894,18 @@ 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 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 +1913,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 +1957,18 @@ 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 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 +2010,18 @@ 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_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 +2043,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 +2089,18 @@ 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 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 +2138,18 @@ 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 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 +2173,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)
@@ -1962,29 +2240,32 @@ bytes to be copied.
=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 +2276,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 +2290,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 +2348,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 +2388,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 +2434,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 +2547,16 @@ 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>
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, and Ulrich Pfeifer.
API Listing by Dean Roehrich <roehrich@cray.com>.
=head1 DATE
-Version 20: 1995/12/14
-
+Version 25.2: 1996/12/16
diff --git a/pod/perlipc.pod b/pod/perlipc.pod
index 8ff9e3a918..83f3d4ba34 100644
--- a/pod/perlipc.pod
+++ b/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
@@ -47,7 +47,7 @@ indexed by name to get the number:
$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}) {
@@ -96,28 +96,30 @@ handlers:
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
+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
$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";
+ 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...
@@ -171,9 +173,9 @@ 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
@@ -191,7 +193,7 @@ to find out whether anyone (or anything) has accidentally removed our fifo.
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
}
@@ -229,7 +231,7 @@ read from the file F<f1>, the process F<cmd1>, standard input (F<tmpfile>
in this case), the F<f2> file, the F<cmd2> command, and finally the F<f3>
file. Pretty nifty, eh?
-You might notice that you could use backticks for much the
+You might notice that you could use back-ticks for much the
same effect as opening a pipe for reading:
print grep { !/^(tcp|udp)/ } `netstat -an 2>&1`;
@@ -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:
@@ -296,11 +298,11 @@ you opened whatever your kid writes to his STDOUT.
Another common use for this construct is when you need to execute
something without the shell's interference. With system(), it's
-straightforward, but you can't use a pipe open or backticks safely.
+straightforward, but you can't use a pipe open or back-ticks safely.
That's because there's no way to stop the shell from getting its hands on
your arguments. Instead, use lower-level control to call exec() directly.
-Here's a safe backtick or pipe open for read:
+Here's a safe back-tick or pipe open for read:
# add error processing as above
$pid = open(KID_TO_READ, "-|");
@@ -340,8 +342,8 @@ And here's a safe pipe open for writing:
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.
+multi-threading. If you'd like to learn more about threading, see the
+F<modules> file mentioned below in the SEE ALSO section.
=head2 Bidirectional Communication
@@ -357,7 +359,7 @@ entirely on the diagnostic message:
Can't do bidirectional pipe at -e line 1.
If you really want to, you can use the standard open2() library function
-to catch both ends. There's also an open3() for tridirectional I/O so you
+to catch both ends. There's also an open3() for tri-directional I/O so you
can also catch your child's STDERR, but doing so would then require an
awkward select() loop and wouldn't allow you to use normal Perl input
operations.
@@ -378,10 +380,10 @@ 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
+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
@@ -400,17 +402,17 @@ 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
+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
@@ -458,7 +460,7 @@ Here's a sample TCP client using Internet-domain sockets:
And here's a corresponding server to go along with it. We'll
leave the address as INADDR_ANY so that the kernel can choose
-the appropriate interface on multihomed hosts. If you want sit
+the appropriate interface on multi-homed hosts. If you want sit
on a particular interface (like the external side of a gateway
or firewall machine), you should fill this in with your real address
instead.
@@ -474,6 +476,8 @@ instead.
my $port = shift || 2345;
my $proto = getprotobyname('tcp');
+ $port = $1 if $port =~ /(\d+)/; # untaint port number
+
socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
pack("l", 1)) || die "setsockopt: $!";
@@ -494,11 +498,11 @@ instead.
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
+And here's a multi-threaded version. It's multi-threaded in that
like most typical servers, it spawns (forks) a slave server to
handle the client request so that the master server can quickly
go back to service a new client.
@@ -515,6 +519,8 @@ go back to service a new client.
my $port = shift || 2345;
my $proto = getprotobyname('tcp');
+ $port = $1 if $port =~ /(\d+)/; # untaint port number
+
socket(Server, PF_INET, SOCK_STREAM, $proto) || die "socket: $!";
setsockopt(Server, SOL_SOCKET, SO_REUSEADDR,
pack("l", 1)) || die "setsockopt: $!";
@@ -527,8 +533,8 @@ go back to service a new client.
my $paddr;
sub REAPER {
- $SIG{CHLD} = \&REAPER; # loathe sysV
$waitedpid = wait;
+ $SIG{CHLD} = \&REAPER; # loathe sysV
logmsg "reaped $waitedpid" . ($? ? " with exit $?" : '');
}
@@ -538,7 +544,7 @@ go back to service a new client.
($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);
@@ -567,9 +573,9 @@ 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";
@@ -719,7 +725,7 @@ 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
@@ -892,7 +898,7 @@ 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
+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.
@@ -911,7 +917,7 @@ 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.)
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/pod/perllocale.pod b/pod/perllocale.pod
new file mode 100644
index 0000000000..a1a5b53457
--- /dev/null
+++ b/pod/perllocale.pod
@@ -0,0 +1,614 @@
+=head1 NAME
+
+perllocale - Perl locale handling (internationlization)
+
+=head1 DESCRIPTION
+
+Perl supports language-specific notions of data such as "is this a
+letter", "what is the upper-case 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 naÔ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.
+
+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 a 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>.
+
+=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 C<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 whch 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 (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 C<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>)
+use C<LC_COLLATE>. The C<sort> function is also affected if it is
+used without an explicit comparison function because it uses C<cmp> by
+default.
+
+B<Note:> The C<eq> and C<ne> operators are unaffected by the locale:
+they always perform a byte-by-byte comparison of their scalar
+arguments. If you really want to know if two strings - which C<eq>
+may consider different - are equal as far as collation is concerned,
+use something like
+
+ !("space and case ignored" cmp "SpaceAndCaseIgnored")
+
+(which would be true if the collation locale specified a
+dictionary-like ordering).
+
+I<Editor's note:> I am right about C<eq> and C<ne>, aren't I?
+
+=item *
+
+B<Regular expressions and case-modification functions> (C<uc>,
+C<lc>, C<ucfirst>, and C<lcfirst>) use C<LC_CTYPE>
+
+=item *
+
+B<The formatting functions> (C<printf> and C<sprintf>) use
+C<LC_NUMERIC>
+
+=item *
+
+B<The POSIX date formatting function> (C<strftime>) uses C<LC_TIME>.
+
+=back
+
+C<LC_COLLATE>, C<LC_CTYPE>, and so on, are discussed further in
+L<LOCALE CATEGORIES>.
+
+The default behaviour returns with S<C<no locale>> or on reaching the end
+of the enclosing block.
+
+Note that the result of any operation that uses locale information is
+tainted (see L<perlsec.pod>), since locales can be created by
+unprivileged users on some systems.
+
+=head2 The setlocale function
+
+You can switch locales as often as you wish at runtime with the
+C<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 C<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 paricular
+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 C<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
+C<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 start-up 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
+C<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 C<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 C<setlocale> has been
+standardized, the names of the locales have not. The form of the name
+is usually I<language_country>B</>I<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 C<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
+C<POSIX::setlocale> with a single parameter - see L<The setlocale
+function>.)
+
+ use POSIX qw(locale_h);
+ use locale;
+
+ # 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->{$_}
+ }
+
+C<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.
+
+I<Editor's note:> I can't work out whether C<POSIX::localeconv>
+correctly obeys C<use locale> and C<no locale>. In my opinion, it
+should, if only to be consistent with other locale stuff - although
+it's hardly a show-stopper if it doesn't. Could someone check,
+please?
+
+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);
+ use locale;
+
+ # 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";
+
+I<Editor's note:> Like all the examples, this needs testing on systems
+which, unlike mine, have non-toy implementations of locale handling.
+
+=head1 LOCALE CATEGORIES
+
+The subsections which follow descibe basic locale categories. As well
+as these, there are some combination categories which allow the
+manipulation of of more than one basic category at a time. See
+L<ENVIRONMENT VARIABLES> for a discussion of these.
+
+=head2 Category LC_COLLATE: Collation
+
+When in the scope of S<C<use locale>>, Perl looks to the B<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 '¡' and 'Ÿ' 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";
+
+I<Editor's note:> The original example had C<setlocale(LC_COLLATE, "")>
+prior to C<print ...>. I think this is wrong: as soon as you utter
+S<C<use locale>>, the default behaviour of C<sort> (well, C<cmp>, really)
+becomes locale-aware. The locale it's aware of is the current locale
+which, unless you've changed it yourself, is the default locale
+defined by your environment.
+
+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 written text.
+
+B<NOTE>: In some locales some characters may have no collation value
+at all - for example, if '-' is such a character, 'relocate' and
+'re-locate' may be considered to be equal to each other, and so sort
+to the same position.
+
+=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 '', 'Š',
+'þ', and '¯' may be understood as C<\w> characters.
+
+C<LC_CTYPE> also affects the POSIX character-class test functions -
+C<isalpha>, C<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 C<ispunct> class to C<isalpha>.
+
+I<Editor's note:> I can't work out whether the C<POSIX::is...> stuff
+correctly obeys C<use locale> and C<no locale>. In my opinion, they
+should. Could someone check, please?
+
+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.
+
+=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 C<printf>, C<fprintf>,
+and C<write> functions. String to numeric conversion by the
+C<POSIX::strtod> function is also affected. In most impementations
+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.)
+
+I<Editor's note:> I can't work out whether C<POSIX::strtod> correctly
+obeys C<use locale> and C<no locale>. In my opinion, it should -
+although it's hardly a show-stopper if it doesn't. Could someone
+check, please?
+
+Note that output produced by C<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 C<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" # Locale-dependent conversion
+ if $n == (strtod("2,5"))[0];
+
+=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 recognise 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 formating 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 C<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);
+ use locale;
+ for (0..11)
+ {
+ $long_month_name[$_] = strftime("%B", 0, 0, 0, 1, $_, 96);
+ }
+
+I<Editor's note:> Unchecked in "alien" locales: my system can't do
+French...
+
+=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 behaviour of library functions called
+by extensions which are not part of the standard Perl distribution.
+
+=head1 ENVIRONMENT
+
+=over 12
+
+=item PERL_BADLANG
+
+A string that controls whether Perl warns in its startup about failed
+locale settings. This can happen if the locale support in the
+operating system is lacking (broken) is some way. If this string has
+an integer value differing from zero, Perl will not complain.
+
+B<NOTE>: This is just hiding 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 to
+control 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 montary 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 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 S<C<use locale>> Pragma>) to
+instruct it to do so.
+
+=head2 Sort speed
+
+Comparing and sorting by locale is usually slower than the default
+sorting; factors of 2 to 4 have been observed. It will also consume
+more memory: while a Perl scalar variable is participating in any
+string comparison or sorting operation and obeying the locale
+collation rules it will take about 3-15 (the exact value depends on
+the operating system and the locale) times more memory than normally.
+These downsides are dictated more by the operating system
+implementation of the locale system than by Perl.
+
+=head2 I18N:Collate
+
+In Perl 5.003 (and later development releases prior to 5.003_06),
+per-locale collation was possible using the C<I18N::Collate> library
+module. This is now mildly obsolete and should be avoided in new
+applications. The C<LC_COLLATE> functionality is integrated into the
+Perl core language and one can use locale-specific scalar data
+completely normally - there is no need to juggle with the scalar
+references of C<I18N::Collate>.
+
+=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.
+
+=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 they
+are unsupported, and are not claimed to be fit for any purpose. If
+your system allows the installation of arbitrary locales, you may find
+them 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 can also talk of
+localization (B<l10n>), the process of tailoring an
+internationalizated application for use in a particular locale.
+
+=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. One
+example is IRIX before release 6.2, in which the C<LC_COLLATE> support
+simply does not work. When confronted with such a system, please
+report in excruciating detail to C<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.
+
+=head2 Rendering of this documentation
+
+This manual page contains non-ASCII characters, which should all be
+rendered as accented letters, and which should make some sort of sense
+in context. If this is not the case, your system is probably not
+using the ISO 8859-1 character set which was used to write them,
+and/or your formatting, display, and printing software are not
+correctly mapping them to your host's character set. If this annoys
+you, and if you can convince yourself that it is due to a bug in one
+of Perl's various C<pod2>... utilities, by all means report it as a
+Perl bug. Otherwise, pausing only to curse anyone who ever invented
+yet another character set, see if you can make it handle ISO 8859-1
+sensibly.
+
+=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)/strtod>
+
+I<Editor's note:> That looks horrible after going through C<pod2man>.
+But I do want to call out all thse sectins by name. What should I
+have done?
+
+=head1 HISTORY
+
+Perl 5.003's F<perli18n.pod> heavily hacked by Dominic Dunlop.
+
+Last update:
+Mon Dec 16 14:13:10 WET 1996
diff --git a/pod/perllol.pod b/pod/perllol.pod
index a1e8a2deef..37adac7ef5 100644
--- a/pod/perllol.pod
+++ b/pod/perllol.pod
@@ -12,7 +12,7 @@ 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
@@ -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
@@ -42,7 +42,7 @@ but rather just a reference to it, you could do something more like this:
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
+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,7 +54,7 @@ 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.
+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.
@@ -116,7 +116,7 @@ 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 ];
}
@@ -124,7 +124,7 @@ if you knew where you wanted to put it:
or even just
my (@LoL, $i);
- for $i ( 0 .. 10 )
+ for $i ( 0 .. 10 ) {
$LoL[$i] = [ split ' ', <> ];
}
@@ -133,7 +133,7 @@ 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(<>) ];
}
@@ -144,10 +144,10 @@ you'd have to do something like this:
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 5.001m
+that's been fixed for the 5.002 release.)
my $ref_to_LoL = [];
while (<>) {
@@ -155,7 +155,7 @@ for the 5.002 release.)
}
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) {
@@ -171,13 +171,13 @@ 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!
@@ -187,17 +187,17 @@ 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
+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
+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
@@ -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];
@@ -266,7 +266,7 @@ 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++) {
@@ -308,6 +308,6 @@ perldata(1), perlref(1), perldsc(1)
=head1 AUTHOR
-Tom Christiansen <tchrist@perl.com>
+Tom Christiansen E<lt>F<tchrist@perl.com>E<gt>
Last udpate: Sat Oct 7 19:35:26 MDT 1995
diff --git a/pod/perlmod.pod b/pod/perlmod.pod
index 9aa4729b4d..4fb5ec838b 100644
--- a/pod/perlmod.pod
+++ b/pod/perlmod.pod
@@ -13,11 +13,11 @@ 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
+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 merely influences which
+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:
@@ -39,10 +39,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
+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,7 +62,7 @@ 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(),
+See L<perlsub> for other scoping issues related to my() and local(),
or L<perlref> regarding closures.
=head2 Symbol Tables
@@ -119,9 +119,9 @@ Assignment to a typeglob performs an aliasing operation, i.e.,
*dick = *richard;
-causes variables, subroutines and file handles accessible via the
+causes variables, subroutines, and file handles accessible via the
identifier C<richard> to also be accessible via the identifier C<dick>. If
-you only want to alias a particular variable or subroutine, you can
+you want to alias only a particular variable or subroutine, you can
assign a reference instead:
*dick = \$richard;
@@ -140,12 +140,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.
@@ -155,6 +155,25 @@ Another use of symbol tables is for making "constant" scalars.
Now you cannot alter $PI, which is probably a good thing all in all.
+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
There are two special subroutine definitions that function as package
@@ -176,6 +195,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,7 +208,7 @@ 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>.
@@ -201,15 +225,18 @@ 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:
- package Fred;
- require Exporter;
+ package Fred;
+ use strict;
+ use Exporter ();
+ use vars qw(@ISA @EXPORT @EXPORT_OK);
@ISA = qw(Exporter);
- @EXPORT = qw(func1 func2);
- @EXPORT_OK = qw($sally @listabob %harry func3);
+ @EXPORT = qw(&func1 &func2);
+ @EXPORT_OK = qw($sally @listabob %harry &func3);
+ use vars qw($sally @listabob %harry);
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 I<Perl Modules File> for details on
mechanics and style issues in module creation.
Perl modules are included into your program by saying
@@ -254,7 +281,7 @@ instead of C<use>. With require you can get into this problem:
require Cwd; # make Cwd:: accessible
$here = Cwd::getcwd();
- use Cwd; # import names from Cwd::
+ use Cwd; # import names from Cwd::
$here = getcwd();
require Cwd; # make Cwd:: accessible
@@ -275,7 +302,7 @@ 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>
and L<perlguts>.
@@ -291,14 +318,14 @@ 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
+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.
=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
+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
@@ -310,54 +337,74 @@ conversion, but it's just a mechanical process, so is 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 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
+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.
-The following programs are defined (and have their own documentation).
+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 pre-declare a variables or subroutines within a particular
+<I>file</I> 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 blib
+
+manipulate @INC at compile time to use MakeMaker's uninstalled version
+of a package
+
=item diagnostics
-Pragma to produce enhanced diagnostics
+force verbose warning diagnostics
=item integer
-Pragma to compute arithmetic in integer instead of double
+compute arithmetic in integer instead of double
=item less
-Pragma to request less of something from the compiler
+request less of something from the compiler
+
+=item lib
+
+manipulate @INC at compile time
+
+=item locale
+
+use or ignore current locale for built-in operations (see L<perli18n>)
=item ops
-Pragma to restrict use of unsafe opcodes
+restrict named opcodes when compiling or running Perl code
=item overload
-Pragma for overloading operators
+overload basic Perl operations
=item sigtrap
-Pragma to enable stack backtrace on unexpected signals
+enable simple signal handling
=item strict
-Pragma to restrict unsafe constructs
+restrict unsafe constructs
=item subs
-Pragma to predeclare sub names
+pre-declare sub names
=item vars
-Pragma to predeclare global symbols
+pre-declare global variable names
=back
@@ -389,9 +436,13 @@ benchmark running times of code
warn of errors (from perspective of caller)
+=item Class::Template
+
+struct/member template builder
+
=item Config
-access Perl configuration option
+access Perl configuration information
=item Cwd
@@ -399,15 +450,19 @@ get pathname of current working directory
=item DB_File
-Perl access to Berkeley DB
+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
+dynamically load C libraries into Perl code
=item English
@@ -415,16 +470,36 @@ use nice English (or awk) names for ugly punctuation variables
=item Env
-perl module that imports environment variables
+import environment variables
=item Exporter
-provide inport/export controls for Perl modules
+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 UN*X behaviour in ExtUtils::MakeMaker
+
+=item ExtUtils::MM_Unix
+
+methods used by ExtUtils::MakeMaker
+
+=item ExtUtils::MM_VMS
+
+methods to override UN*X behaviour in ExtUtils::MakeMaker
+
=item ExtUtils::MakeMaker
create an extension Makefile
@@ -437,9 +512,29 @@ utilities to write and check a MANIFEST file
make a bootstrap file for use by DynaLoader
-=item ExtUtils::Miniperl
+=item ExtUtils::Mksymlists
+
+write linker options files for dynamic extension
+
+=item ExtUtils::testlib
+
+add blib/* directories to @INC
+
+=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 Fatal
-!!!GOOD QUESTION!!!
+replace functions with equivalents which succeed or die
=item Fcntl
@@ -447,71 +542,275 @@ load the C Fcntl.h defines
=item File::Basename
-parse file specifications
+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 built-in stat() functions
+
+=item FileCache
+
+keep more files open than the system permits
+
=item FileHandle
supply object methods for filehandles
-=item File::Path
+=item FindBin
-create or remove a series of directories
+locate directory of original perl script
+
+=item GDBM_File
+
+access to the gdbm library
=item Getopt::Long
-extended getopt processing
+extended processing of command line options
=item Getopt::Std
-Process single-character switches with switch clustering
+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
-a process for both reading and writing
+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 NDBM_File
+
+tied access to ndbm files
+
+=item Net::FTP
+
+File Transfer Protocol client
+
=item Net::Ping
check a host for upness
+=item Net::Netrc
+
+parser for ".netrc" files a la Berkeley UNIX
+
+=item Net::Socket
+
+support class for Net::FTP
+
+=item Net::hostent
+
+by-name interface to Perl's built-in gethost*() functions
+
+=item Net::netent
+
+by-name interface to Perl's built-in getnet*() functions
+
+=item Net::protoent
+
+by-name interface to Perl's built-in getproto*() functions
+
+=item Net::servent
+
+by-name interface to Perl's built-in 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
-Perl interface to IEEE Std 1003.1
+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 Safe
+=item Shell
-Creation controlled compartments in which perl code can be evaluated.
+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
-rceate an abbreviation table from a list
+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 built-in gmtime() function
+
+=item Time::localtime
+
+by-name interface to Perl's built-in 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 built-in getgr*() functions
+
+=item User::pwent
+
+by-name interface to Perl's built-in getpw*() functions
=back
@@ -530,7 +829,7 @@ 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
+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
@@ -540,13 +839,13 @@ 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:
+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
+Language Extensions and Documentation Tools
=item *
Development Support
@@ -573,16 +872,16 @@ Interfaces to / Emulations of Other Programming Languages
File Names, File Systems and File Locking (see also File Handles)
=item *
-String Processing, Language Text Processing, Parsing and Searching
+String Processing, Language Text Processing, Parsing, and Searching
=item *
-Option, Argument, Parameter and Configuration File Processing
+Option, Argument, Parameter, and Configuration File Processing
=item *
Internationalization and Locale
=item *
-Authentication, Security and Encryption
+Authentication, Security, and Encryption
=item *
World Wide Web, HTML, HTTP, CGI, MIME
@@ -594,7 +893,7 @@ Server and Daemon Utilities
Archiving and Compression
=item *
-Images, Pixmap and Bitmap Manipulation, Drawing and Graphing
+Images, Pixmap and Bitmap Manipulation, Drawing, and Graphing
=item *
Mail and Usenet News
@@ -683,15 +982,15 @@ ftp://ftp.is.co.za/programming/perl/CPAN/
=back
-For an up-to-date listing of CPAN sites,
+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
+=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
+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
@@ -729,9 +1028,9 @@ scheme as the original author.
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.:
+e.g.,:
- sub new {
+ sub new {
my $class = shift;
return bless {}, $class;
}
@@ -739,7 +1038,7 @@ e.g.:
or even this if you'd like it to be used as either a static
or a virtual method.
- sub new {
+ sub new {
my $self = shift;
my $class = ref($self) || $self;
return bless {}, $class;
@@ -750,13 +1049,13 @@ Pass arrays as references so more parameters can be added later
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.
+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 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).
+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
@@ -765,18 +1064,18 @@ 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
+"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: $obj = new YOURCLASS;
-into: $obj = new SUBCLASS; ?
+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 C<-w>. Try to C<use strict;> (or C<use strict qw(...);>).
+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 C<-w>. Always use C<-w>!
+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
@@ -806,7 +1105,7 @@ or nature of a variable. For example:
$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().
+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.
@@ -822,13 +1121,13 @@ 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)
+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
-informally indicate that they are 'internal' and not for public use.
+indicate informally 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
+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
@@ -837,12 +1136,12 @@ then export nothing. If it's just a collection of functions then
=item Select a name for the module.
-This name should be as descriptive, accurate and complete as
+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.
+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
@@ -922,16 +1221,16 @@ Copying, ToDo etc.
=item Adding a Copyright Notice.
-How you choose to licence your work is a personal decision.
+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 License (see the files README, Copying and
+Perl, for example, is supplied with two types of license: 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:
+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
@@ -945,9 +1244,9 @@ Remember to include the other words in addition to the Copyright.
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.
+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.
@@ -963,7 +1262,7 @@ 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.
+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
@@ -980,10 +1279,10 @@ Follow the instructions and links on
http://franz.ww.tu-berlin.de/modulelist
-or upload to one of these sites:
+or upload to one of these sites:
ftp://franz.ww.tu-berlin.de/incoming
- ftp://ftp.cis.ufl.edu/incoming
+ ftp://ftp.cis.ufl.edu/incoming
and notify upload@franz.ww.tu-berlin.de.
@@ -1074,8 +1373,7 @@ 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
+or
perl -mModule::Name ... (in perl5.002)
=back
-
diff --git a/pod/perlnews.pod b/pod/perlnews.pod
new file mode 100644
index 0000000000..7e6e626723
--- /dev/null
+++ b/pod/perlnews.pod
@@ -0,0 +1,642 @@
+=head1 NAME
+
+perlnews - 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, Plan9, LynxOS, VMS, OS/2,
+QNX, and AmigaOS.
+
+=head1 Core Changes
+
+Most importantly, many bugs were fixed. See the F<Changes>
+file in the distribution for details.
+
+=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.
+
+=head2 Internal Change: FileHandle Deprecated
+
+Filehandles are now stored internally as type IO::Handle.
+Although C<use FileHandle> and C<*STDOUT{FILEHANDLE}>
+are still supported for backwards compatibility
+C<use IO::Handle> (or C<IO::Seekable> or C<IO::File>) and
+C<*STDOUT{IO}> are the way of the future.
+
+=head2 Internal Change: Safe Module Absorbed into Opcode
+
+A new Opcode module subsumes 5.003's Safe module. The Safe
+interface is still available, so existing scripts should still
+work, but users are encouraged to read the new Opcode documentation.
+
+=head2 Internal Change: PerlIO internal IO 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 Built-in Variables
+
+=over
+
+=item $^E
+
+Extended error message under some platforms ($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 -DEMERGENCY_SBRK and used Perl's malloc. Then
+
+ $^M = 'a' x (1<<16);
+
+would allocate 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 Built-in Functions
+
+=over
+
+=item delete on slices
+
+This now works. (e.g. C<delete @ENV{'PATH', 'MANPATH'}>)
+
+=item flock
+
+is now supported on more platforms, and prefers fcntl
+to lockf when emulating.
+
+=item keys as an lvalue
+
+As an lvalue, C<keys> allows you to increase the number of hash buckets
+allocated for the given associative array. 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 (my $line = <>) {
+ $line = lc $line;
+ } continue {
+ print $line;
+ }
+
+ if ((my $answer = <STDIN>) =~ /^yes$/i) {
+ user_agrees();
+ } elsif ($answer =~ /^no$/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 unpack() and pack()
+
+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.
+
+=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. 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 fail if the $VERSION variable in package Module is
+less than VERSION.
+
+Note that there is not a comma after the version!
+
+=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 $_ 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>.
+
+=back
+
+=head2 New Built-in 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 sub-class 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 is
+not less than NEED and die if this is not the case. This method is
+normally called as a class method. This method is also called when the
+C<VERSION> form of C<use> is used.
+
+ use A 1.2 qw(some imported subs);
+
+ A->VERSION( 1.2 );
+ $ref->is_instance(); # True
+
+=item class()
+
+C<class> returns the class name of its object.
+
+=item is_instance()
+
+C<is_instance> returns true if its object is an instance of some
+class, false if its object is the class (package) itself. Example
+
+ A->is_instance(); # False
+
+ $var = 'A';
+ $var->is_instance(); # False
+
+ $ref = bless [], 'A';
+ $ref->is_instance(); # True
+
+=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 TIEHANDLE Now Supported
+
+=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; 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++; print join($,,map(uc($_),@_)),$\ }
+
+=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; "PRINT called $$r times\n"; }
+
+=item DESTROY this
+
+As with the other types of ties, this method will be called when the
+tied handle is about to be destroyed. This is useful for debugging and
+possibly for cleaning up.
+
+ sub DESTROY { print "</shout>\n" }
+
+=back
+
+=head1 Pragmata
+
+Three new pragmatic modules exist:
+
+=over
+
+=item use blib
+
+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 locale
+
+Tells the compiler to enable (or disable) the use of POSIX locales for
+built-in 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
+
+Restricts unsafe operations when compiling.
+
+=back
+
+=head1 Modules
+
+=head2 Module Information Summary
+
+Brand new modules:
+
+ 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
+
+ Fatal.pm Make do-or-die equivalents of functions
+ FindBin.pm Find path of currently executing program
+
+ Class/Template.pm Structure/member template builder
+ File/stat.pm Object-oriented wrapper around CORE::stat
+ Net/hostent.pm Object-oriented wrapper around CORE::gethost*
+ Net/netent.pm Object-oriented wrapper around CORE::getnet*
+ Net/protoent.pm Object-oriented wrapper around CORE::getproto*
+ Net/servent.pm Object-oriented wrapper around CORE::getserv*
+ Time/gmtime.pm Object-oriented wrapper around CORE::gmtime
+ Time/localtime.pm Object-oriented wrapper around CORE::localtime
+ Time/tm.pm Perl implementation of "struct tm" for {gm,local}time
+ User/grent.pm Object-oriented wrapper around CORE::getgr*
+ User/pwent.pm Object-oriented wrapper around CORE::getpw*
+
+ UNIVERSAL.pm Base class for *ALL* classes
+
+=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 cbrt root
+ tan cotan asin acos atan acotan
+ sinh cosh tanh cotanh asinh acosh atanh acotanh
+ cplx cplxe
+
+=head2 Overridden Built-ins
+
+Many of the Perl built-ins 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 Efficiency Enhancements
+
+All hash keys with the same string are only allocated once, so
+even if you have 100 copies of the same hash, the immutable keys
+never have to be re-allocated.
+
+Functions that do nothing but return a fixed value are now inlined.
+
+=head1 Documentation Changes
+
+Many of the base and library pods were updated. These
+new pods are included in section 1:
+
+=over 4
+
+=item L<perli18n>
+
+Internationalization.
+
+=item L<perlapio>
+
+Perl internal IO abstraction interface.
+
+=item L<perltoot>
+
+Tutorial on Perl OO programming.
+
+=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:
+
+=over 4
+
+=item "my" variable %s masks earlier declaration in same scope
+
+(S) 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 Allocation too large: %lx
+
+(X) You can't allocate more than 64K on an MSDOS machine.
+
+=item Allocation too large
+
+(F) You can't allocate more than 2^31+"small amount" bytes.
+
+=item Attempt to free non-existent 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 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 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 non-standard names,
+or it may indicate that a logical name table has been corrupted.
+
+=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 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 Possible attempt to put comments in qw() list
+
+(W) You probably wrote something like this:
+
+ qw( a # a comment
+ b # another comment
+ ) ;
+
+when you should have written this:
+
+ qw( a
+ b
+ ) ;
+
+=item Possible attempt to separate words with commas
+
+(W) You probably wrote something like this:
+
+ qw( a, b, c );
+
+when you should have written this:
+
+ qw( a b c );
+
+=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 Got an error from DosAllocMem:
+
+(P) An error peculiar to OS/2. Most probably you use an obsolete version
+of Perl, and 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 non-empty 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 L<perlos2/"PERLLIB_PREFIX">.
+
+=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 L<perlos2/"PERL_SH_DIR">.
+
+=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 L<perlos2/"Process terminated by SIGTERM/SIGINT">.
+
+=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 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 Dec 18 16:18:27 EST 1996
diff --git a/pod/perlobj.pod b/pod/perlobj.pod
index 994edfe00e..1d13d90c9a 100644
--- a/pod/perlobj.pod
+++ b/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
@@ -44,7 +47,7 @@ constructor:
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
+This is for convenience, because the referenced object itself knows that
it has been blessed, and its reference to it could have been returned
directly, like this:
@@ -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 {
@@ -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 = {};
@@ -117,7 +121,7 @@ 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
@@ -142,7 +146,7 @@ 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
@@ -155,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 {
@@ -173,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.
@@ -193,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';
@@ -222,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)
@@ -244,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:
@@ -253,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
@@ -295,15 +300,17 @@ 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 require_version ( VERSION )
+=item VERSION ( [ VERSION ] )
-C<require_version> will check that the current version of the package
-is greater than C<VERSION>. This method is normally called as a static method.
-This method is also called when the C<VERSION> form of C<use> is used.
+C<VERSION> returns the VERSION number of the class (package). If
+an argument is given then it will check that the current version is not
+less that the given argument. This method is normally called as a class
+method. This method is also called when the C<VERSION> form of C<use> is
+used.
use A 1.2 qw(some imported subs);
- A->require_version( 1.2 );
+ A->VERSION( 1.2 );
=item class ()
@@ -322,12 +329,6 @@ class, false if its object is the class (package) itself. Example
$ref = bless [], 'A';
$ref->is_instance(); # True
-=item require_version ( [ VERSION ] )
-
-C<require_version> returns the VERSION number of the class (package). If
-an argument is given then it will check that the current version is not
-less that the given argument.
-
=back
B<NOTE:> C<can> directly uses Perl's internal code for method lookup, and
@@ -346,9 +347,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.
@@ -369,7 +370,7 @@ are equivalent, but AB and CD are different:
=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.
@@ -415,7 +416,7 @@ When an interpreter thread finally shuts down (usually when your program
exits), then a rather costly but complete mark-and-sweep style of garbage
collection is performed, and everything allocated by that thread gets
destroyed. This is essential to support Perl as an embedded or a
-multithreadable language. For example, this program demonstrates Perl's
+multi-threadable language. For example, this program demonstrates Perl's
two-phased garbage collection:
#!/usr/bin/perl
@@ -464,7 +465,7 @@ 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.
@@ -474,6 +475,8 @@ at a future date.
=head1 SEE ALSO
+A kinder, gentler tutorial on object-oriented programming in Perl can
+be found in L<perltoot>.
You should also check out L<perlbot> for other object tricks, traps, and tips,
as well as L<perlmod> for some style guides on constructing both modules
and classes.
diff --git a/pod/perlop.pod b/pod/perlop.pod
index 91cee46fbd..a75cb4947d 100644
--- a/pod/perlop.pod
+++ b/pod/perlop.pod
@@ -43,7 +43,7 @@ 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,
+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
@@ -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.
@@ -88,7 +88,7 @@ Also parsed as terms are the C<do {}> and C<eval {}> constructs, as
well as subroutine and method calls, and the anonymous
constructors C<[]> and C<{}>.
-See also L<Quote and 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 built-in 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,7 +167,7 @@ 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
+time. This is less efficient than an explicit search, because the pattern
must be compiled every time the expression is evaluated--unless you've
used C</o>.)
@@ -184,7 +185,7 @@ Binary "%" computes the modulus of the two numbers.
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 +206,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 +241,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 +277,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.
@@ -291,12 +293,15 @@ less than, equal to, or greater than the right argument.
=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
@@ -384,7 +389,7 @@ As a list operator:
@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');
@@ -475,7 +480,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 +495,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 +506,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.
@@ -535,7 +540,7 @@ 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
@@ -558,13 +563,13 @@ the same character fore and aft, but the 4 sorts of brackets
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
@@ -582,13 +587,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,7 +602,7 @@ 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.
@@ -617,10 +622,10 @@ L<perlre>.
Options are:
- g Match globally, i.e. find all occurrences.
+ 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.
@@ -644,7 +649,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 +672,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
@@ -690,7 +695,7 @@ beginning. Examples:
($one,$five,$fifteen) = (`uptime` =~ /(\d+\.\d+)/g);
# scalar context
- $/ = ""; $* = 1; # $* deprecated in Perl 5
+ $/ = ""; $* = 1; # $* deprecated in modern perls
while ($paragraph = <>) {
while ($paragraph =~ /[a-z]['")]*[.!?]+['")]*\s/g) {
$sentences++;
@@ -754,13 +759,13 @@ 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.
@@ -768,20 +773,20 @@ expression is used instead. See L<perlre> for further explanation on these.
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). Unlike
-Perl 4, Perl 5 treats backticks as normal delimiters; the replacement
+Perl 4, Perl 5 treats back-ticks 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
@@ -824,10 +829,10 @@ 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>>.
+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
@@ -847,10 +852,10 @@ 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,
+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]>
+quotes, which may or may not be bracketing quotes, e.g., C<tr[A-Z][a-z]>
or C<tr(+-*/)/ABCD/>.
Options:
@@ -915,7 +920,7 @@ an eval():
=head2 I/O Operators
There are several I/O operators you should know about.
-A string is enclosed by backticks (grave accents) first undergoes
+A string is enclosed by back-ticks (grave accents) first undergoes
variable substitution just like a double quoted string. It is then
interpreted as a command, and the output of that command is the value
of the pseudo-literal, like in a shell. In a scalar context, a single
@@ -928,7 +933,7 @@ of C<$?>). Unlike in B<csh>, no translation is done on the return
data--newlines remain newlines. Unlike in any of the shells, single
quotes do not hide variable names in the command from interpretation.
To pass a $ through to the shell you need to hide it with a backslash.
-The generalized form of backticks is C<qx//>. (Because backticks
+The generalized form of back-ticks is C<qx//>. (Because back-ticks
always undergo shell expansion as well, see L<perlsec> for
security concerns.)
@@ -949,13 +954,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.
@@ -984,9 +989,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<$.>)
@@ -1013,7 +1018,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 +1030,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 +1055,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
+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
@@ -1102,7 +1107,7 @@ 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
@@ -1117,3 +1122,9 @@ countermand this by saying
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.
diff --git a/pod/perlpod.pod b/pod/perlpod.pod
index dbeaf51a2b..dcf615daa3 100644
--- a/pod/perlpod.pod
+++ b/pod/perlpod.pod
@@ -42,7 +42,7 @@ the same paragraph as "=headn" 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.
+"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 +51,11 @@ 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
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 blank lines after each command to end its paragraph.
Some examples of lists include:
@@ -94,15 +94,21 @@ here and in commands:
S<text> text contains non-breaking spaces
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
+ E<escape> An HTML escape
+ E<lt> A literal <
+ E<gt> A literal >
+ (these are optional except in other interior
+ sequences and when preceded by a capital letter)
+ E<nnn> Character number nnn.
=back
@@ -111,7 +117,7 @@ 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.
@@ -152,6 +158,36 @@ the first pod directive.
If you had not had that blank 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 blank 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 blank 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/pod/perlre.pod b/pod/perlre.pod
index a364916b29..ce054ec448 100644
--- a/pod/perlre.pod
+++ b/pod/perlre.pod
@@ -5,7 +5,7 @@ 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>.
@@ -13,10 +13,28 @@ The matching operations can
have various modifiers, some of which relate to the interpretation of
the regular expression inside. These are:
- 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.
+
+=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 +42,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>.
+character is also treated as a meta-character introducing a comment,
+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
@@ -43,7 +63,7 @@ See L<Version 8 Regular Expressions> for details.
In particular the following metacharacters have their standard I<egrep>-ish
meanings:
- \ Quote the next metacharacter
+ \ Quote the next meta-character
^ Match the beginning of the line
. Match any character (except newline)
$ Match the end of the line (or before newline at the end)
@@ -51,8 +71,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 +80,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.
@@ -82,7 +102,7 @@ as a regular character.) The "*" modifier is equivalent to C<{0,}>, the "+"
modifier to C<{1,}>, and the "?" modifier to C<{0,1}>. n and m are limited
to integral values less than 65536.
-By default, a quantified subpattern is "greedy", that is, it will match as
+By default, a quantified sub-pattern 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
@@ -97,15 +117,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
@@ -127,15 +147,15 @@ In addition, Perl defines the following:
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
+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)
+ \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
A word boundary (C<\b>) is defined as a spot between two characters that
@@ -148,26 +168,26 @@ 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)>.
-When the bracketing construct C<( ... )> is used, \<digit> matches the
+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:
@@ -182,10 +202,10 @@ everything after the matched string. Examples:
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
+So anything that looks like \\, \(, \), \E<lt>, \E<gt>, \{, or \} is always
+interpreted as a literal character, not a meta-character. 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
+you are afraid might contain metacharacters. Quote simply all the
non-alphanumeric characters:
$pattern =~ s/(\W)/\\$1/g;
@@ -196,11 +216,11 @@ is to say
/$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 +231,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 +255,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 +268,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";
@@ -370,11 +390,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,12 +420,12 @@ 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.
The search engine will initially match C<\D*> with "ABC". Then it will
@@ -417,7 +436,7 @@ in the hope of matching the complete regular expression.
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.
@@ -457,10 +476,10 @@ it would take literally forever--or until you ran out of stack space.
In case you're not familiar with the "regular" Version 8 regexp
routines, here are the pattern-matching rules not described above.
-Any single character matches itself, unless it is a I<metacharacter>
+Any single character matches itself, unless it is a I<meta-character>
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.
@@ -472,13 +491,13 @@ 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.
-Characters may be specified using a metacharacter syntax much like that
+Characters may be specified using a meta-character 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
+ASCII character control-I<x>. Finally, the "." meta-character matches any
character except "\n" (unless you use C</s>).
You can specify a series of alternatives for a pattern using "|" to
@@ -493,14 +512,14 @@ start and end. 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|]>.
-Within a pattern, you may designate subpatterns for later reference by
+Within a pattern, you may designate sub-patterns for later reference by
enclosing them in parentheses, and you may refer back to the I<n>th
-subpattern later in the pattern using the metacharacter \I<n>.
-Subpatterns are numbered based on the left to right order of their
+sub-pattern later in the pattern using the meta-character \I<n>.
+Sub-patterns 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
+actually matched the sub-pattern in the string being examined, not the
+rules for that sub-pattern. Therefore, C<(0|0x)\d*\s\1\d*> will
+match "0x1234 0x4321",but not "0x1234 01234", because sub-pattern 1
actually matched "0x", even though the rule C<0|0x> could
potentially match the leading 0 in the second number.
@@ -512,7 +531,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>
diff --git a/pod/perlref.pod b/pod/perlref.pod
index dc10eedaf2..bbbe57feba 100644
--- a/pod/perlref.pod
+++ b/pod/perlref.pod
@@ -7,9 +7,9 @@ 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.
@@ -25,7 +25,7 @@ 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.
+symbolic link in the filesystem contains merely 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.
@@ -44,7 +44,7 @@ References can be constructed several ways.
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
+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:
@@ -53,8 +53,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.
@@ -66,15 +71,18 @@ brackets:
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
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.
@@ -161,7 +169,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.
@@ -180,27 +188,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 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
@@ -244,7 +287,7 @@ previous examples could be written like this:
${$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,
@@ -255,7 +298,7 @@ subscripted expressions:
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:
@@ -321,7 +364,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.
@@ -336,7 +379,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
@@ -420,7 +463,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 }
@@ -437,7 +480,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
@@ -448,7 +491,7 @@ 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
+you won't accomplish what you're attempting. You might want to do something
more like
$r = \@a;
diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index 3761398d4d..083b567e19 100644
--- a/pod/perlrun.pod
+++ b/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.
@@ -46,11 +46,11 @@ scans for the first line starting with #! and containing the word
embedded in a larger message. (In this case you would indicate the end
of the script using the __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
@@ -67,8 +67,8 @@ 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.
@@ -100,7 +100,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 +109,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 +133,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>
@@ -151,10 +151,10 @@ Devel::DProf profiler. See L<perldebug>.
=item B<-D>I<list>
sets debugging flags. To watch how it executes your script, use
-B<-D14>. (This only works if debugging is compiled into your
+B<-D14>. (This works only 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
+alternative specify a list of letters instead of numbers (e.g., B<-D14> is
equivalent to B<-Dtls>):
1 p Tokenizing and Parsing
@@ -186,7 +186,7 @@ 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>
@@ -238,16 +238,17 @@ 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 +260,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>
@@ -329,9 +330,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>
@@ -352,7 +353,7 @@ this is used to emulate #! startup on machines that don't support #!,
in the following manner:
#!/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 +365,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>
@@ -418,7 +419,7 @@ Prints to STDOUT the value of the named configuration variable.
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
+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.
@@ -431,8 +432,8 @@ 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
+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).
diff --git a/pod/perlsec.pod b/pod/perlsec.pod
index 13c0987af7..2b6972701f 100644
--- a/pod/perlsec.pod
+++ b/pod/perlsec.pod
@@ -1,4 +1,3 @@
-
=head1 NAME
perlsec - Perl security
@@ -17,7 +16,7 @@ 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 the B<-T> command line flag. This flag is
+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.
@@ -33,7 +32,7 @@ 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, and file input are marked as "tainted".
Tainted data may not be used directly or indirectly in any command that
-invokes a subshell, nor in any command that modifies files, directories,
+invokes a sub-shell, nor in any command that modifies files, directories,
or processes. Any variable set within an expression that has previously
referenced a tainted value itself becomes tainted, even if it is logically
impossible for the tainted value to influence the variable. Because
@@ -102,9 +101,9 @@ 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 only gets you so far. Sometimes you just have
+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.
+mechanism is by referencing sub-patterns 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
@@ -123,7 +122,7 @@ or a dot.
die "Bad data in $data"; # log this somewhere
}
-This is fairly secure since C</\w+/> doesn't normally match shell
+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
@@ -134,7 +133,7 @@ a child of lesser privilege.
=head2 Cleaning Up Your Path
-For "Insecure $ENV{PATH}" messages, you need to set C<$ENV{'PATH'}> to a
+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>
@@ -156,7 +155,7 @@ prevent stupid mistakes, not to remove the need for thought.
Perl does not call the shell to expand wild cards when you pass B<system>
and B<exec> explicit parameter lists instead of strings with possible shell
wildcards in them. Unfortunately, the B<open>, B<glob>, and
-backtick functions provide no such alternate calling convention, so more
+back-tick 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
@@ -168,11 +167,11 @@ 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. Since the file or pipe was opened in the child while running
+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
+Here's a way to do back-ticks 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. By the time we get to the B<exec>, tainting
diff --git a/pod/perlstyle.pod b/pod/perlstyle.pod
index e4a5aab41f..734b9ad032 100644
--- a/pod/perlstyle.pod
+++ b/pod/perlstyle.pod
@@ -12,7 +12,7 @@ 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 *
@@ -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.
@@ -189,7 +189,7 @@ 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
+file systems' representations of module names as files that must fit into a
few sparse bites.
=item *
@@ -202,7 +202,7 @@ or nature of a variable. For example:
$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().
+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 *
diff --git a/pod/perlsub.pod b/pod/perlsub.pod
index 4d186d2843..6bd3fe8d84 100644
--- a/pod/perlsub.pod
+++ b/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 pre-declared/imported.
&NAME; # Passes current @_ to subroutine.
=head1 DESCRIPTION
@@ -58,7 +58,7 @@ 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
+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">.
@@ -105,8 +105,8 @@ 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 {
@@ -149,13 +149,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
+pre-declared. (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
@@ -187,11 +188,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,
@@ -225,11 +227,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;
@@ -250,6 +252,49 @@ the expression
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 (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
@@ -284,8 +329,8 @@ 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
+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
@@ -297,7 +342,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.
@@ -326,7 +371,7 @@ 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()
to be executed early, either by putting the whole block above
-your pain program, or more likely, merely placing a BEGIN
+your pain program, or more likely, placing merely a BEGIN
sub around it to make sure it gets executed before your program
starts to run:
@@ -362,15 +407,15 @@ Synopsis:
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
@@ -392,7 +437,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,7 +450,7 @@ 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>;
@@ -422,12 +467,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 +487,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
@@ -489,9 +535,9 @@ list of keys occurring in all the hashes passed to it:
return grep { $seen{$_} == @_ } keys %seen;
}
-So far, we're just using the normal list return mechanism.
+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 only using one of them, or you don't mind them
+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.
@@ -501,7 +547,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.
@@ -536,7 +582,7 @@ It turns out that you can actually do this also:
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,6 +600,9 @@ 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 {
@@ -563,8 +612,8 @@ If you're planning on generating new filehandles, you could do this:
}
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 +623,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 +632,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 +676,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;
@@ -645,7 +694,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 +706,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:
@@ -698,23 +747,23 @@ 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
+This is all very powerful, of course, and should be used only in moderation
to make the world a better place.
=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
+C<subs> pragma (compiler directive) lets you, in effect, pre-declare subs
via the import syntax, and these names may then override the builtin ones:
use subs 'chdir', 'chroot', 'chmod', 'chown';
@@ -722,7 +771,7 @@ via the import syntax, and these names may then override the builtin ones:
sub chdir { ... }
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.
@@ -767,7 +816,7 @@ should just call system() with those arguments. All you'd do is this:
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 pre-declare the functions you want to call that way, you don't
even need the parentheses:
use subs qw(date who ls);
diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod
index c3ef4501dd..9cf39a3d5a 100644
--- a/pod/perlsyn.pod
+++ b/pod/perlsyn.pod
@@ -35,7 +35,7 @@ take effect at compile time. Typically all the declarations are put at
the beginning or the end of the script. However, if you're using
lexically-scoped private variables created with 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
@@ -63,7 +63,7 @@ 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),
and thus need an explicit termination if used as the last item in a statement.
@@ -91,7 +91,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 +128,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.
@@ -196,7 +196,7 @@ which is Perl short-hand for the more explicitly written version:
# 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 |) {}
@@ -244,6 +244,9 @@ 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
@@ -259,12 +262,14 @@ hang.
=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 +283,7 @@ Examples:
for (@ary) { s/foo/bar/ }
- foreach $elem (@elements) {
+ foreach my $elem (@elements) {
$elem *= 2;
}
@@ -294,8 +299,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,11 +309,11 @@ 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;
}
@@ -317,19 +322,19 @@ do it:
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.
@@ -491,8 +496,8 @@ and your documentation text freely, as in
.........
}
-Note that pod translators should only look at paragraphs beginning
-with a pod diretive (it makes parsing easier), whereas the compiler
+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.
diff --git a/pod/perltie.pod b/pod/perltie.pod
index 658425e7da..7624881bde 100644
--- a/pod/perltie.pod
+++ b/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.
@@ -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.
@@ -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.
@@ -302,8 +303,8 @@ 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
+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,
@@ -312,8 +313,8 @@ 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;
@@ -322,7 +323,7 @@ contents. For example:
$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:
@@ -346,7 +347,7 @@ whose dot files this object represents
=item HOME
-where those dotfiles live
+where those dot files live
=item CLOBBER
@@ -354,7 +355,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 +367,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,7 +413,7 @@ 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
+in question. Otherwise, because we didn't chdir() there, it would
have been testing the wrong file.
=item FETCH this, key
@@ -444,7 +445,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
@@ -525,14 +526,14 @@ the caller whether the file was successfully deleted.
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}}) {
@@ -573,8 +574,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;
@@ -608,7 +609,61 @@ 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, PRINT and/or READLINE, 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 $r; bless \$r, 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++; print join($,,map(uc($_),@_)),$\ }
+
+=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; "PRINT called $$r times\n"; }
+
+=item DESTROY this
+
+As with the other types of ties, this method will be called when the
+tied handle is about to be destroyed. This is useful for debugging and
+possibly cleaning up.
+
+ sub DESTROY { print "</shout>\n" }
+
+=back
+
+Here's how to use our little example:
+
+ tie(*FOO,'Shout');
+ print FOO "hello\n";
+ $a = 4; $b = 6;
+ print FOO $a, " plus ", $b, " equals ", $a + $b, "\n";
+ print <FOO>;
=head1 SEE ALSO
@@ -625,10 +680,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 that does attempt to address this need partially is the MLDBM
module. Check your nearest CPAN site as described in L<perlmod> for
source code to MLDBM.
=head1 AUTHOR
Tom Christiansen
+
+TIEHANDLE by Sven Verdoolaege E<lt>F<skimo@dns.ufsia.ac.be>E<gt>
diff --git a/pod/perltoc.pod b/pod/perltoc.pod
index 6184e146c1..2821fa363a 100644
--- a/pod/perltoc.pod
+++ b/pod/perltoc.pod
@@ -6,7 +6,7 @@ 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
@@ -144,7 +144,7 @@ HOME, LOGDIR, PATH, PERL5LIB, PERL5DB, PERLLIB
=item The Arrow Operator
-=item Autoincrement and Autodecrement
+=item Auto-increment and Auto-decrement
=item Exponentiation
@@ -215,10 +215,10 @@ HOME, LOGDIR, PATH, PERL5LIB, PERL5DB, PERLLIB
unary &, unary *, (TYPE)
-=item Quote and Quotelike Operators
+=item Quote and Quote-like Operators
-=item Regexp Quotelike Operators
+=item Regexp Quote-like Operators
?PATTERN?, m/PATTERN/gimosx, /PATTERN/gimosx, q/STRING/, C<'STRING'>,
@@ -232,7 +232,7 @@ y/SEARCHLIST/REPLACEMENTLIST/cds
=item Constant Folding
-=item Integer arithmetic
+=item Integer Arithmetic
@@ -247,6 +247,8 @@ y/SEARCHLIST/REPLACEMENTLIST/cds
=item DESCRIPTION
+i, m, s, x
+
=over
=item Regular Expressions
@@ -742,6 +744,11 @@ structures, objects
=item Method Invocation
+=item Default UNIVERSAL methods
+
+isa(CLASS), can(METHOD), VERSION([VERSION]), class(), is_instance()
+
+
=item Destructors
@@ -857,20 +864,43 @@ FIRSTKEY this, NEXTKEY this, lastkey, DESTROY this
=item DESCRIPTION
+=item The Perl Debugger
+
+
=over
-=item Debugging
+=item Debugger Commands
+
+
+h [command], p expr, x expr, V [pkg [vars]], X [vars], T, s [expr], n,
+E<lt>CRE<gt>, c [line], 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], d [line], D, a
+[line] command, A, O [opt[=val]] [opt"val"] [opt?].., recallCommand,
+ShellBang, pager, arrayDepth, hashDepth, compactDump, veryCompact,
+globPrint, DumpDBFiles, DumpPackages, quote, HighBit, undefPrint,
+tkRunning, signalLevel, warnLevel. dieLevel, E<lt> command, E<gt>
+command, ! number, ! -number, ! pattern, !! cmd, H -number, q or ^D,
+R, |dbcmd, ||dbcmd, = [alias value], command, p expr
-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 Debugger Customization
-=item Customization
+=item Readline Support
+
+=item Editor Support for Debugging
+
+
+=item The Perl Profiler
+
+
+=item Debugger Internals
+
+TTY, noTTY, ReadLine, NonStop, LineInfo
+
+
=item Other resources
@@ -899,10 +929,14 @@ command, V package [symbols], X [symbols], ! number, ! -number, H
=over
-=item Format Variables
+=item Laundering and Detecting Tainted Data
+
+=item Cleaning Up Your Path
+=item Security Bugs
+
=back
@@ -928,7 +962,7 @@ command, V package [symbols], X [symbols], ! number, ! -number, H
=head2 perlipc - Perl interprocess communication (signals, fifos,
-pipes, safe subprocceses, sockets, and semaphores)
+pipes, safe subprocesses, sockets, and semaphores)
=item DESCRIPTION
@@ -1714,7 +1748,7 @@ C<overload::Method(obj,op)>
-=head2 sigtrap - Perl pragma to enable stack backtrace on unexpected
+=head2 sigtrap - Perl pragma to enable stack back-trace on unexpected
signals
=item SYNOPSIS
@@ -1739,7 +1773,7 @@ C<strict refs>, C<strict vars>, C<strict subs>
-=head2 subs - Perl pragma to predeclare sub names
+=head2 subs - Perl pragma to pre-declare sub names
=item SYNOPSIS
@@ -1750,7 +1784,7 @@ C<strict refs>, C<strict vars>, C<strict subs>
-=head2 vars - Perl pragma to predeclare global variable names
+=head2 vars - Perl pragma to pre-declare global variable names
=item SYNOPSIS
@@ -1987,7 +2021,7 @@ get, put, del, fd, seq, sync
@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()
+dl_find_symbol(), dl_undef_symbols(), dl_install_xsub(), bootstrap()
=item AUTHOR
@@ -2133,7 +2167,7 @@ maybe_command_in_dirs, maybe_command, perl_script
guess_name, init_main, init_dirscan, init_others, find_perl
-=item Methods to actually produce chunks of text for the Makefile
+=item Methods to produce chunks of text for the Makefile
post_initialize, const_config, constants, const_loadlibs, const_cccmd,
@@ -3123,8 +3157,8 @@ TIESCALAR classname, LIST, FETCH this, STORE this, value, DESTROY this
=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 program's documentation, but they don't all
+have manual pages yet:
=item a2p
@@ -3147,7 +3181,7 @@ have man pages yet:
=head1 AUTHOR
-Larry Wall E<lt><F<lwall@sems.com>E<gt>, with the help of oodles of
+Larry Wall E<lt>F<larry@wall.org>E<gt>, with the help of oodles of
other folks.
diff --git a/pod/perltoot.pod b/pod/perltoot.pod
new file mode 100644
index 0000000000..3fdedc2513
--- /dev/null
+++ b/pod/perltoot.pod
@@ -0,0 +1,1779 @@
+=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 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 an even 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.
+
+Why is DESTROY in all caps? Perl on occasion uses purely upper-case
+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 trade-offs 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 destructed, 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 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 all C<Employee>) inherits
+methods from this person one? Then C<Employee-&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 know 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.
+
+ $class->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 5.003, there were no predefined methods there, but you could put
+whatever you felt like into it.
+
+However, as of 5.004 (or some subversive releases, like 5.003_08),
+UNIVERSAL has some methods in it already. These are built-in 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
+upper-case 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 versioning 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 it 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 will be a lot faster than the
+hash access, but they're actually comparable. The array is a 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 allocation memory for the keys as well as the values.
+However, it really isn't that bad, especially since as of 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 as 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::Template and Alias. These and other related metaclasses can be
+found in the modules directory on CPAN.
+
+=head2 Class::Template
+
+One of the older ones is Class::Template. 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().
+
+Here's a simple example of using it:
+
+ use Class::Template 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::Template 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::Template 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(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+ @ISA = qw(Exporter);
+ @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;
+
+ use Class::Template 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::Template 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, and short-cut function call via C<&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 lower-case, by convention reserved for compiler pragmas,
+because they affect the compilation and change a built-in 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 pre-declare 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::Template 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.
+
+>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 built-in 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 man pages 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 man page 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/pod/perltrap.pod b/pod/perltrap.pod
index be58bc52e2..391c98b129 100644
--- a/pod/perltrap.pod
+++ b/pod/perltrap.pod
@@ -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 *
@@ -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,18 +231,18 @@ Sharp shell programmers should take note of the following:
=item *
-The backtick operator does variable interpolation without regard to
+The back-tick operator does variable interpolation without regard to
the presence of single quotes in the command.
=item *
-The backtick operator does no translation of the return value, unlike B<csh>.
+The back-tick 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
-such as double quotes, backticks, angle brackets, and search patterns.
+command line. Perl does substitution in only certain constructs
+such as double quotes, back-ticks, angle brackets, and search patterns.
=item *
@@ -275,16 +275,16 @@ 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
+You can't tell by just 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.
+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())
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 *
@@ -295,8 +295,8 @@ you might expect to do not.
=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>) { }
@@ -332,7 +332,7 @@ external name is still an alias for the original.
=back
-=head2 Perl4 to Perl5 Traps
+=head2 Perl4 to Perl5 Traps
Practicing Perl4 Programmers should take note of the following
Perl4-to-Perl5 specific traps.
@@ -419,7 +419,7 @@ for C<$_> itself (and C<@_>, etc.).
=item * Deprecation
Double-colon is now a valid package separator in a variable name. Thus these
-behave differently in perl4 vs. perl5, since the packages don't exist.
+behave differently in perl4 vs. perl5, because the packages don't exist.
$a=1;$b=2;$c=3;$var=4;
print "$a::$b::$c ";
@@ -480,7 +480,7 @@ Double darn.
# perl4 prints: a is foo bar, b is baz
# perl5 errors: Bare word found where operator expected
-
+
=item * Discontinuance
The archaic while/if BLOCK BLOCK syntax is no longer supported.
@@ -537,6 +537,48 @@ 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 C<-e> switch,
+always taking the code snippet from the following arg. Additionally, it
+would silently accept an C<-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 * Deprecation
Some error messages will be different.
@@ -610,21 +652,11 @@ Formatted output and significant digits
=item * Numerical
-Large integer trap with autoincrement
+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 5.003_04. But always be wary when using large integers. If in doubt:
- $a = $b = 2147483647;
- print "$a $b\n";
- $a += 1;
- $b++;
- print "$a $b\n";
-
- # perl4 prints:
- 2147483647 2147483647
- 2147483648 2147483648
-
- # perl5 prints:
- 2147483647 2147483647
- 2147483648 -2147483648
+ use Math::BigInt;
=item * Numerical
@@ -638,8 +670,8 @@ Logical tests now return an null, instead of 0
# perl4 prints: 0
# perl5 prints:
-Also see the L<General Regular Expression Traps> tests for another example
-of this new feature...
+Also see the L<General Regular Expression Traps using s///, etc.>
+tests for another example of this new feature...
=back
@@ -709,7 +741,7 @@ variable is localized subsequent to the assignment
# perl4 prints: 1 2 4
# perl5 prints: Literal @fred now requires backslash
-
+
=item * (Scalar String)
Changes in unary negation (of strings)
@@ -763,7 +795,7 @@ The behavior is slightly different for:
Variable suicide behavior is more consistent under Perl 5.
Perl5 exhibits the same behavior for associative arrays and scalars,
-that perl4 exhibits only for scalars.
+that perl4 exhibits for only scalars.
$aGlobal{ "aKey" } = "global value";
print "MAIN:", $aGlobal{"aKey"}, "\n";
@@ -796,7 +828,7 @@ that perl4 exhibits only for scalars.
# SUB: this should never appear
# SUB: this should never appear
-=back
+=back
=head2 Context Traps - scalar, list contexts
@@ -827,7 +859,7 @@ being required.
# 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
@@ -868,7 +900,20 @@ Probably a bug.
Perl4-to-Perl5 traps involving precedence order.
-=item *
+=over 5
+
+=item * Precedence
+
+LHS vs. RHS when both sides are getting an op.
+
+ @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:
@@ -908,8 +953,8 @@ now works as a C programmer would expect.
open FOO || die;
-is now incorrect. You need parens around the filehandle.
-Otherwise, perl5 leaves the statement as it's default precedence:
+is now incorrect. You need parentheses around the filehandle.
+Otherwise, perl5 leaves the statement as its default precedence:
open(FOO || die);
@@ -925,7 +970,7 @@ treats C<$::> as main C<package>
# perl 4 prints: -:a
# perl 5 prints: x
-
+
=item * Precedence
concatenation precedence over filetest operator?
@@ -1010,8 +1055,8 @@ Also see L<Numerical Traps> for another example of this new feature.
=item * Regular Expression
-C<s`lhs`rhs`> (using backticks) is now a normal substitution, with no
-backtick expansion
+C<s`lhs`rhs`> (using back-ticks) is now a normal substitution, with no
+back-tick expansion
$string = "";
$string =~ s`^`hostname`;
@@ -1096,6 +1141,16 @@ reverse is no longer allowed as the name of a sort subroutine.
# 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
@@ -1132,7 +1187,7 @@ on the handler _not_ being reset will have to be reworked.
=item * (SysV)
Under SysV OS's, C<seek()> on a file opened to append C<E<gt>E<gt>> now does
-the right thing w.r.t. the fopen() man page. e.g. - When a file is opened
+the right thing w.r.t. the fopen() man page. e.g., - When a file is opened
for append, it is impossible to overwrite information already in
the file.
@@ -1154,6 +1209,9 @@ the file.
=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
@@ -1167,9 +1225,6 @@ the file.
=item * Interpolation
-Perl4-to-Perl5 traps having to do with how things get interpolated
-within certain expressions, statements, contexts, or whatever.
-
Double-quoted strings may no longer end with an unescaped $ or @.
$foo = "foo$";
@@ -1183,6 +1238,23 @@ Note: perl5 DOES NOT error on the terminating @ in $bar
=item * Interpolation
+Perl now sometimes evaluates arbitrary expressions inside braces that occur
+within double quotes (usually when the opening brace is preceded by C<$>
+or C<@>).
+
+ @www = "buz";
+ $foo = "foo";
+ $bar = "bar";
+ sub foo { return "bar" };
+ print "|@{w.w.w}|${main'foo}|";
+
+ # perl4 prints: |@{w.w.w}|foo|
+ # perl5 prints: |buz|bar|
+
+Note that you can C<use strict;> to ward off such trappiness under perl5.
+
+=item * Interpolation
+
The construct "this is $$x" used to interpolate the pid at that
point, but now apparently tries to dereference C<$x>. C<$$> by itself still
works fine, however.
@@ -1324,6 +1396,8 @@ immediately.
Everything else.
+=over 5
+
=item * Unclassified
C<require>/C<do> trap using returned value
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 0248fe0719..a049e9d5a1 100644
--- a/pod/perlvar.pod
+++ b/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
@@ -51,7 +51,7 @@ 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 (<>) {...} # equivalent in only while!
while ($_ = <>) {...}
/^Subject:/
@@ -106,9 +106,9 @@ test. Note that outside of a C<while> test, this will not happen.
=over 8
-=item $<I<digit>>
+=item $E<lt>I<digit>E<gt>
-Contains the subpattern from the corresponding set of parentheses in
+Contains the sub-pattern from the corresponding set of parentheses in
the last pattern matched, not counting patterns matched in nested
blocks that have been exited already. (Mnemonic: like \digit.)
These variables are all read-only.
@@ -127,7 +127,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
@@ -136,7 +136,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';
@@ -162,15 +162,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
@@ -181,8 +181,8 @@ Use of "C<$*>" is deprecated in Perl 5.
=item $.
The current input line number for the last file handle from
-which you read (or performed a C<seek> or <tell> on). An
-explicit close on a filehandle resets the line number. Since
+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
@@ -198,14 +198,15 @@ 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
+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 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
+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 $/;
@@ -220,8 +221,8 @@ delimit line boundaries when quoting poetry.)
If set to nonzero, forces a flush 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<$|> only tells
-you whether you've asked Perl to explicitly flush after each write).
+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
@@ -238,8 +239,8 @@ has no 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.)
@@ -253,12 +254,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
@@ -298,7 +299,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" multi-dimensional arrays.
=item $OFMT
@@ -312,7 +313,7 @@ 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
@@ -378,7 +379,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
@@ -395,13 +396,17 @@ L<perlfunc/formline()>.
=item $?
-The status returned by the last pipe close, backtick (C<``>) command,
+The status returned by the last pipe close, back-tick (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>.)
+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.
+
=item $OS_ERROR
=item $ERRNO
@@ -413,7 +418,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?)
@@ -422,12 +427,16 @@ 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
+provided by C<$!>, if available. (If not, it's just C<$!> again, except under
+OS/2.)
+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 which was not directed via CRT. The
caveats mentioned in the description of C<$!> apply here, too.
(Mnemonic: Extra error explanation.)
+Note that under OS/2 C<$!> and C<$^E> do not track each other, so if an
+OS/2-specific call is performed, you may need to check both.
=item $EVAL_ERROR
@@ -439,7 +448,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__}>
+below.
=item $PROCESS_ID
@@ -471,7 +481,7 @@ The effective uid of this process. Example:
($<,$>) = ($>,$<); # 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().
+"C<$E<lt>>" and "C<$E<gt>>" can be swapped on only machines supporting setreuid().
=item $REAL_GROUP_ID
@@ -500,10 +510,11 @@ 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.)
-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.
+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 on only machines supporting setregid(). Because
+Perl doesn't currently use initgroups(), you can't set your group vector to
+multiple groups.
=item $PROGRAM_NAME
@@ -602,7 +613,7 @@ it.
=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.
@@ -610,8 +621,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
@@ -621,13 +632,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
@@ -637,12 +648,12 @@ be evaluated by the C<do EXPR>, C<require>, or C<use> constructs. It
initially consists of the arguments to any B<-I> command line switches,
followed by the default Perl library, probably F</usr/local/lib/perl>,
followed by ".", to represent the current directory. If you need to
-modify this at runtime, you should use the C<use lib> pragma 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 %INC
The hash %INC contains entries for each filename that has
@@ -674,7 +685,7 @@ signals. Example:
$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!!
@@ -685,10 +696,10 @@ the Perl script. Here are some other examples:
The one marked scary is problematic because it's a bareword, which means
sometimes it's a string representing the function, and sometimes it's
going to call the subroutine call right then and there! Best to be sure
-and quote it or take a reference to it. *Plumber works too. See L<perlsubs>.
+and quote it or take a reference to it. *Plumber works too. See L<perlsub>.
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
@@ -697,7 +708,7 @@ 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,
diff --git a/pod/perlxs.pod b/pod/perlxs.pod
index 850960ae2b..cc83c8b843 100644
--- a/pod/perlxs.pod
+++ b/pod/perlxs.pod
@@ -416,6 +416,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 +560,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
@@ -614,7 +631,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 +664,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 +680,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.
@@ -827,7 +844,7 @@ 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.
diff --git a/pod/perlxstut.pod b/pod/perlxstut.pod
index 592f2ee189..501a34845e 100644
--- a/pod/perlxstut.pod
+++ b/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
@@ -33,7 +33,7 @@ read:
=item *
-In versions of 5.002 prior to version beta 3, then the line in the .xs file
+In versions of 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.
@@ -63,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.
@@ -88,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.
@@ -201,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:
@@ -227,7 +227,7 @@ Now re-run 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"
@@ -261,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.
@@ -271,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
@@ -445,7 +446,7 @@ 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. The next example will show how to do this.
@@ -576,17 +577,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
@@ -604,7 +607,7 @@ 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.
@@ -617,12 +620,12 @@ 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.
@@ -682,7 +685,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.
@@ -693,7 +696,7 @@ 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
@@ -724,7 +727,7 @@ and L<perlpod>.
=head2 Author
-Jeff Okamoto <okamoto@corp.hp.com>
+Jeff Okamoto E<lt>F<okamoto@corp.hp.com>E<gt>
Reviewed and assisted by Dean Roehrich, Ilya Zakharevich, Andreas Koenig,
and Tim Bunce.
diff --git a/pod/pod2html.PL b/pod/pod2html.PL
index ced84783e5..b41e0c37d6 100644
--- a/pod/pod2html.PL
+++ b/pod/pod2html.PL
@@ -25,14 +25,15 @@ 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
diff --git a/pod/pod2latex.PL b/pod/pod2latex.PL
index 602364e2ec..ebace22aef 100644
--- a/pod/pod2latex.PL
+++ b/pod/pod2latex.PL
@@ -25,9 +25,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/pod/pod2man.PL b/pod/pod2man.PL
index 8c054ca521..68121e482c 100644
--- a/pod/pod2man.PL
+++ b/pod/pod2man.PL
@@ -15,7 +15,7 @@ use File::Basename qw(&basename &dirname);
chdir(dirname($0));
($file = basename($0)) =~ s/\.PL$//;
$file =~ s/\.pl$//
- if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+ if ($^O eq 'VMS' or $^O eq 'os2' or $^O eq 'amigaos'); # "case-forgiving"
open OUT,">$file" or die "Can't create $file: $!";
@@ -25,14 +25,14 @@ 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 "$@"'
- if 0;
=head1 NAME
@@ -198,7 +198,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
@@ -248,7 +248,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,
@@ -273,7 +273,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:
@@ -388,8 +388,12 @@ $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;
+$name =~ s(/)(::)g; # translate Getopt/Long to Getopt::Long, etc.
if ($name ne 'something') {
FCHECK: {
@@ -402,7 +406,7 @@ if ($name ne 'something') {
$oops++;
warn "$0: Improper man page - no dash in NAME header in paragraph $. of $ARGV[0]\n"
}
- %namedesc = split /\s+-\s+/;
+ %namedesc = split /\s+-+\s+/;
last FCHECK;
}
next if /^=cut\b/; # DB_File and Net::Ping have =cut before NAME
@@ -755,7 +759,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;
@@ -1004,7 +1008,7 @@ 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)
return $retstr;
diff --git a/pod/pod2text.PL b/pod/pod2text.PL
index 49198078c0..033a0d8f55 100644
--- a/pod/pod2text.PL
+++ b/pod/pod2text.PL
@@ -25,9 +25,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/pp.c b/pp.c
index 03685cb1e0..ab1816df63 100644
--- a/pp.c
+++ b/pp.c
@@ -15,6 +15,20 @@
#include "EXTERN.h"
#include "perl.h"
+/*
+ * 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 everywhere, at
+ * least today.
+ */
+typedef int IBW;
+typedef unsigned UBW;
+
static void doencodes _((SV *sv, char *s, I32 len));
/* variations on pp_null */
@@ -98,7 +112,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;
+ SvREFCNT_inc(sv);
+ sv = (SV*) gv;
+ } else if (SvTYPE(sv) != SVt_PVGV)
DIE("Not a GLOB reference");
}
else {
@@ -122,28 +142,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) = (GV*)sv;
- }
- }
+ if (op->op_private & OPpLVAL_INTRO)
+ save_gp((GV*)sv, !(op->op_flags & OPf_SPECIAL));
SETs(sv);
RETURN;
}
@@ -188,7 +188,7 @@ PP(pp_rv2sv)
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))
+ else if (op->op_private & OPpDEREF)
provide_ref(op, sv);
}
SETs(sv);
@@ -214,7 +214,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;
@@ -259,10 +264,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,12 +273,10 @@ 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;
}
@@ -307,6 +308,7 @@ PP(pp_refgen)
MARK[1] = *SP;
SP = MARK + 1;
}
+ EXTEND_MORTAL(SP - MARK);
while (MARK < SP) {
sv = *++MARK;
rv = sv_newmortal();
@@ -415,13 +417,6 @@ 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);
@@ -569,9 +564,11 @@ PP(pp_undef)
PP(pp_predec)
{
dSP;
- 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);
@@ -583,9 +580,11 @@ PP(pp_postinc)
{
dSP; dTARGET;
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);
@@ -600,9 +599,11 @@ PP(pp_postdec)
{
dSP; dTARGET;
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);
@@ -666,21 +667,26 @@ PP(pp_modulo)
{
dSP; dATARGET; tryAMAGICbin(mod,opASSIGN);
{
- register unsigned long tmpulong;
- register long tmplong;
- I32 value;
+ register UV right;
- tmpulong = (unsigned long) POPn;
- if (tmpulong == 0L)
+ right = POPu;
+ if (!right)
DIE("Illegal modulus zero");
- value = TOPn;
- if (value >= 0.0)
- value = (I32)(((unsigned long)value) % tmpulong);
+
+ if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)) {
+ register IV left = SvIVX(TOPs);
+ if (left < 0)
+ SETu( (right - ((UV)(-left) - 1) % right) - 1 );
+ else
+ SETi( left % right );
+ }
else {
- tmplong = (long)value;
- value = (I32)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
+ register double left = TOPn;
+ if (left < 0.0)
+ SETu( (right - (U_V(-left) - 1) % right) - 1 );
+ else
+ SETu( U_V(left) % right );
}
- SETi(value);
RETURN;
}
}
@@ -754,9 +760,16 @@ 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;
+ SETi( i << shift );
+ }
+ else {
+ UBW u = TOPu;
+ SETu( u << shift );
+ }
+ RETURN;
}
}
@@ -764,8 +777,15 @@ 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;
+ SETi( i >> shift );
+ }
+ else {
+ UBW u = TOPu;
+ SETu( u >> shift );
+ }
RETURN;
}
}
@@ -843,7 +863,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( cmp < 0 ? &sv_yes : &sv_no );
RETURN;
}
}
@@ -853,7 +876,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( cmp > 0 ? &sv_yes : &sv_no );
RETURN;
}
}
@@ -863,7 +889,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( cmp <= 0 ? &sv_yes : &sv_no );
RETURN;
}
}
@@ -873,7 +902,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( cmp >= 0 ? &sv_yes : &sv_no );
+ RETURN;
+ }
+}
+
+PP(pp_seq)
+{
+ dSP; tryAMAGICbinSET(seq,0);
+ {
+ dPOPTOPssrl;
+ SETs( sv_eq(left, right) ? &sv_yes : &sv_no );
RETURN;
}
}
@@ -893,19 +935,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( value );
+ }
+ else {
+ UBW value = SvUV(left) & SvUV(right);
+ SETu( value );
+ }
}
else {
do_vop(op->op_type, TARG, left, right);
@@ -921,9 +972,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 = SvIV(left) ^ SvIV(right);
+ SETi( value );
+ }
+ else {
+ UBW value = SvUV(left) ^ SvUV(right);
+ SETu( value );
+ }
}
else {
do_vop(op->op_type, TARG, left, right);
@@ -939,9 +995,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 = SvIV(left) | SvIV(right);
+ SETi( value );
+ }
+ else {
+ UBW value = SvUV(left) | SvUV(right);
+ SETu( value );
+ }
}
else {
do_vop(op->op_type, TARG, left, right);
@@ -958,12 +1019,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);
}
@@ -995,18 +1058,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( value );
+ }
+ else {
+ UBW value = ~SvUV(sv);
+ SETu( value );
+ }
}
else {
register char *tmps;
register long *tmpl;
+ register I32 anum;
STRLEN len;
SvSetSV(TARG, sv);
@@ -1244,7 +1309,7 @@ PP(pp_srand)
_ckvmssts(sys$gettim(when));
anum = when[0] ^ when[1];
#else
-# if defined(I_SYS_TIME) && !defined(PLAN9)
+# ifdef HAS_GETTIMEOFDAY
struct timeval when;
gettimeofday(&when,(struct timezone *) 0);
anum = when.tv_sec ^ when.tv_usec;
@@ -1287,8 +1352,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;
@@ -1301,8 +1368,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;
@@ -1343,22 +1412,17 @@ 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;
@@ -1371,10 +1435,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;
}
@@ -1425,14 +1486,24 @@ PP(pp_substr)
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;
@@ -1588,7 +1659,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;
@@ -1660,8 +1738,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;
}
@@ -1679,8 +1764,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;
@@ -1691,7 +1783,6 @@ PP(pp_uc)
dSP;
SV *sv = TOPs;
register char *s;
- register char *send;
STRLEN len;
if (!SvPADTMP(sv)) {
@@ -1700,12 +1791,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;
}
@@ -1715,7 +1815,6 @@ PP(pp_lc)
dSP;
SV *sv = TOPs;
register char *s;
- register char *send;
STRLEN len;
if (!SvPADTMP(sv)) {
@@ -1724,12 +1823,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;
}
@@ -1848,17 +1956,35 @@ PP(pp_delete)
{
dSP;
SV *sv;
- SV *tmpsv = POPs;
- HV *hv = (HV*)POPs;
- 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,
+ (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0);
+ *MARK = sv ? sv : &sv_undef;
+ }
+ if (GIMME != G_ARRAY) {
+ 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,
+ (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0);
+ if (!sv)
+ sv = &sv_undef;
+ PUSHs(sv);
}
- sv = hv_delete_ent(hv, tmpsv,
- (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0);
- if (!sv)
- RETPUSHUNDEF;
- PUSHs(sv);
RETURN;
}
@@ -1990,7 +2116,6 @@ PP(pp_anonlist)
PP(pp_anonhash)
{
dSP; dMARK; dORIGMARK;
- STRLEN len;
HV* hv = (HV*)sv_2mortal((SV*)newHV());
while (MARK < SP) {
@@ -2073,15 +2198,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 */
}
@@ -2167,8 +2297,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);
}
@@ -2177,7 +2311,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]);
}
@@ -2212,7 +2347,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;
@@ -2226,7 +2361,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;
@@ -2293,12 +2428,42 @@ 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;
SV *sv;
STRLEN llen;
STRLEN rlen;
@@ -2520,6 +2685,7 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
aint = *s++;
if (aint >= 128) /* fake up signed chars */
@@ -2542,6 +2708,7 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
auint = *s++ & 255;
sv = NEWSV(37, 0);
@@ -2563,6 +2730,7 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
Copy(s, &ashort, 1, I16);
s += sizeof(I16);
@@ -2595,6 +2763,7 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
Copy(s, &aushort, 1, U16);
s += sizeof(U16);
@@ -2628,6 +2797,7 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
Copy(s, &aint, 1, int);
s += sizeof(int);
@@ -2653,11 +2823,15 @@ 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);
+ if (auint <= I32_MAX)
+ sv_setiv(sv, (I32)auint);
+ else
+ sv_setnv(sv, (double)auint);
PUSHs(sv_2mortal(sv));
}
}
@@ -2678,6 +2852,7 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
Copy(s, &along, 1, I32);
s += sizeof(I32);
@@ -2713,6 +2888,7 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
Copy(s, &aulong, 1, U32);
s += sizeof(U32);
@@ -2735,6 +2911,7 @@ PP(pp_unpack)
if (len > along)
len = along;
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
if (sizeof(char*) > strend - s)
break;
@@ -2748,6 +2925,49 @@ 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 decn[sizeof(UV) * 3 + 1];
+ char *t;
+
+ (void) sprintf(decn, "%0*ld", sizeof(decn) - 1, auv);
+ sv = newSVpv(decn, 0);
+ 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)
@@ -2764,6 +2984,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;
@@ -2778,6 +2999,7 @@ PP(pp_unpack)
break;
case 'Q':
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
if (s + sizeof(unsigned Quad_t) > strend)
auquad = 0;
@@ -2806,6 +3028,7 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
Copy(s, &afloat, 1, float);
s += sizeof(float);
@@ -2829,6 +3052,7 @@ PP(pp_unpack)
}
else {
EXTEND(SP, len);
+ EXTEND_MORTAL(len);
while (len-- > 0) {
Copy(s, &adouble, 1, double);
s += sizeof(double);
@@ -2914,6 +3138,8 @@ PP(pp_unpack)
checksum = 0;
}
}
+ if (sp == oldsp && GIMME != G_ARRAY)
+ PUSHs(&sv_undef);
RETURN;
}
@@ -2944,6 +3170,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;
@@ -3223,6 +3528,65 @@ PP(pp_pack)
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 (adouble <= UV_MAX) {
+ 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;
@@ -3345,6 +3709,10 @@ PP(pp_split)
if (!pm || !s)
DIE("panic: do_split");
+
+ 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)
@@ -3366,8 +3734,14 @@ PP(pp_split)
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);
@@ -3378,17 +3752,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)) {
@@ -3409,20 +3791,10 @@ PP(pp_split)
else if (pm->op_pmshort) {
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);
@@ -3452,7 +3824,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;
@@ -3500,7 +3874,7 @@ 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) {
diff --git a/pp.h b/pp.h
index 7dc918c40d..56cd26cfbd 100644
--- a/pp.h
+++ b/pp.h
@@ -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,18 +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
+#define SETu(u) STMT_START { sv_setuv(TARG, (UV)(u)); SETTARG; } STMT_END
#define dTOPss SV *sv = TOPs
#define dPOPss SV *sv = POPs
@@ -99,6 +104,8 @@
#define dPOPnv double value = POPn
#define dTOPiv IV value = TOPi
#define dPOPiv IV value = POPi
+#define dTOPuv UV value = TOPu
+#define dPOPuv UV value = POPu
#define dPOPPOPssrl SV *right = POPs; SV *left = POPs
#define dPOPPOPnnrl double right = POPn; double left = POPn
@@ -125,6 +132,12 @@
sp = stack_sp = stack_base + AvFILL(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
#define AMGf_noright 1
diff --git a/pp_ctl.c b/pp_ctl.c
index 0e86fd132b..78e1c99585 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -31,8 +31,9 @@ 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;
@@ -174,7 +175,7 @@ PP(pp_formline)
bool gotsome;
STRLEN len;
- if (!SvCOMPILED(form)) {
+ if (!SvMAGICAL(form) || !SvCOMPILED(form)) {
SvREADONLY_off(form);
doparseform(form);
}
@@ -212,9 +213,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 +377,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 {
@@ -574,7 +577,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",
@@ -649,7 +652,8 @@ PP(pp_sort)
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;
@@ -707,14 +711,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);
}
}
@@ -853,7 +859,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)
@@ -881,7 +887,7 @@ I32 cxix;
while (cxstack_ix > cxix) {
cx = &cxstack[cxstack_ix--];
- DEBUG_l(fprintf(Perl_debug_log, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
+ 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) {
@@ -900,54 +906,6 @@ I32 cxix;
}
}
-#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;
-
- /* 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);
- }
-#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;
@@ -987,7 +945,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);
@@ -1003,11 +961,11 @@ char *message;
return pop_return();
}
}
- fputs(message, stderr);
- (void)Fflush(stderr);
+ PerlIO_printf(PerlIO_stderr(), "%s",message);
+ PerlIO_flush(PerlIO_stderr());
if (e_tmpname) {
if (e_fp) {
- fclose(e_fp);
+ PerlIO_close(e_fp);
e_fp = Nullfp;
}
(void)UNLINK(e_tmpname);
@@ -1114,7 +1072,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)));
}
@@ -1189,33 +1147,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 **)a, *(SV **)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 **)a, *(SV **)b);
}
PP(pp_reset)
@@ -1265,7 +1205,7 @@ PP(pp_dbstate)
SAVETMPS;
SAVEI32(debug);
- SAVESPTR(stack_sp);
+ SAVESTACK_POS();
debug = 0;
hasargs = 0;
sp = stack_sp;
@@ -1623,7 +1563,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");
@@ -1696,8 +1636,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]) );
}
@@ -1760,12 +1702,13 @@ PP(pp_goto)
mark++;
}
}
- if (perldb && curstash != debstash) { /* &xsub is not copying @_ */
+ if (perldb && curstash != debstash) {
+ /* &xsub is not copying @_ */
SV *sv = GvSV(DBsub);
save_item(sv);
- gv_efullname(sv, CvGV(cv)); /* We do not care about
- * using sv to call CV,
- * just for info. */
+ gv_efullname3(sv, CvGV(cv), Nullch);
+ /* We do not care about using sv to call CV,
+ * just for info. */
}
RETURNOP(CvSTART(cv));
}
@@ -1965,13 +1908,13 @@ int gimme;
/* 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);
SAVESPTR(compcv);
compcv = (CV*)NEWSV(1104,0);
@@ -2049,6 +1992,20 @@ int gimme;
DEBUG_x(dump_eval());
+ /* Register with debugger: */
+
+ if (perldb && 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 */
SP = stack_base + POPMARK; /* pop original mark */
@@ -2064,10 +2021,11 @@ PP(pp_require)
char *tmpname;
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);
@@ -2093,27 +2051,29 @@ PP(pp_require)
|| (tmpname[0] && tmpname[1] == ':')
#endif
#ifdef VMS
- || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') &&
- (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>')))
+ || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') &&
+ (isALNUM(tmpname[1]) || strchr("$-_]>",tmpname[1]))))
#endif
)
{
- tryrsfp = fopen(tmpname,"r");
+ tryrsfp = PerlIO_open(tmpname,"r");
}
else {
AV *ar = GvAVn(incgv);
I32 i;
-
- for (i = 0; i <= AvFILL(ar); i++) {
#ifdef VMS
+ char unixified[256];
+ if (tounixspec_ts(tmpname,unixified) != NULL)
+ for (i = 0; i <= AvFILL(ar); i++) {
if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL)
continue;
- strcat(buf,name);
+ strcat(buf,unixified);
#else
+ for (i = 0; i <= AvFILL(ar); i++) {
(void)sprintf(buf, "%s/%s",
SvPVx(*av_fetch(ar, i, TRUE), na), name);
#endif
- tryrsfp = fopen(buf, "r");
+ tryrsfp = PerlIO_open(buf, "r");
if (tryrsfp) {
char *s = buf;
@@ -2182,9 +2142,10 @@ PP(pp_entereval)
dSP;
register CONTEXT *cx;
dPOPss;
- I32 gimme = GIMME;
- char tmpbuf[32];
+ I32 gimme = GIMME, was = sub_generation;
+ char tmpbuf[32], *safestr;
STRLEN len;
+ OP *ret;
if (!SvPV(sv,len) || !len)
RETPUSHUNDEF;
@@ -2200,7 +2161,13 @@ PP(pp_entereval)
sprintf(tmpbuf, "_<(eval %d)", ++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;
@@ -2213,7 +2180,11 @@ PP(pp_entereval)
if (perldb && curstash != debstash)
save_lines(GvAV(compiling.cop_filegv), linestr);
PUTBACK;
- return doeval(gimme);
+ ret = doeval(gimme);
+ if (perldb && was != sub_generation) { /* Some subs defined here. */
+ strcpy(safestr, "_<(eval )"); /* Anything fake and short. */
+ }
+ return ret;
}
PP(pp_leaveeval)
@@ -2225,7 +2196,7 @@ PP(pp_leaveeval)
I32 gimme;
register CONTEXT *cx;
OP *retop;
- OP *saveop = op;
+ U8 save_flags = op -> op_flags;
I32 optype;
POPBLOCK(cx,newpm);
@@ -2252,7 +2223,7 @@ PP(pp_leaveeval)
}
else {
for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(TOPs) & SVs_TEMP))
+ if (!(SvFLAGS(*mark) & SVs_TEMP))
*mark = sv_mortalcopy(*mark);
/* in case LEAVE wipes old return values */
}
@@ -2269,7 +2240,7 @@ PP(pp_leaveeval)
lex_end();
LEAVE;
- if (!(saveop->op_flags & OPf_SPECIAL))
+ if (!(save_flags & OPf_SPECIAL))
sv_setpv(GvSV(errgv),"");
RETURNOP(retop);
@@ -2328,7 +2299,7 @@ PP(pp_leavetry)
}
else {
for (mark = newsp + 1; mark <= SP; mark++)
- if (!(SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)))
+ if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP)))
*mark = sv_mortalcopy(*mark);
/* in case LEAVE wipes old return values */
}
@@ -2357,7 +2328,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) {
@@ -2390,13 +2364,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) {
@@ -2512,5 +2485,6 @@ SV *sv;
}
Copy(fops, s, arg, U16);
Safefree(fops);
+ sv_magic(sv, Nullsv, 'f', Nullch, 0);
SvCOMPILED_on(sv);
}
diff --git a/pp_hot.c b/pp_hot.c
index 9945dd4bbc..fb28bfee83 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -100,7 +100,7 @@ PP(pp_gelem)
ref = (SV*)GvCV(gv);
break;
case 'F':
- if (strEQ(elem, "FILEHANDLE"))
+ if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
ref = (SV*)GvIOp(gv);
break;
case 'G':
@@ -111,6 +111,10 @@ PP(pp_gelem)
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));
@@ -154,11 +158,8 @@ 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);
SETs(right);
@@ -185,16 +186,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);
@@ -226,7 +217,7 @@ 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))
+ else if (op->op_private & OPpDEREF)
provide_ref(op, curpad[op->op_targ]);
}
RETURN;
@@ -251,9 +242,11 @@ PP(pp_eq)
PP(pp_preinc)
{
dSP;
- 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);
@@ -315,16 +308,31 @@ 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'))) {
+ SV *sv;
+
+ PUSHMARK(MARK-1);
+ *MARK = mg->mg_obj;
+ ENTER;
+ perl_call_method("PRINT", G_SCALAR);
+ LEAVE;
+ SPAGAIN;
+ sv = POPs;
+ SP = ORIGMARK;
+ PUSHs(sv);
+ 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 +342,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 +359,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 +377,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;
}
}
@@ -582,7 +590,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:
@@ -599,11 +607,10 @@ PP(pp_aassign)
(void)av_store(ary,i++,sv);
if (magic)
mg_set(sv);
- tainted = 0;
+ TAINT_NOT;
}
break;
case SVt_PVHV: {
- char *tmps;
SV *tmpstr;
hash = (HV*)sv;
@@ -616,16 +623,17 @@ PP(pp_aassign)
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);
+ (void)hv_store_ent(hash,sv,tmpstr,0);
if (magic)
mg_set(tmpstr);
- tainted = 0;
+ TAINT_NOT;
}
+ if (relem == lastrelem)
+ warn("Odd number of elements in hash list");
}
break;
default:
@@ -717,6 +725,8 @@ PP(pp_aassign)
SP = lastrelem;
else
SP = firstrelem + (lastlelem - firstlelem);
+ while (relem <= SP)
+ *relem++ = &sv_undef;
RETURN;
}
else {
@@ -778,7 +788,7 @@ PP(pp_match)
}
if (!rx->nparens && !global)
gimme = G_SCALAR; /* accidental array context? */
- safebase = (gimme == G_ARRAY) || global;
+ safebase = (((gimme == G_ARRAY) || global) && !sawampersand);
if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
SAVEINT(multiline);
multiline = pm->op_pmflags & PMf_MULTILINE;
@@ -787,7 +797,7 @@ PP(pp_match)
play_it_again:
if (global && rx->startp[0]) {
t = s = rx->endp[0];
- if (s > strend)
+ if (s >= strend)
goto nope;
minmatch = (s == rx->startp[0]);
}
@@ -816,15 +826,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);
@@ -832,8 +837,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;
@@ -847,12 +852,14 @@ play_it_again:
if (gimme == G_ARRAY) {
I32 iters, i, len;
+ TAINT_IF(rx->exec_tainted);
iters = rx->nparens;
if (global && !iters)
i = 1;
else
i = 0;
EXTEND(SP, iters + i);
+ EXTEND_MORTAL(iters + i);
for (i = !i; i <= iters; i++) {
PUSHs(sv_newmortal());
/*SUPPRESS 560*/
@@ -863,6 +870,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;
@@ -880,7 +888,7 @@ 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
@@ -898,6 +906,8 @@ yup:
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;
@@ -908,8 +918,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);
@@ -944,10 +952,22 @@ 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;
+ 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) sv_setsv(TARG, TOPs);
+ RETURN;
+ }
fp = Nullfp;
if (io) {
fp = IoIFP(io);
@@ -984,7 +1004,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};
@@ -1014,7 +1034,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,
@@ -1032,7 +1052,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 &&
@@ -1041,11 +1061,11 @@ 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;
}
@@ -1114,7 +1134,7 @@ do_readline()
}
for (;;) {
if (!sv_gets(sv, fp, offset)) {
- clearerr(fp);
+ PerlIO_clearerr(fp);
if (IoFLAGS(io) & IOf_ARGV) {
fp = nextargv(last_in_gv);
if (fp)
@@ -1131,12 +1151,13 @@ do_readline()
}
RETURN;
}
+ /* This should not be marked tainted if the fp is marked clean */
+ if (!(IoFLAGS(io) & IOf_UNTAINT)) {
+ TAINT;
+ SvTAINTED_on(sv);
+ }
IoLINES(io)++;
XPUSHs(sv);
- if (tainting) {
- tainted = TRUE;
- SvTAINT(sv); /* Anything from the outside world...*/
- }
if (type == OP_GLOB) {
char *tmps;
@@ -1205,25 +1226,27 @@ 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;
if (SvTYPE(hv) != SVt_PVHV)
RETPUSHUNDEF;
- 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 (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)
+ DIE(no_helem, SvPV(keysv, na));
+ 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)
+ provide_ref(op, HeVAL(he));
}
- PUSHs(svp ? *svp : &sv_undef);
+ PUSHs(he ? HeVAL(he) : &sv_undef);
RETURN;
}
@@ -1284,7 +1307,7 @@ PP(pp_iter)
{
dSP;
register CONTEXT *cx;
- SV *sv;
+ SV* sv;
AV* av;
EXTEND(sp, 1);
@@ -1298,13 +1321,26 @@ PP(pp_iter)
if (cx->blk_loop.iterix >= AvFILL(av))
RETPUSHNO;
- 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_dec(LvTARG(lv));
+ else {
+ lv = cx->blk_loop.iterlval = newSVsv(sv);
+ sv_upgrade(lv, SVt_PVLV);
+ sv_magic(lv, Nullsv, 'y', Nullch, 0);
+ LvTYPE(lv) = 'y';
+ }
+ LvTARG(lv) = SvREFCNT_inc(av);
+ LvTARGOFF(lv) = cx->blk_loop.iterix;
+ LvTARGLEN(lv) = 1;
+ sv = (SV*)lv;
+ }
+ *cx->blk_loop.itervar = sv;
RETPUSHYES;
}
@@ -1354,7 +1390,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;
@@ -1381,15 +1417,10 @@ 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);
@@ -1507,7 +1538,7 @@ PP(pp_subst)
else
c = Nullch;
if (pregexec(rx, s, strend, orig, 0,
- SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
+ SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
long_way:
if (force_on_match) {
force_on_match = 0;
@@ -1539,8 +1570,7 @@ 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);
(void)SvOOK_off(TARG);
@@ -1716,13 +1746,12 @@ PP(pp_entersub)
goto retry;
}
tmpstr = sv_newmortal();
- gv_efullname(tmpstr, gv);
+ gv_efullname3(tmpstr, gv, Nullch);
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');
+ SvTAINTED_off(GvSV(CvGV(cv)));
goto retry;
}
else
@@ -1742,7 +1771,7 @@ PP(pp_entersub)
sv_setsv(sv, newRV((SV*)cv));
}
else {
- gv_efullname(sv,gv);
+ gv_efullname3(sv, gv, Nullch);
}
cv = GvCV(DBsub);
if (CvXSUB(cv)) curcopdb = curcop;
@@ -1821,7 +1850,8 @@ PP(pp_entersub)
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
- if (CvDEPTH(cv) == 100 && dowarn)
+ if (CvDEPTH(cv) == 100 && dowarn
+ && !(perldb && cv == GvCV(DBsub)))
warn("Deep recursion on subroutine \"%s\"",GvENAME(CvGV(cv)));
if (CvDEPTH(cv) > AvFILL(padlist)) {
AV *av;
@@ -1832,9 +1862,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 == '@')
@@ -1919,7 +1950,7 @@ PP(pp_aelem)
DIE(no_aelem, elem);
if (op->op_private & OPpLVAL_INTRO)
save_svref(svp);
- else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
+ else if (op->op_private & OPpDEREF)
provide_ref(op, *svp);
}
PUSHs(svp ? *svp : &sv_undef);
@@ -1936,9 +1967,25 @@ SV* 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 (op->op_private & OPpDEREF)
+ {
+ 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);
}
diff --git a/pp_sys.c b/pp_sys.c
index ee51347cdc..5e096feff8 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -17,14 +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
+
+#ifdef I_SYS_WAIT
+# include <sys/wait.h>
+#endif
+
+#ifdef I_SYS_RESOURCE
+# include <sys/resource.h>
#endif
/* Put this after #includes because fork and vfork prototypes may
@@ -46,11 +49,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;
@@ -91,15 +92,64 @@ 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() */
+
+
/* Pushy I/O. */
PP(pp_backtick)
{
dSP; dTARGET;
- FILE *fp;
+ PerlIO *fp;
char *tmps = POPp;
TAINT_PROPER("``");
fp = my_popen(tmps, "r");
@@ -152,7 +202,7 @@ PP(pp_glob)
#ifndef CSH
*SvPVX(rs) = '\n';
#endif /* !CSH */
-#endif /* !MSDOS */
+#endif /* !DOSISH */
result = do_readline();
LEAVE;
@@ -234,16 +284,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
@@ -294,16 +346,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;
}
@@ -322,13 +374,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;
}
@@ -357,7 +409,7 @@ PP(pp_binmode)
dSP;
GV *gv;
IO *io;
- FILE *fp;
+ PerlIO *fp;
if (MAXARG < 1)
RETPUSHUNDEF;
@@ -366,16 +418,16 @@ 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)
RETPUSHYES;
else
RETPUSHUNDEF;
@@ -461,8 +513,8 @@ PP(pp_untie)
SV * sv ;
sv = POPs;
- if (hints & HINT_STRICT_UNTIE)
- {
+
+ if (dowarn) {
MAGIC * mg ;
if (SvMAGICAL(sv)) {
if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
@@ -471,7 +523,7 @@ PP(pp_untie)
mg = mg_find(sv, 'q') ;
if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
- croak("Can't untie: %d inner references still exist",
+ warn("untie attempted while %d inner references still exist",
SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
}
}
@@ -480,7 +532,7 @@ PP(pp_untie)
sv_unmagic(sv, 'P');
else
sv_unmagic(sv, 'q');
- RETSETYES;
+ RETPUSHYES;
}
PP(pp_tied)
@@ -747,7 +799,7 @@ PP(pp_select)
else {
GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
if (gvp && *gvp == egv)
- gv_efullname(TARG, defoutgv);
+ gv_efullname3(TARG, defoutgv, Nullch);
else
sv_setsv(TARG, sv_2mortal(newRV((SV*)egv)));
XPUSHTARG;
@@ -775,9 +827,9 @@ PP(pp_getc)
gv = argvgv;
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;
}
@@ -841,7 +893,7 @@ PP(pp_enterwrite)
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");
@@ -856,13 +908,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(Perl_debug_log,"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)
@@ -903,13 +955,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;
@@ -920,7 +972,7 @@ 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));
}
return doform(cv,gv,op);
@@ -946,15 +998,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);
}
}
@@ -968,7 +1020,7 @@ PP(pp_prtf)
dSP; dMARK; dORIGMARK;
GV *gv;
IO *io;
- FILE *fp;
+ PerlIO *fp;
SV *sv = NEWSV(0,0);
if (op->op_flags & OPf_STACKED)
@@ -977,7 +1029,7 @@ PP(pp_prtf)
gv = defoutgv;
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);
@@ -985,7 +1037,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
@@ -995,12 +1047,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);
@@ -1059,6 +1117,8 @@ PP(pp_sysread)
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)
@@ -1075,7 +1135,8 @@ PP(pp_sysread)
if (op->op_type == OP_RECV) {
bufsize = sizeof buf;
buffer = SvGROW(bufsv, length+1);
- length = recvfrom(fileno(IoIFP(io)), buffer, length, offset,
+ /* 'offset' means 'flags' here */
+ length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
(struct sockaddr *)buf, &bufsize);
if (length < 0)
RETPUSHUNDEF;
@@ -1083,8 +1144,9 @@ PP(pp_sysread)
*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);
PUSHs(TARG);
@@ -1094,28 +1156,38 @@ 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,
+ length = recvfrom(PerlIO_fileno(IoIFP(io)), buffer+offset, length, 0,
(struct sockaddr *)buf, &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;
@@ -1161,24 +1233,30 @@ 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)
+ 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");
@@ -1251,9 +1329,9 @@ PP(pp_truncate)
do_ftruncate:
if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
#ifdef HAS_TRUNCATE
- ftruncate(fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ ftruncate(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#else
- my_chsize(fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
+ my_chsize(PerlIO_fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
#endif
result = 0;
}
@@ -1274,8 +1352,8 @@ PP(pp_truncate)
{
int tmpfd;
- if ((tmpfd = open(SvPV (sv, na), 0)) < 0)
- result = 0;
+ if ((tmpfd = open(SvPV (sv, na), O_RDWR)) < 0)
+ result = 0;
else {
if (my_chsize(tmpfd, len) < 0)
result = 0;
@@ -1340,23 +1418,19 @@ PP(pp_ioctl)
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)) {
@@ -1384,13 +1458,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;
@@ -1401,7 +1471,7 @@ PP(pp_flock)
else
fp = Nullfp;
if (fp) {
- value = (I32)(flock(fileno(fp), argtype) >= 0);
+ value = (I32)(FLOCK(PerlIO_fileno(fp), argtype) >= 0);
}
else
value = 0;
@@ -1440,12 +1510,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;
}
@@ -1484,18 +1554,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;
}
@@ -1521,7 +1591,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;
@@ -1551,7 +1621,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;
@@ -1577,7 +1647,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;
@@ -1620,15 +1690,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;
}
@@ -1660,7 +1730,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:
@@ -1707,7 +1777,7 @@ 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);
@@ -1779,7 +1849,7 @@ PP(pp_getpeername)
SvCUR_set(sv,256);
*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)
@@ -1827,13 +1897,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 {
@@ -1862,14 +1929,17 @@ PP(pp_stat)
}
}
- EXTEND(SP, 13);
if (GIMME != G_ARRAY) {
+ EXTEND(SP, 1);
if (max)
RETPUSHYES;
else
RETPUSHUNDEF;
}
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)));
@@ -2176,7 +2246,7 @@ PP(pp_fttty)
else
gv = gv_fetchpv(tmps = POPp, FALSE, SVt_PVIO);
if (GvIO(gv) && IoIFP(GvIOp(gv)))
- fd = fileno(IoIFP(GvIOp(gv)));
+ fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
else if (isDIGIT(*tmps))
fd = atoi(tmps);
else
@@ -2203,11 +2273,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 {
@@ -2216,30 +2296,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)
@@ -2251,9 +2335,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
@@ -2264,7 +2349,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) {
@@ -2473,7 +2560,7 @@ char *filename;
char *s,
*save_filename = filename;
int anum = 1;
- FILE *myfp;
+ PerlIO *myfp;
strcpy(mybuf, cmd);
strcat(mybuf, " ");
@@ -2485,7 +2572,8 @@ char *filename;
myfp = my_popen(mybuf, "r");
if (myfp) {
*mybuf = '\0';
- s = fgets(mybuf, sizeof mybuf, myfp);
+ /* 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++) {
@@ -2822,10 +2910,9 @@ 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 (defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(OS2)
if (SP - MARK == 1) {
if (tainting) {
char *junk = SvPV(TOPs, na);
@@ -2843,13 +2930,13 @@ 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);
+ (void)rsignal_restore(SIGINT, &ihand);
+ (void)rsignal_restore(SIGQUIT, &qhand);
statusvalue = FIXSTATUS(status);
if (result < 0)
value = -1;
@@ -3047,15 +3134,27 @@ PP(pp_time)
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);
@@ -3066,8 +3165,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)));
@@ -3077,7 +3174,7 @@ PP(pp_tms)
PUSHs(sv_2mortal(newSVnv(((double)timesbuf.tms_cstime)/HZ)));
}
RETURN;
-#endif /* MSDOS */
+#endif /* HAS_TIMES */
}
PP(pp_localtime)
@@ -3109,6 +3206,7 @@ PP(pp_gmtime)
tmbuf = gmtime(&when);
EXTEND(SP, 9);
+ EXTEND_MORTAL(9);
if (GIMME != G_ARRAY) {
dTARGET;
char mybuf[30];
@@ -3164,7 +3262,7 @@ PP(pp_sleep)
(void)time(&lasttime);
if (MAXARG < 1)
- pause();
+ Pause();
else {
duration = POPi;
sleep((unsigned int)duration);
@@ -3577,8 +3675,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
@@ -3949,9 +4050,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");
@@ -4033,7 +4135,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
@@ -4041,12 +4178,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
@@ -4066,23 +4200,7 @@ 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;
@@ -4107,8 +4225,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;
@@ -4120,4 +4239,5 @@ int operation;
}
return (i);
}
-#endif
+
+#endif /* LOCKF_EMULATE_FLOCK */
diff --git a/proto.h b/proto.h
index c6bac403c4..cbf38d48aa 100644
--- a/proto.h
+++ b/proto.h
@@ -28,8 +28,8 @@ 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));
+OP* block_end _((I32 floor, OP* seq));
+int block_start _((int full));
void boot_core_UNIVERSAL _((void));
void calllist _((AV* list));
I32 cando _((I32 bit, I32 effective, struct stat* statbufp));
@@ -46,6 +46,7 @@ char* cpytill _((char* to, char* from, char* fromend, int delim, I32* retlen));
void croak _((char* pat,...)) __attribute__((format(printf,1,2),noreturn));
CV* cv_clone _((CV* proto));
void cv_undef _((CV* cv));
+SV* cv_const_sv _((CV* cv));
#ifdef DEBUGGING
void cx_dump _((CONTEXT* cs));
#endif
@@ -82,9 +83,9 @@ 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));
+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));
@@ -112,7 +113,7 @@ 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));
@@ -125,11 +126,13 @@ GV* gv_HVadd _((GV* gv));
GV* gv_IOadd _((GV* gv));
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_fetchpv _((char* name, I32 add, I32 sv_type));
void gv_fullname _((SV* sv, GV* gv));
+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));
@@ -150,12 +153,15 @@ SV* hv_iterkeysv _((HE* entry));
HE* hv_iternext _((HV* tb));
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));
@@ -172,7 +178,8 @@ I32 looks_like_number _((SV* sv));
int magic_clearenv _((SV* sv, MAGIC* mg));
int magic_clearpack _((SV* sv, MAGIC* mg));
int magic_clearsig _((SV* sv, MAGIC* mg));
-int magic_existspack _((SV* sv, MAGIC* mg));
+int magic_existspack _((SV* sv, MAGIC* mg));
+int magic_freevivary _((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));
@@ -190,10 +197,13 @@ 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));
+int magic_setcollxfrm _((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));
@@ -201,19 +211,14 @@ 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_setvivary _((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));
-extern Malloc_t calloc _((MEM_SIZE, MEM_SIZE));
-#endif
void markstack_grow _((void));
+#ifdef USE_LOCALE_COLLATE
+char* mem_collxfrm _((const char *s, STRLEN len, STRLEN *xlen));
+#endif
char* mess _((char* pat, va_list* args));
int mg_clear _((SV* sv));
int mg_copy _((SV *, SV *, char *, I32));
@@ -226,17 +231,19 @@ int mg_set _((SV* sv));
OP* mod _((OP* op, I32 type));
char* moreswitches _((char* s));
OP * my _(( 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));
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));
+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
@@ -294,7 +301,7 @@ 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));
+PerlIO* nextargv _((GV* gv));
char* ninstr _((char* big, char* bigend, char* little, char* lend));
OP * oopsCV _((OP* o));
void op_free _((OP* arg));
@@ -324,6 +331,12 @@ 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
@@ -348,23 +361,11 @@ char* regnext _((char* p));
char* regprop _((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
-char* safecalloc _((MEM_SIZE cnt, MEM_SIZE size));
-#endif
-#ifdef LEAKTEST
-void safexfree _((char* where));
-char* safexmalloc _((I32 x, MEM_SIZE size));
-char* safexrealloc _((char* where, MEM_SIZE size));
-char* safexcalloc _((I32 x, MEM_SIZE size, MEM_SIZE size));
-#endif
#ifndef HAS_RENAME
I32 same_dirent _((char* a, char* b));
#endif
@@ -372,6 +373,8 @@ char* savepv _((char* sv));
char* savepvn _((char* sv, I32 len));
char* sharepvn _((char* sv, I32 len, U32 hash));
void unsharepvn _((char* sv, I32 len, U32 hash));
+HEK* share_hek _((char* sv, I32 len, U32 hash));
+void unshare_hek _((HEK* hek));
void savestack_grow _((void));
void save_aptr _((AV** aptr));
AV* save_ary _((GV* gv));
@@ -383,11 +386,14 @@ 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_nogv _((GV* gv));
@@ -400,9 +406,9 @@ 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
@@ -419,6 +425,7 @@ 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));
@@ -430,12 +437,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
@@ -457,6 +469,7 @@ void sv_replace _((SV* sv, SV* nsv));
void sv_report_used _((void));
void sv_reset _((char* s, HV* stash));
void sv_setiv _((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));
@@ -465,12 +478,14 @@ 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));
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 taint_env _((void));
-void taint_not _((char *s));
void taint_proper _((char* f, char* s));
#ifdef UNLINK_ALL_VERSIONS
I32 unlnk _((char* f));
@@ -484,3 +499,24 @@ 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/qnx/ar b/qnx/ar
new file mode 100755
index 0000000000..b46549abd1
--- /dev/null
+++ b/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/qnx/cpp b/qnx/cpp
new file mode 100755
index 0000000000..6459af249f
--- /dev/null
+++ b/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/regcomp.c b/regcomp.c
index 1bc1b2d239..bbb7c8e444 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -107,7 +107,7 @@ 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* nextchar _((void));
@@ -132,7 +132,6 @@ char* exp;
char* xend;
PMOP* pm;
{
- I32 fold = pm->op_pmflags & PMf_FOLD;
register regexp *r;
register char *scan;
register SV *longish;
@@ -150,13 +149,14 @@ PMOP* pm;
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 +171,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 +191,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,16 +216,16 @@ 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;
@@ -244,7 +244,7 @@ PMOP* pm;
if (sawplus && (!sawopen || !regsawback))
r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */
- DEBUG_r(fprintf(Perl_debug_log,"first %d next %d offset %d\n",
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "first %d next %d offset %d\n",
OP(first), OP(NEXTOPER(first)), first - scan));
/*
* If there's something expensive in the r.e., find the
@@ -280,7 +280,7 @@ PMOP* pm;
scan = regnext(scan);
continue;
}
- if (OP(scan) == EXACTLY) {
+ if (OP(scan) == EXACT) {
char *t;
first = scan;
@@ -333,8 +333,8 @@ PMOP* pm;
/* Prefer earlier on tie, unless we can tail match latter */
- if (SvCUR(longish) + (regkind[(U8)OP(first)] == EOL) >
- SvCUR(longest))
+ if (SvCUR(longish) + (regkind[(U8)OP(first)] == EOL)
+ > SvCUR(longest))
{
sv_setsv(longest,longish);
backest = backish;
@@ -342,23 +342,18 @@ 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 || 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))
@@ -371,7 +366,6 @@ PMOP* pm;
SvREFCNT_dec(longish);
}
- r->do_folding = fold;
r->nparens = regnpar - 1;
r->minlen = minlen;
Newz(1002, r->startp, regnpar, char*);
@@ -793,32 +787,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;
@@ -887,7 +881,9 @@ 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;
@@ -948,10 +944,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':
@@ -990,8 +984,6 @@ tryagain:
ender = *p++;
break;
}
- if (regflags & PMf_FOLD && isUPPER(ender))
- ender = toLOWER(ender);
if (ISMULT2(p)) { /* Back off on ?+*. */
if (len)
p = oldp;
@@ -1023,24 +1015,20 @@ tryagain:
}
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 +1037,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 +1061,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 +1146,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 +1170,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 != ']')
@@ -1439,7 +1451,7 @@ 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;
@@ -1450,48 +1462,48 @@ regexp *r;
s++;
#endif
op = OP(s);
- fprintf(Perl_debug_log,"%2d%s", s-r->program, regprop(s)); /* Where, what. */
+ PerlIO_printf(Perl_debug_log, "%2d%s", s-r->program, regprop(s)); /* Where, what. */
next = regnext(s);
s += regarglen[(U8)op];
if (next == NULL) /* Next ptr. */
- fprintf(Perl_debug_log,"(0)");
+ PerlIO_printf(Perl_debug_log, "(0)");
else
- fprintf(Perl_debug_log,"(%d)", (s-r->program)+(next-s));
+ PerlIO_printf(Perl_debug_log, "(%d)", (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(' ', Perl_debug_log);
- (void)putc('<', Perl_debug_log);
+ (void)PerlIO_putc(Perl_debug_log, ' ');
+ (void)PerlIO_putc(Perl_debug_log, '<');
while (*s != '\0') {
- (void)putc(*s, Perl_debug_log);
+ (void)PerlIO_putc(Perl_debug_log,*s);
s++;
}
- (void)putc('>', Perl_debug_log);
+ (void)PerlIO_putc(Perl_debug_log, '>');
s++;
}
- (void)putc('\n', Perl_debug_log);
+ (void)PerlIO_putc(Perl_debug_log, '\n');
}
/* Header fields of interest. */
if (r->regstart)
- fprintf(Perl_debug_log,"start `%s' ", SvPVX(r->regstart));
+ PerlIO_printf(Perl_debug_log, "start `%s' ", SvPVX(r->regstart));
if (r->regstclass)
- fprintf(Perl_debug_log,"stclass `%s' ", regprop(r->regstclass));
+ PerlIO_printf(Perl_debug_log, "stclass `%s' ", regprop(r->regstclass));
if (r->reganch & ROPT_ANCH)
- fprintf(Perl_debug_log,"anchored ");
+ PerlIO_printf(Perl_debug_log, "anchored ");
if (r->reganch & ROPT_SKIP)
- fprintf(Perl_debug_log,"plus ");
+ PerlIO_printf(Perl_debug_log, "plus ");
if (r->reganch & ROPT_IMPLICIT)
- fprintf(Perl_debug_log,"implicit ");
+ PerlIO_printf(Perl_debug_log, "implicit ");
if (r->regmust != NULL)
- fprintf(Perl_debug_log,"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(Perl_debug_log, "minlen %ld ", (long) r->minlen);
- fprintf(Perl_debug_log,"\n");
+ PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
+ PerlIO_printf(Perl_debug_log, "\n");
}
/*
@@ -1536,8 +1548,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,29 +1566,17 @@ 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));
@@ -1616,6 +1622,36 @@ 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");
}
diff --git a/regcomp.h b/regcomp.h
index b2d9b846f7..9d07ff9d1c 100644
--- a/regcomp.h
+++ b/regcomp.h
@@ -48,41 +48,49 @@
*/
/* 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 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 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 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 some already matched string */
+#define OPEN 25 /* num Mark this point in input as start of #n. */
+#define CLOSE 26 /* num Analogous to OPEN. */
+#define MINMOD 27 /* no Next operator is not greedy. */
+#define GBOL 28 /* no Matches where last m//g left off. */
+#define IFMATCH 29 /* no Succeeds if the following matches. */
+#define UNLESSM 30 /* no Fails if the following matches. */
+#define SUCCEED 31 /* no Return from a subroutine, basically. */
+#define WHILEM 32 /* no Do curly processing and see if rest matches. */
+#define ALNUM 33 /* no Match any alphanumeric character */
+#define ALNUML 34 /* no Match any alphanumeric char in locale */
+#define NALNUM 35 /* no Match any non-alphanumeric character */
+#define NALNUML 36 /* no Match any non-alphanumeric char in locale */
+#define SPACE 37 /* no Match any whitespace character */
+#define SPACEL 38 /* no Match any whitespace char in locale */
+#define NSPACE 39 /* no Match any non-whitespace character */
+#define NSPACEL 40 /* no Match any non-whitespace char in locale */
+#define DIGIT 41 /* no Match any numeric character */
+#define NDIGIT 42 /* no Match any non-numeric character */
/*
* Opcode notes:
@@ -109,7 +117,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, /*OPEN*/ 2, /*CLOSE*/ 2,
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
+};
#endif
#ifndef DOINIT
@@ -130,18 +144,16 @@ EXT char regkind[] = {
CURLY,
BRANCH,
BACK,
- EXACTLY,
+ EXACT,
+ EXACT,
+ EXACT,
NOTHING,
STAR,
PLUS,
- ALNUM,
- NALNUM,
+ BOUND,
BOUND,
NBOUND,
- SPACE,
- NSPACE,
- DIGIT,
- NDIGIT,
+ NBOUND,
REF,
OPEN,
CLOSE,
@@ -150,7 +162,17 @@ EXT char regkind[] = {
BRANCH,
BRANCH,
END,
- WHILEM
+ WHILEM,
+ ALNUM,
+ ALNUM,
+ NALNUM,
+ NALNUM,
+ SPACE,
+ SPACE,
+ NSPACE,
+ NSPACE,
+ DIGIT,
+ NDIGIT,
};
#endif
@@ -158,14 +180,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, 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 +251,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/regexec.c b/regexec.c
index 818d9dc700..292f96005d 100644
--- a/regexec.c
+++ b/regexec.c
@@ -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;
@@ -147,6 +147,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 +165,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,23 +194,15 @@ 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;
@@ -281,13 +275,13 @@ 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++;
@@ -327,8 +321,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 +332,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 +351,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 +371,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 +398,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 +436,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 +463,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 +523,27 @@ 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)
- Safefree(prog->subbase);
- prog->subbeg = prog->subbase = s;
- prog->subend = s+i;
- }
- else {
- prog->subbeg = s = prog->subbase;
- prog->subend = s+i;
- }
- s += (stringarg - strbeg);
+ prog->exec_tainted = regtainted;
+
+ /* make sure $`, $&, $', and $digit will work later */
+ if (!safebase && (strbeg != prog->subbase)) {
+ 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 +608,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,7 +623,7 @@ char *prog;
#define sayNO goto no
#define saySAME(x) if (x) goto yes; else goto no
if (regnarrate) {
- fprintf(Perl_debug_log, "%*s%2d%-8.8s\t<%.10s>\n", regindent*2, "",
+ PerlIO_printf(Perl_debug_log, "%*s%2d%-8.8s\t<%.10s>\n", regindent*2, "",
scan - regprogram, regprop(scan), locinput);
}
#else
@@ -653,85 +686,130 @@ 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 EXACT:
+ s = OPERAND(scan);
+ ln = *s++;
+ /* Inline the first character, for speed. */
+ if (UCHARAT(s) != nextchar)
+ sayNO;
+ if (regeol - locinput < ln)
+ sayNO;
+ if (ln > 1 && memNE(s, locinput, ln))
+ sayNO;
+ locinput += ln;
+ nextchar = UCHARAT(locinput);
break;
- case EXACTLY:
+ case EXACTFL:
+ regtainted = TRUE;
+ /* FALL THROUGH */
+ case EXACTF:
s = OPERAND(scan);
ln = *s++;
/* Inline the first character, for speed. */
- if (*s != nextchar)
+ if (UCHARAT(s) != nextchar &&
+ UCHARAT(s) != ((OP(scan) == EXACTF)
+ ? fold : fold_locale)[nextchar])
sayNO;
if (regeol - locinput < ln)
sayNO;
- if (ln > 1 && bcmp(s, locinput, ln) != 0)
+ if (ln > 1 && (OP(scan) == EXACTF
+ ? ibcmp(s, locinput, ln)
+ : ibcmp_locale(s, locinput, ln)))
sayNO;
locinput += ln;
- nextchar = *locinput;
+ 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 REF:
n = ARG1(scan); /* which paren pair */
@@ -743,15 +821,15 @@ char *prog;
if (s == regendp[n])
break;
/* Inline the first character, for speed. */
- if (*s != nextchar)
+ if (UCHARAT(s) != nextchar)
sayNO;
ln = regendp[n] - s;
if (locinput + ln > regeol)
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 NOTHING:
@@ -800,13 +878,14 @@ 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(Perl_debug_log, "%*s %d %lx\n", regindent*2, "",
+ PerlIO_printf(Perl_debug_log, "%*s %d %lx\n", regindent*2, "",
n, (long)cc);
#endif
@@ -838,8 +917,12 @@ char *prog;
if (cc->minmod) {
regcc = cc->oldcc;
ln = regcc->cur;
- if (regmatch(cc->next))
+ cp = regcppush(cc->parenfloor);
+ if (regmatch(cc->next)) {
+ regcpblow(cp);
sayYES; /* All done. */
+ }
+ regcppop();
regcc->cur = ln;
regcc = cc;
@@ -850,8 +933,12 @@ char *prog;
reginput = locinput;
cc->cur = n;
cc->lastloc = locinput;
- if (regmatch(cc->scan))
+ cp = regcppush(cc->parenfloor);
+ if (regmatch(cc->scan)) {
+ regcpblow(cp);
sayYES;
+ }
+ regcppop();
cc->cur = n - 1;
sayNO;
}
@@ -859,11 +946,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)) {
+ regcpblow(cp);
sayYES;
+ }
regcppop(); /* Restore some previous $<digit>s? */
reginput = locinput;
}
@@ -929,10 +1018,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 +1036,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 +1060,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 +1090,7 @@ char *prog;
sayNO;
break;
default:
- fprintf(stderr, "%x %d\n",(unsigned)scan,scan[1]);
+ PerlIO_printf(PerlIO_stderr(), "%x %d\n",(unsigned)scan,scan[1]);
FAIL("regexp memory corruption");
}
scan = next;
@@ -1043,34 +1147,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 +1224,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/regexp.h b/regexp.h
index 018312ec24..ebd30ada53 100644
--- a/regexp.h
+++ b/regexp.h
@@ -26,7 +26,7 @@ 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;
diff --git a/run.c b/run.c
index e168611b28..a952dac986 100644
--- a/run.c
+++ b/run.c
@@ -47,7 +47,7 @@ runops() {
do {
if (debug) {
if (watchaddr != 0 && *watchaddr != watchok)
- fprintf(Perl_debug_log, "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));
@@ -65,23 +65,23 @@ OP *op;
deb("%s", op_name[op->op_type]);
switch (op->op_type) {
case OP_CONST:
- fprintf(Perl_debug_log, "(%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(Perl_debug_log, "(%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(Perl_debug_log, "(NULL)");
+ PerlIO_printf(Perl_debug_log, "(NULL)");
break;
default:
break;
}
- fprintf(Perl_debug_log, "\n");
+ PerlIO_printf(Perl_debug_log, "\n");
return 0;
}
@@ -91,7 +91,7 @@ char **addr;
{
watchaddr = addr;
watchok = *addr;
- fprintf(Perl_debug_log, "WATCHING, %lx is currently %lx\n",
+ PerlIO_printf(Perl_debug_log, "WATCHING, %lx is currently %lx\n",
(long)watchaddr, (long)watchok);
}
@@ -112,7 +112,7 @@ debprofdump()
return;
for (i = 0; i < MAXO; i++) {
if (profiledata[i])
- fprintf(Perl_debug_log, "%d\t%lu\n", i, profiledata[i]);
+ PerlIO_printf(Perl_debug_log, "%d\t%lu\n", i, profiledata[i]);
}
}
diff --git a/scope.c b/scope.c
index 278a5af4fd..afdcf44e76 100644
--- a/scope.c
+++ b/scope.c
@@ -143,27 +143,30 @@ GV *gv;
return sv;
}
-#ifdef INLINED_ELSEWHERE
void
-save_gp(gv)
+save_gp(gv, empty)
GV *gv;
+I32 empty;
{
- register GP *gp;
- GP *ogp = GvGP(gv);
-
SSCHECK(3);
SSPUSHPTR(SvREFCNT_inc(gv));
- SSPUSHPTR(ogp);
+ SSPUSHPTR(GvGP(gv));
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;
+ if (empty) {
+ register GP *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;
+ }
+ else {
+ GvGP(gv)->gp_refcnt++;
+ GvINTRO_on(gv);
+ }
}
-#endif
SV*
save_svref(sptr)
@@ -272,6 +275,16 @@ I32 *intp;
}
void
+save_I16(intp)
+I16 *intp;
+{
+ SSCHECK(3);
+ SSPUSHINT(*intp);
+ SSPUSHPTR(intp);
+ SSPUSHINT(SAVEt_I16);
+}
+
+void
save_iv(ivp)
IV *ivp;
{
@@ -496,6 +509,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;
@@ -601,6 +618,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");
}
@@ -613,88 +636,88 @@ void
cx_dump(cx)
CONTEXT* cx;
{
- fprintf(Perl_debug_log, "CX %d = %s\n", cx - cxstack, block_type[cx->cx_type]);
+ PerlIO_printf(Perl_debug_log, "CX %d = %s\n", cx - cxstack, block_type[cx->cx_type]);
if (cx->cx_type != CXt_SUBST) {
- fprintf(Perl_debug_log, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
- fprintf(Perl_debug_log, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop);
- fprintf(Perl_debug_log, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
- fprintf(Perl_debug_log, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
- fprintf(Perl_debug_log, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp);
- fprintf(Perl_debug_log, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm);
- fprintf(Perl_debug_log, "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(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n",
(long)cx->blk_sub.cv);
- fprintf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n",
(long)cx->blk_sub.gv);
- fprintf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n",
(long)cx->blk_sub.dfoutgv);
- fprintf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
+ PerlIO_printf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
(long)cx->blk_sub.olddepth);
- fprintf(Perl_debug_log, "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(Perl_debug_log, "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(Perl_debug_log, "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(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
+ PerlIO_printf(Perl_debug_log, "BLK_EVAL.OLD_NAME = %s\n",
cx->blk_eval.old_name);
- fprintf(Perl_debug_log, "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(Perl_debug_log, "BLK_LOOP.LABEL = %s\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.LABEL = %s\n",
cx->blk_loop.label);
- fprintf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
(long)cx->blk_loop.resetsp);
- fprintf(Perl_debug_log, "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(Perl_debug_log, "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(Perl_debug_log, "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(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERIX = %ld\n",
(long)cx->blk_loop.iterix);
- fprintf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n",
(long)cx->blk_loop.iterary);
- fprintf(Perl_debug_log, "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(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n",
(long)cx->blk_loop.itersave);
break;
case CXt_SUBST:
- fprintf(Perl_debug_log, "SB_ITERS = %ld\n",
+ PerlIO_printf(Perl_debug_log, "SB_ITERS = %ld\n",
(long)cx->sb_iters);
- fprintf(Perl_debug_log, "SB_MAXITERS = %ld\n",
+ PerlIO_printf(Perl_debug_log, "SB_MAXITERS = %ld\n",
(long)cx->sb_maxiters);
- fprintf(Perl_debug_log, "SB_SAFEBASE = %ld\n",
+ PerlIO_printf(Perl_debug_log, "SB_SAFEBASE = %ld\n",
(long)cx->sb_safebase);
- fprintf(Perl_debug_log, "SB_ONCE = %ld\n",
+ PerlIO_printf(Perl_debug_log, "SB_ONCE = %ld\n",
(long)cx->sb_once);
- fprintf(Perl_debug_log, "SB_ORIG = %s\n",
+ PerlIO_printf(Perl_debug_log, "SB_ORIG = %s\n",
cx->sb_orig);
- fprintf(Perl_debug_log, "SB_DSTR = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "SB_DSTR = 0x%lx\n",
(long)cx->sb_dstr);
- fprintf(Perl_debug_log, "SB_TARG = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "SB_TARG = 0x%lx\n",
(long)cx->sb_targ);
- fprintf(Perl_debug_log, "SB_S = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "SB_S = 0x%lx\n",
(long)cx->sb_s);
- fprintf(Perl_debug_log, "SB_M = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "SB_M = 0x%lx\n",
(long)cx->sb_m);
- fprintf(Perl_debug_log, "SB_STREND = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "SB_STREND = 0x%lx\n",
(long)cx->sb_strend);
- fprintf(Perl_debug_log, "SB_SUBBASE = 0x%lx\n",
+ PerlIO_printf(Perl_debug_log, "SB_SUBBASE = 0x%lx\n",
(long)cx->sb_subbase);
break;
}
diff --git a/scope.h b/scope.h
index 0ea343a0e5..53081a3b44 100644
--- a/scope.h
+++ b/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,28 @@
#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((void(*)_((void*)))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
diff --git a/sv.c b/sv.c
index 96c812c0ab..95c3340e94 100644
--- a/sv.c
+++ b/sv.c
@@ -40,12 +40,13 @@
# 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,40 +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; \
- SvFLAGS(p) = SVTYPEMASK; \
- sv_root = p; \
- --sv_count; \
- }
+ else \
+ plant_SV(p)
static void
del_sv(p)
@@ -128,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)
@@ -173,6 +253,8 @@ U32 flags;
static SV*
more_sv()
{
+ register SV* sv;
+
if (nice_chunk) {
sv_add_arena(nice_chunk, nice_chunk_size, 0);
nice_chunk = Nullch;
@@ -182,74 +264,88 @@ more_sv()
New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
sv_add_arena(chunk, 1008, 0);
}
- return new_sv();
+ 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 = (GV*)sva + 1;
- svend = &sva[SvREFCNT(sva)];
- while ((SV*)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;
- }
- }
+
+void
+sv_clean_objs()
+{
+#ifndef DISABLE_DESTRUCTOR_KLUDGE
+ visit(do_clean_named_objs);
+#endif
+ visit(do_clean_objs);
+}
+
+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 int in_clean_all = 0;
@@ -257,23 +353,8 @@ static int in_clean_all = 0;
void
sv_clean_all()
{
- SV* sva;
- register SV* sv;
- register SV* svend;
-
in_clean_all = 1;
- 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(Perl_debug_log, "Cleaning loops:\n "), sv_dump(sv));)
- SvFLAGS(sv) |= SVf_BREAK;
- SvREFCNT_dec(sv);
- }
- ++sv;
- }
- }
+ visit(do_clean_all);
in_clean_all = 0;
}
@@ -294,6 +375,9 @@ sv_free_arenas()
if (!SvFAKE(sva))
Safefree((void *)sva);
}
+
+ sv_arenaroot = 0;
+ sv_root = 0;
}
static XPVIV*
@@ -583,7 +667,6 @@ U32 mt;
stash = 0;
break;
case SVt_PV:
- nv = 0.0;
pv = SvPVX(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
@@ -598,7 +681,6 @@ U32 mt;
mt = SVt_PVNV;
break;
case SVt_PVIV:
- nv = 0.0;
pv = SvPVX(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
@@ -609,7 +691,6 @@ U32 mt;
del_XPVIV(SvANY(sv));
break;
case SVt_PVNV:
- nv = SvNVX(sv);
pv = SvPVX(sv);
cur = SvCUR(sv);
len = SvLEN(sv);
@@ -701,8 +782,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;
@@ -924,8 +1005,10 @@ register SV *sv;
else
sprintf(t,"(\"%.127s\")",SvPVX(sv));
}
- else if (SvNOKp(sv))
+ else if (SvNOKp(sv)) {
+ SET_NUMERIC_STANDARD();
sprintf(t,"(%g)",SvNVX(sv));
+ }
else if (SvIOKp(sv))
sprintf(t,"(%ld)",(long)SvIVX(sv));
else
@@ -969,12 +1052,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) {
@@ -1043,6 +1126,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;
@@ -1100,17 +1194,33 @@ SV *sv;
int i;
for (s = SvPVX(sv), i = 50; *s && i; s++,i--) {
- int ch = *s;
- if (ch & 128 && !isprint(ch)) {
+ 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) {
@@ -1143,14 +1253,10 @@ 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 (!SvROK(sv)) {
- return 0;
- }
+ if (SvPOKp(sv) && SvLEN(sv))
+ return asIV(sv);
+ if (!SvROK(sv))
+ return 0;
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
@@ -1168,11 +1274,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;
@@ -1194,25 +1297,88 @@ 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;
}
- (void)SvIOK_on(sv);
- DEBUG_c(fprintf(Perl_debug_log,"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))
+ 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);
+ return SvUVX(sv);
+ 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;
@@ -1226,6 +1392,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))
@@ -1247,6 +1414,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))
@@ -1261,7 +1429,9 @@ register SV *sv;
sv_upgrade(sv, SVt_PVNV);
else
sv_upgrade(sv, SVt_NV);
- DEBUG_c(fprintf(Perl_debug_log,"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);
@@ -1273,6 +1443,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 {
@@ -1281,10 +1452,103 @@ register SV *sv;
return 0.0;
}
SvNOK_on(sv);
- DEBUG_c(fprintf(Perl_debug_log,"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);
+
+ if (numtype == 1)
+ return atol(SvPVX(sv));
+ 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 = 1;
+ 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 >= send)
+ return 0;
+ if (*s == '+' || *s == '-')
+ s++;
+ while (isDIGIT(*s))
+ s++;
+ if (s == send)
+ return numtype;
+ if (*s == '.') {
+ numtype = 1;
+ s++;
+ }
+ else if (s == SvPVX(sv))
+ return 0;
+ while (isDIGIT(*s))
+ s++;
+ if (s == send)
+ return numtype;
+ if (*s == 'e' || *s == 'E') {
+ numtype = 2;
+ s++;
+ if (*s == '+' || *s == '-')
+ s++;
+ while (isDIGIT(*s))
+ s++;
+ }
+ 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;
@@ -1308,6 +1572,7 @@ STRLEN *lp;
goto tokensave;
}
if (SvNOKp(sv)) {
+ SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
goto tokensave;
}
@@ -1343,7 +1608,7 @@ 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;
}
if (SvOBJECT(sv))
@@ -1358,6 +1623,7 @@ STRLEN *lp;
}
if (SvREADONLY(sv)) {
if (SvNOKp(sv)) {
+ SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
goto tokensave;
}
@@ -1384,7 +1650,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])
@@ -1416,7 +1685,7 @@ STRLEN *lp;
*lp = s - SvPVX(sv);
SvCUR_set(sv, *lp);
SvPOK_on(sv);
- DEBUG_c(fprintf(Perl_debug_log,"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:
@@ -1441,7 +1710,7 @@ STRLEN *lp;
s = SvGROW(sv, len + 1);
SvCUR_set(sv, len);
(void)strcpy(s, tokenbuf);
- /* NO SvPOK_on(sv) here! */
+ SvPOKp_on(sv);
return s;
}
}
@@ -1532,22 +1801,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;
@@ -1580,7 +1847,7 @@ register SV *sstr;
break;
case SVt_PVLV:
- sv_upgrade(dstr, SVt_PVNV);
+ sv_upgrade(dstr, SVt_PVLV);
break;
case SVt_PVAV:
@@ -1713,6 +1980,7 @@ register SV *sstr;
return;
}
if (SvPVX(dstr)) {
+ (void)SvOOK_off(dstr); /* backoff */
Safefree(SvPVX(dstr));
SvLEN(dstr)=SvCUR(dstr)=0;
}
@@ -1808,7 +2076,8 @@ register SV *sv;
register 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);
@@ -1989,7 +2258,7 @@ STRLEN len;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -2012,7 +2281,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))) {
@@ -2064,6 +2333,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;
@@ -2076,6 +2348,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;
@@ -2083,6 +2358,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;
@@ -2109,6 +2389,9 @@ I32 namlen;
case 'x':
mg->mg_virtual = &vtbl_substr;
break;
+ case 'y':
+ mg->mg_virtual = &vtbl_vivary;
+ break;
case '*':
mg->mg_virtual = &vtbl_glob;
break;
@@ -2334,7 +2617,7 @@ register SV *sv;
SvROK_off(ret);
SvREFCNT(sv) = 0;
} else {
- croak("panic: dangling references in DESTROY");
+ croak("DESTROY created new reference to dead object");
}
}
}
@@ -2342,7 +2625,10 @@ register SV *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));
@@ -2519,59 +2805,137 @@ 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
+
+char *
+sv_collxfrm(sv, nxp)
+ SV *sv;
+ STRLEN *nxp;
+{
+ /* 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. */
+
+ MAGIC *mg = NULL;
+
+ if (SvMAGICAL(sv)) {
+ mg = mg_find(sv, 'o');
+ if (mg && *(U32*)mg->mg_ptr != collation_ix)
+ mg = NULL;
+ }
+
+ if (! mg) {
+ char *s, *xf;
+ STRLEN len, xlen;
+
+ s = SvPV(sv, len);
+ if ((xf = mem_collxfrm(s, len, &xlen))) {
+ sv_magic(sv, 0, 'o', 0, 0);
+ if ((mg = mg_find(sv, 'o'))) {
+ mg->mg_ptr = xf;
+ mg->mg_len = xlen;
+ }
+ }
+ }
+
+ if (mg) {
+ *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;
@@ -2581,16 +2945,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);
@@ -2599,6 +2953,7 @@ I32 append;
}
if (!SvUPGRADE(sv, SVt_PV))
return 0;
+ SvSCREAM_off(sv);
if (RsSNARF(rs)) {
rsptr = NULL;
@@ -2614,23 +2969,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) {
@@ -2639,24 +3020,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=%d, cnt=%d\n",ptr,cnt));
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: entering: FILE * thinks ptr=%d, cnt=%d, base=%d\n",
+ PerlIO_get_ptr(fp), PerlIO_get_cnt(fp),
+ 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;
@@ -2673,15 +3062,28 @@ I32 append;
continue;
}
- FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */
- FILE_ptr(fp) = ptr;
-#if defined(__Lynx__)
- i = _fillbuf(fp); /* get more characters */
-#else
- i = _filbuf(fp); /* get more characters */
-#endif
- cnt = FILE_cnt(fp);
- ptr = FILE_ptr(fp); /* reregisterize cnt and ptr */
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: going to getc, ptr=%d, cnt=%d\n",ptr,cnt));
+ PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: pre: FILE * thinks ptr=%d, cnt=%d, base=%d\n",
+ PerlIO_get_ptr(fp), PerlIO_get_cnt(fp),
+ 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 another
+ abstraction. This may also avoid issues with different named
+ 'filbuf' equivalents, though Configure tries to handle them now
+ anyway.
+ */
+ i = PerlIO_getc(fp); /* get more characters */
+ DEBUG_P(PerlIO_printf(Perl_debug_log,
+ "Screamer: post: FILE * thinks ptr=%d, cnt=%d, base=%d\n",
+ PerlIO_get_ptr(fp), PerlIO_get_cnt(fp),
+ 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=%d, cnt=%d\n",ptr,cnt));
if (i == EOF) /* all done for ever? */
goto thats_really_all_folks;
@@ -2691,7 +3093,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;
@@ -2699,64 +3101,65 @@ 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=%d, cnt=%d\n",ptr,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=%d, cnt=%d, base=%d\n",
+ PerlIO_get_ptr(fp), PerlIO_get_cnt(fp),
+ 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=%d, string=|%.*s|\n",
+ SvCUR(sv),SvCUR(sv),SvPVX(sv)));
+ }
+ else
{
+ /*The big, slow, and stupid way */
STDCHAR buf[8192];
-screamer:
+screamer2:
if (rslen) {
- if (rslast == '\n') {
- i = fgets(buf,sizeof buf,fp) == NULL ? EOF : *buf;
- cnt = i == EOF ? 0 : strlen(buf);
- }
- else {
- register STDCHAR *bpe = buf + sizeof(buf);
- bp = buf;
- while ((i = getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
- ; /* keep reading */
- cnt = bp - buf;
- }
+ register STDCHAR *bpe = buf + sizeof(buf);
+ bp = buf;
+ while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
+ ; /* keep reading */
+ cnt = bp - buf;
}
else {
- cnt = fread((char*)buf, 1, sizeof(buf), fp);
- i = cnt ? !EOF : 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;
+ 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;
}
}
@@ -2765,6 +3168,7 @@ screamer:
return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
}
+
void
sv_inc(sv)
register SV *sv;
@@ -2787,14 +3191,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)) {
@@ -2808,7 +3216,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--;
@@ -2857,16 +3266,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);
@@ -2874,7 +3287,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
@@ -2885,7 +3299,7 @@ register SV *sv;
static void
sv_mortalgrow()
{
- tmps_max += 128;
+ tmps_max += (tmps_max < 512) ? 128 : 512;
Renew(tmps_stack, tmps_max, SV*);
}
@@ -2895,7 +3309,7 @@ SV *oldstr;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -2912,7 +3326,7 @@ sv_newmortal()
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = SVs_TEMP;
@@ -2946,7 +3360,7 @@ STRLEN len;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -2962,7 +3376,7 @@ double n;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -2976,7 +3390,7 @@ IV i;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -2990,7 +3404,7 @@ SV *ref;
{
register SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
@@ -3001,6 +3415,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 *
@@ -3015,7 +3442,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;
@@ -3147,7 +3574,7 @@ I32 lref;
SV *tmpsv;
ENTER;
tmpsv = NEWSV(704,0);
- gv_efullname(tmpsv, gv);
+ gv_efullname3(tmpsv, gv, Nullch);
newSUB(start_subparse(),
newSVOP(OP_CONST, 0, tmpsv),
Nullop,
@@ -3190,30 +3617,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 *
@@ -3269,7 +3706,7 @@ STRLEN *lp;
if (!SvPOK(sv)) {
SvPOK_on(sv); /* validate pointer */
SvTAINT(sv);
- DEBUG_c(fprintf(Perl_debug_log,"0x%lx 2pv(%s)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
(unsigned long)sv,SvPVX(sv)));
}
}
@@ -3342,7 +3779,7 @@ char *classname;
{
SV *sv;
- new_SV();
+ new_SV(sv);
SvANY(sv) = 0;
SvREFCNT(sv) = 0;
SvFLAGS(sv) = 0;
@@ -3460,6 +3897,70 @@ SV* sv;
sv_2mortal(rv); /* Schedule for freeing later */
}
+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;
+}
+
+void
+sv_taint(sv)
+SV *sv;
+{
+ sv_magic((sv), Nullsv, 't', Nullch, 0);
+}
+
+void
+sv_untaint(sv)
+SV *sv;
+{
+ if (SvMAGICAL(sv)) {
+ MAGIC *mg = mg_find(sv, 't');
+ if (mg)
+ mg->mg_len &= ~1;
+ }
+}
+
+bool
+sv_tainted(sv)
+SV *sv;
+{
+ if (SvMAGICAL(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;
+}
+
#ifdef DEBUGGING
void
sv_dump(sv)
@@ -3471,7 +3972,7 @@ SV* sv;
U32 type;
if (!sv) {
- fprintf(Perl_debug_log, "SV = 0\n");
+ PerlIO_printf(Perl_debug_log, "SV = 0\n");
return;
}
@@ -3514,8 +4015,27 @@ SV* sv;
if (CvCLONE(sv)) strcat(d, "CLONE,");
if (CvCLONED(sv)) strcat(d, "CLONED,");
break;
+ case SVt_PVHV:
+ if (HvSHAREKEYS(sv)) strcat(d, "SHAREKEYS,");
+ if (HvLAZYDEL(sv)) strcat(d, "LAZYDEL,");
+ break;
case SVt_PVGV:
- if (GvMULTI(sv)) strcat(d, "MULTI,");
+ if (GvINTRO(sv)) strcat(d, "INTRO,");
+ if (GvMULTI(sv)) strcat(d, "MULTI,");
+ if (GvASSUMECV(sv)) strcat(d, "ASSUMECV,");
+ if (GvIMPORTED(sv)) {
+ strcat(d, "IMPORT");
+ if (GvIMPORTED(sv) == GVf_IMPORTED)
+ strcat(d, "ALL,");
+ else {
+ strcat(d, "(");
+ if (GvIMPORTED_SV(sv)) strcat(d, " SV");
+ if (GvIMPORTED_AV(sv)) strcat(d, " AV");
+ if (GvIMPORTED_HV(sv)) strcat(d, " HV");
+ if (GvIMPORTED_CV(sv)) strcat(d, " CV");
+ strcat(d, " ),");
+ }
+ }
#ifdef OVERLOAD
if (flags & SVpgv_AM) strcat(d, "withOVERLOAD,");
#endif /* OVERLOAD */
@@ -3527,66 +4047,68 @@ SV* sv;
*d++ = ')';
*d = '\0';
- fprintf(Perl_debug_log, "SV = ");
+ PerlIO_printf(Perl_debug_log, "SV = ");
switch (type) {
case SVt_NULL:
- fprintf(Perl_debug_log,"NULL%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "NULL%s\n", tmpbuf);
return;
case SVt_IV:
- fprintf(Perl_debug_log,"IV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "IV%s\n", tmpbuf);
break;
case SVt_NV:
- fprintf(Perl_debug_log,"NV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "NV%s\n", tmpbuf);
break;
case SVt_RV:
- fprintf(Perl_debug_log,"RV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "RV%s\n", tmpbuf);
break;
case SVt_PV:
- fprintf(Perl_debug_log,"PV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PV%s\n", tmpbuf);
break;
case SVt_PVIV:
- fprintf(Perl_debug_log,"PVIV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVIV%s\n", tmpbuf);
break;
case SVt_PVNV:
- fprintf(Perl_debug_log,"PVNV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVNV%s\n", tmpbuf);
break;
case SVt_PVBM:
- fprintf(Perl_debug_log,"PVBM%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVBM%s\n", tmpbuf);
break;
case SVt_PVMG:
- fprintf(Perl_debug_log,"PVMG%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVMG%s\n", tmpbuf);
break;
case SVt_PVLV:
- fprintf(Perl_debug_log,"PVLV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVLV%s\n", tmpbuf);
break;
case SVt_PVAV:
- fprintf(Perl_debug_log,"PVAV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVAV%s\n", tmpbuf);
break;
case SVt_PVHV:
- fprintf(Perl_debug_log,"PVHV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVHV%s\n", tmpbuf);
break;
case SVt_PVCV:
- fprintf(Perl_debug_log,"PVCV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVCV%s\n", tmpbuf);
break;
case SVt_PVGV:
- fprintf(Perl_debug_log,"PVGV%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVGV%s\n", tmpbuf);
break;
case SVt_PVFM:
- fprintf(Perl_debug_log,"PVFM%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVFM%s\n", tmpbuf);
break;
case SVt_PVIO:
- fprintf(Perl_debug_log,"PVIO%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "PVIO%s\n", tmpbuf);
break;
default:
- fprintf(Perl_debug_log,"UNKNOWN%s\n", tmpbuf);
+ PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", tmpbuf);
return;
}
if (type >= SVt_PVIV || type == SVt_IV)
- fprintf(Perl_debug_log, " IV = %ld\n", (long)SvIVX(sv));
- if (type >= SVt_PVNV || type == SVt_NV)
- fprintf(Perl_debug_log, " 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(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv));
+ PerlIO_printf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv));
sv_dump(SvRV(sv));
return;
}
@@ -3594,32 +4116,32 @@ SV* sv;
return;
if (type <= SVt_PVLV) {
if (SvPVX(sv))
- fprintf(Perl_debug_log, " 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(Perl_debug_log, " PV = 0\n");
+ PerlIO_printf(Perl_debug_log, " PV = 0\n");
}
if (type >= SVt_PVMG) {
if (SvMAGIC(sv)) {
- fprintf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv));
+ PerlIO_printf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv));
}
if (SvSTASH(sv))
- fprintf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv)));
+ PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv)));
}
switch (type) {
case SVt_PVLV:
- fprintf(Perl_debug_log, " TYPE = %c\n", LvTYPE(sv));
- fprintf(Perl_debug_log, " TARGOFF = %ld\n", (long)LvTARGOFF(sv));
- fprintf(Perl_debug_log, " TARGLEN = %ld\n", (long)LvTARGLEN(sv));
- fprintf(Perl_debug_log, " 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(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv));
- fprintf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv));
- fprintf(Perl_debug_log, " FILL = %ld\n", (long)AvFILL(sv));
- fprintf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv));
- fprintf(Perl_debug_log, " 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;
*d = '\0';
@@ -3628,78 +4150,77 @@ SV* sv;
if (flags & AVf_REUSED) strcat(d, "REUSED,");
if (*d)
d[strlen(d)-1] = '\0';
- fprintf(Perl_debug_log, " FLAGS = (%s)\n", d);
+ PerlIO_printf(Perl_debug_log, " FLAGS = (%s)\n", d);
break;
case SVt_PVHV:
- fprintf(Perl_debug_log, " ARRAY = 0x%lx\n",(long)HvARRAY(sv));
- fprintf(Perl_debug_log, " KEYS = %ld\n", (long)HvKEYS(sv));
- fprintf(Perl_debug_log, " FILL = %ld\n", (long)HvFILL(sv));
- fprintf(Perl_debug_log, " MAX = %ld\n", (long)HvMAX(sv));
- fprintf(Perl_debug_log, " RITER = %ld\n", (long)HvRITER(sv));
- fprintf(Perl_debug_log, " 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(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv));
+ PerlIO_printf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv));
if (HvNAME(sv))
- fprintf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv));
+ PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv));
break;
case SVt_PVFM:
case SVt_PVCV:
if (SvPOK(sv))
- fprintf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,na));
- fprintf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv));
- fprintf(Perl_debug_log, " START = 0x%lx\n", (long)CvSTART(sv));
- fprintf(Perl_debug_log, " ROOT = 0x%lx\n", (long)CvROOT(sv));
- fprintf(Perl_debug_log, " XSUB = 0x%lx\n", (long)CvXSUB(sv));
- fprintf(Perl_debug_log, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32);
- fprintf(stderr, " GV = 0x%lx", (long)CvGV(sv));
+ PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,na));
+ 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))) {
- fprintf(stderr, " \"%s\"\n", GvNAME(CvGV(sv)));
+ PerlIO_printf(Perl_debug_log, " \"%s\"\n", GvNAME(CvGV(sv)));
} else {
- fprintf(stderr, "\n");
+ PerlIO_printf(Perl_debug_log, "\n");
}
- fprintf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv));
- fprintf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv));
- fprintf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv));
- fprintf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv));
+ 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(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv));
+ PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv));
break;
case SVt_PVGV:
- fprintf(Perl_debug_log, " NAME = \"%s\"\n", GvNAME(sv));
- fprintf(Perl_debug_log, " NAMELEN = %ld\n", (long)GvNAMELEN(sv));
- fprintf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv)));
- fprintf(Perl_debug_log, " GP = 0x%lx\n", (long)GvGP(sv));
- fprintf(Perl_debug_log, " SV = 0x%lx\n", (long)GvSV(sv));
- fprintf(Perl_debug_log, " REFCNT = %ld\n", (long)GvREFCNT(sv));
- fprintf(Perl_debug_log, " IO = 0x%lx\n", (long)GvIOp(sv));
- fprintf(Perl_debug_log, " FORM = 0x%lx\n", (long)GvFORM(sv));
- fprintf(Perl_debug_log, " AV = 0x%lx\n", (long)GvAV(sv));
- fprintf(Perl_debug_log, " HV = 0x%lx\n", (long)GvHV(sv));
- fprintf(Perl_debug_log, " CV = 0x%lx\n", (long)GvCV(sv));
- fprintf(Perl_debug_log, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv));
- fprintf(Perl_debug_log, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv));
- fprintf(Perl_debug_log, " LINE = %ld\n", (long)GvLINE(sv));
- fprintf(Perl_debug_log, " FLAGS = 0x%x\n", (int)GvFLAGS(sv));
- fprintf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(GvSTASH(sv)));
- fprintf(Perl_debug_log, " 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(Perl_debug_log, " IFP = 0x%lx\n", (long)IoIFP(sv));
- fprintf(Perl_debug_log, " OFP = 0x%lx\n", (long)IoOFP(sv));
- fprintf(Perl_debug_log, " DIRP = 0x%lx\n", (long)IoDIRP(sv));
- fprintf(Perl_debug_log, " LINES = %ld\n", (long)IoLINES(sv));
- fprintf(Perl_debug_log, " PAGE = %ld\n", (long)IoPAGE(sv));
- fprintf(Perl_debug_log, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv));
- fprintf(Perl_debug_log, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv));
- fprintf(Perl_debug_log, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
- fprintf(Perl_debug_log, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv));
- fprintf(Perl_debug_log, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
- fprintf(Perl_debug_log, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv));
- fprintf(Perl_debug_log, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
- fprintf(Perl_debug_log, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv));
- fprintf(Perl_debug_log, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv));
- fprintf(Perl_debug_log, " TYPE = %c\n", IoTYPE(sv));
- fprintf(Perl_debug_log, " 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;
}
}
@@ -3710,38 +4231,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/sv.h b/sv.h
index 5b3a72a4ad..36fa72d749 100644
--- a/sv.h
+++ b/sv.h
@@ -126,10 +126,10 @@ struct io {
#define SVpfm_COMPILED 0x80000000
#define SVpbm_VALID 0x80000000
-#define SVpbm_CASEFOLD 0x40000000
-#define SVpbm_TAIL 0x20000000
+#define SVpbm_TAIL 0x40000000
#define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */
+#define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */
#ifdef OVERLOAD
#define SVpgv_AM 0x40000000
@@ -153,6 +153,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 */
@@ -247,8 +254,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; /* $% */
@@ -269,6 +276,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. */
@@ -400,10 +408,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)
@@ -413,6 +417,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
@@ -472,11 +478,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)
@@ -484,6 +495,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)
@@ -491,14 +503,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 \
@@ -517,12 +540,20 @@ 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)
@@ -531,6 +562,8 @@ I32 SvTRUE _((SV *));
#define SvPEEK(sv) sv_peek(sv)
+#define SvIMMORTAL(sv) ((sv)==&sv_undef || (sv)==&sv_yes || (sv)==&sv_no)
+
#define isGV(sv) (SvTYPE(sv) == SVt_PVGV)
#ifndef DOSISH
diff --git a/t/README b/t/README
index d714295dd2..00bf561c23 100644
--- a/t/README
+++ b/t/README
@@ -8,4 +8,4 @@ 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 come up with new tests, send them to larry@wall.org.
diff --git a/t/TEST b/t/TEST
index 160e316754..0b996f42d4 100644..100755
--- a/t/TEST
+++ b/t/TEST
@@ -24,14 +24,20 @@ if ($ARGV[0] eq '') {
`echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.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;
@@ -41,7 +47,7 @@ while ($test = shift) {
}
$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");
} else {
@@ -50,6 +56,10 @@ while ($test = shift) {
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 = '';
}
diff --git a/t/base/term.t b/t/base/term.t
index 42cd56fe0b..782ad397d3 100755
--- a/t/base/term.t
+++ b/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/t/comp/package.t b/t/comp/package.t
index ca800bb364..cef02c5cb4 100755
--- a/t/comp/package.t
+++ b/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/t/comp/redef.t b/t/comp/redef.t
new file mode 100755
index 0000000000..6a73ae1c2e
--- /dev/null
+++ b/t/comp/redef.t
@@ -0,0 +1,79 @@
+#!./perl
+#
+# Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
+
+BEGIN {
+ $^W = 1;
+ $warn = "";
+ $SIG{__WARN__} = sub { $warn .= join("",@_) }
+}
+
+sub ok ($$) {
+ print $_[1] ? "ok " : "not ok ", $_[0], "\n";
+}
+
+print "1..18\n";
+
+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/Prototype mismatch: \Q(none) 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/Prototype mismatch: \Q(none) 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/Prototype mismatch: \Q() 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/Prototype mismatch: \Q() 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/Prototype mismatch: \Q($) 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/Prototype mismatch: \Q($) 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/Prototype mismatch: \(\$\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/t/io/fs.t b/t/io/fs.t
index a219b81eef..87a3d2f6fb 100755
--- a/t/io/fs.t
+++ b/t/io/fs.t
@@ -2,7 +2,7 @@
# $RCSfile: fs.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:28 $
-print "1..22\n";
+print "1..26\n";
$wd = `pwd`;
chop($wd);
@@ -83,3 +83,27 @@ if (`ls -l perl 2>/dev/null` =~ /^l.*->/) { # we have symbolic links
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"}
+ `echo helloworld > Iofs.tmp`;
+ open(FH, ">Iofs.tmp") or die "Can't create Iofs.tmp";
+ 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/t/io/read.t b/t/io/read.t
new file mode 100755
index 0000000000..b27fde17c7
--- /dev/null
+++ b/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/t/lib/abbrev.t b/t/lib/abbrev.t
new file mode 100755
index 0000000000..fb5a9841eb
--- /dev/null
+++ b/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/t/lib/anydbm.t b/t/lib/anydbm.t
index 11ac103a64..80b39df141 100755
--- a/t/lib/anydbm.t
+++ b/t/lib/anydbm.t
@@ -23,7 +23,7 @@ if (! -e $Dfile) {
}
($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");
+print (($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) ? "ok 2\n" : "not ok 2\n");
while (($key,$value) = each(%h)) {
$i++;
}
@@ -80,7 +80,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;
}
diff --git a/t/lib/autoloader.t b/t/lib/autoloader.t
new file mode 100755
index 0000000000..b1622a8ae2
--- /dev/null
+++ b/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/t/lib/basename.t b/t/lib/basename.t
new file mode 100755
index 0000000000..56b1f7f211
--- /dev/null
+++ b/t/lib/basename.t
@@ -0,0 +1,107 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+use File::Basename qw(fileparse basename dirname);
+
+print "1..30\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";
+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";
+
diff --git a/t/lib/bigintpm.t b/t/lib/bigintpm.t
index b229d7c67b..ebaecac21a 100755
--- a/t/lib/bigintpm.t
+++ b/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/t/lib/checktree.t b/t/lib/checktree.t
new file mode 100755
index 0000000000..b5426ca261
--- /dev/null
+++ b/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/t/lib/complex.t b/t/lib/complex.t
new file mode 100755
index 0000000000..1ffd7d5447
--- /dev/null
+++ b/t/lib/complex.t
@@ -0,0 +1,254 @@
+#!./perl
+
+# $RCSfile$
+#
+# Regression tests for the new Math::Complex pacakge
+# -- Raphael Manfredi, Sept 1996
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+use Math::Complex;
+
+$test = 0;
+$| = 1;
+$script = '';
+$epsilon = 1e-10;
+
+while (<DATA>) {
+ next if /^#/ || /^\s*$/;
+ chop;
+ $set_test = 0; # Assume not a test over a set of values
+ if (/^&(.*)/) {
+ $op = $1;
+ next;
+ }
+ elsif (/^\{(.*)\}/) {
+ set($1, \@set, \@val);
+ next;
+ }
+ elsif (s/^\|//) {
+ $set_test = 1; # Requests we loop over the set...
+ }
+ my @args = split(/:/);
+ if ($set_test) {
+ my $i;
+ for ($i = 0; $i < @set; $i++) {
+ $target = $set[$i]; # complex number
+ $zvalue = $val[$i]; # textual value as found in set definition
+ test($zvalue, $target, @args);
+ }
+ } else {
+ test($op, undef, @args);
+ }
+}
+
+print "1..$test\n";
+eval $script;
+die $@ if $@;
+
+sub test {
+ my ($op, $z, @args) = @_;
+ $test++;
+ my $i;
+ for ($i = 0; $i < @args; $i++) {
+ $val = value($args[$i]);
+ $script .= "\$z$i = $val;\n";
+ }
+ if (defined $z) {
+ $args = "'$op'"; # Really the value
+ $try = "abs(\$z0 - \$z1) <= 1e-10 ? \$z1 : \$z0";
+ $script .= "\$res = $try; ";
+ $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]'";
+ }
+ $script .= "\$res = $try; ";
+ $script .= "check($test, '$try', \$res, \$z$#args, $args);\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]);
+ $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) = @_;
+ if ("$got" eq "$expected" || ($expected =~ /^-?\d/ && $got == $expected)) {
+ 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";
+ }
+}
+__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)
+
+&--
+(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]
+
+&abs
+(3,4):5
+(-3,4):5
+
+&~
+(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
+(-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)'
+
+{ (4,3); [3,2]; (-3,4); (0,2); 3; 1; (-5, 0); [2,1] }
+
+|'exp(z)':'exp(a) * exp(i * b)'
+|'abs(z)':'r'
+|'sqrt(z) * sqrt(z)':'z'
+|'sqrt(z)':'sqrt(r) * exp(i * t/2)'
+|'cbrt(z)':'cbrt(r) * exp(i * t/3)'
+|'log(z)':'log(r) + i*t'
+|'sin(asin(z))':'z'
+|'cos(acos(z))':'z'
+|'tan(atan(z))':'z'
+|'cotan(acotan(z))':'z'
+|'cos(z) ** 2 + sin(z) ** 2':1
+|'cosh(z) ** 2 - sinh(z) ** 2':1
+|'cos(z)':'cosh(i*z)'
+|'cotan(z)':'1 / tan(z)'
+|'cotanh(z)':'1 / tanh(z)'
+|'i*sin(z)':'sinh(i*z)'
+|'z**z':'exp(z * log(z))'
+|'log(exp(z))':'z'
+|'exp(log(z))':'z'
+|'log10(z)':'log(z) / log(10)'
+|'logn(z, 3)':'log(z) / log(3)'
+|'logn(z, 2)':'log(z) / log(2)'
+|'(root(z, 4))[1] ** 4':'z'
+|'(root(z, 8))[7] ** 8':'z'
+
+{ (1,1); [1,0.5]; (-2, -1); 2; (-1,0.5); (0,0.5); 0.5; (2, 0) }
+
+|'sinh(asinh(z))':'z'
+|'cosh(acosh(z))':'z'
+|'tanh(atanh(z))':'z'
+|'cotanh(acotanh(z))':'z'
+
+{ (0.2,-0.4); [1,0.5]; -1.2; (-1,0.5); (0,-0.5); 0.5; (1.1, 0) }
+
+|'asin(sin(z))':'z'
+|'acos(cos(z)) ** 2':'z * z'
+|'atan(tan(z))':'z'
+|'asinh(sinh(z))':'z'
+|'acosh(cosh(z)) ** 2':'z * z'
+|'atanh(tanh(z))':'z'
+
diff --git a/t/lib/db-btree.t b/t/lib/db-btree.t
index f3cf94487e..7dea2ed5ea 100755
--- a/t/lib/db-btree.t
+++ b/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,7 +12,31 @@ BEGIN {
use DB_File;
use Fcntl;
-print "1..86\n";
+print "1..91\n";
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
+
+sub lexical
+{
+ my(@a) = unpack ("C*", $a) ;
+ my(@b) = unpack ("C*", $b) ;
+
+ my $len = (@a > @b ? @b : @a) ;
+ my $i = 0 ;
+
+ foreach $i ( 0 .. $len -1) {
+ return $a[$i] - $b[$i] if $a[$i] != $b[$i] ;
+ }
+
+ return @a - @b ;
+}
$Dfile = "dbbtree.tmp";
unlink $Dfile;
@@ -21,65 +45,68 @@ umask(0);
# Check the interface to BTREEINFO
-#$dbh = TIEHASH DB_File::BTREEINFO ;
-$dbh = new 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, $dbh->{flags} == 0) ;
+ok(2, $dbh->{cachesize} == 0) ;
+ok(3, $dbh->{psize} == 0) ;
+ok(4, $dbh->{lorder} == 0) ;
+ok(5, $dbh->{minkeypage} == 0) ;
+ok(6, $dbh->{maxkeypage} == 0) ;
+$^W = 0 ;
+ok(7, $dbh->{compare} == undef) ;
+ok(8, $dbh->{prefix} == undef) ;
+$^W = 1 ;
$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 ($@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ? "ok 17\n" : "not ok 17\n") ;
+ok(17, $@ =~ /^DB_File::BTREEINFO::STORE - Unknown element 'fred' at/ ) ;
eval '$q = $dbh->{fred}' ;
-print ($@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ? "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' ? 0666 : 0640) );
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'} eq '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";
@@ -111,7 +138,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';
@@ -142,48 +169,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";}
+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
@@ -192,52 +216,55 @@ 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") ;
+$^W = 0 ;
+ok(43, $h{'q'} eq undef) ;
+ok(44, $h{''} eq undef) ;
+$^W = 1 ;
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
# ###
@@ -246,15 +273,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.
@@ -262,35 +289,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 ;
@@ -299,12 +326,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 ;
@@ -314,8 +341,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
@@ -324,14 +351,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 ;
@@ -340,11 +367,11 @@ 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 ;
@@ -353,40 +380,44 @@ untie %h ;
# Duplicate keys
my $bt = new DB_File::BTREEINFO ;
$bt->{flags} = R_DUP ;
-print (($YY = tie(%hh, DB_File, $Dfile, O_RDWR|O_CREAT, 0640, $bt )) ? "ok 74\n" : "not ok 74");
+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
-print(scalar $YY->get_dup('Unknown') == 0 ? "ok 75\n" : "not ok 75\n") ;
-print(scalar $YY->get_dup('Smith') == 1 ? "ok 76\n" : "not ok 76\n") ;
-print(scalar $YY->get_dup('Wall') == 3 ? "ok 77\n" : "not ok 77\n") ;
+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') ;
-print( "@unknown" eq "" ? "ok 78\n" : "not ok 78\n") ;
+ok(80, "@unknown" eq "" );
my @smith = $YY->get_dup('Smith') ;
-print( "@smith" eq "John" ? "ok 79\n" : "not ok 79\n") ;
+ok(81, "@smith" eq "John" );
+{
my @wall = $YY->get_dup('Wall') ;
my %wall ;
@wall{@wall} = @wall ;
-print( (@wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 80\n" : "not ok 80\n") ;
+ok(82, (@wall == 4 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) );
+}
# hash
my %unknown = $YY->get_dup('Unknown', 1) ;
-print( keys %unknown == 0 ? "ok 81\n" : "not ok 81\n") ;
+ok(83, keys %unknown == 0 );
my %smith = $YY->get_dup('Smith', 1) ;
-print( (keys %smith == 1 && $smith{'John'}) ? "ok 82\n" : "not ok 82\n") ;
+ok(84, keys %smith == 1 && $smith{'John'}) ;
my %wall = $YY->get_dup('Wall', 1) ;
-print( (keys %wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 83\n" : "not ok 83\n") ;
+ok(85, keys %wall == 3 && $wall{'Larry'} == 1 && $wall{'Stone'} == 1
+ && $wall{'Brick'} == 2);
undef $YY ;
untie %hh ;
@@ -398,27 +429,31 @@ $Dfile1 = "btree1" ;
$Dfile2 = "btree2" ;
$Dfile3 = "btree3" ;
-$dbh1 = TIEHASH DB_File::BTREEINFO ;
+$dbh1 = new DB_File::BTREEINFO ;
$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 ) ;
+$^W = 0 ;
@srt_1 = sort { $a <=> $b } @Keys ;
+$^W = 1 ;
@srt_2 = sort { $a cmp $b } @Keys ;
@srt_3 = sort { length $a <=> length $b } @Keys ;
foreach (@Keys) {
- $h{$_} = 1 ;
+ $^W = 0 ;
+ $h{$_} = 1 ;
+ $^W = 1 ;
$g{$_} = 1 ;
$k{$_} = 1 ;
}
@@ -437,13 +472,40 @@ sub ArrayCompare
1 ;
}
-print ( ArrayCompare (\@srt_1, [keys %h]) ? "ok 84\n" : "not ok 84\n") ;
-print ( ArrayCompare (\@srt_2, [keys %g]) ? "ok 85\n" : "not ok 85\n") ;
-print ( ArrayCompare (\@srt_3, [keys %k]) ? "ok 86\n" : "not ok 86\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 ;
+
exit ;
diff --git a/t/lib/db-hash.t b/t/lib/db-hash.t
index 5205fae32e..09c0ee2151 100755
--- a/t/lib/db-hash.t
+++ b/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,7 +12,16 @@ BEGIN {
use DB_File;
use Fcntl;
-print "1..43\n";
+print "1..51\n";
+
+sub ok
+{
+ my $no = shift ;
+ my $result = shift ;
+
+ print "not " unless $result ;
+ print "ok $no\n" ;
+}
$Dfile = "dbhash.tmp";
unlink $Dfile;
@@ -21,57 +30,62 @@ umask(0);
# Check the interface to HASHINFO
-#$dbh = TIEHASH DB_File::HASHINFO ;
-$dbh = new 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, $dbh->{bsize} == 0) ;
+ok(2, $dbh->{ffactor} == 0) ;
+ok(3, $dbh->{nelem} == 0) ;
+ok(4, $dbh->{cachesize} == 0) ;
+$^W = 0 ;
+ok(5, $dbh->{hash} == undef) ;
+$^W = 1 ;
+ok(6, $dbh->{lorder} == 0) ;
$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 ($@ =~ /^DB_File::HASHINFO::STORE - Unknown element 'fred' at/ ? "ok 13\n" : "not ok 13\n") ;
-eval '$q = $dbh->{fred}' ;
-print ($@ =~ /^DB_File::HASHINFO::FETCH - Unknown element 'fred' at/ ? "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' ? 0666 : 0640) );
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'} eq '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";
@@ -103,7 +117,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';
@@ -134,39 +148,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) ;
+$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 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";}
+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
@@ -175,44 +190,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
# ###
@@ -227,28 +245,71 @@ 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) ;
+}
exit ;
diff --git a/t/lib/db-recno.t b/t/lib/db-recno.t
index ba5c7edee1..6027b6fa95 100755
--- a/t/lib/db-recno.t
+++ b/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";
@@ -23,7 +23,7 @@ sub ok
print "ok $no\n" ;
}
-print "1..35\n";
+print "1..55\n";
my $Dfile = "recno.tmp";
unlink $Dfile ;
@@ -33,59 +33,58 @@ umask(0);
# Check the interface to RECNOINFO
my $dbh = new DB_File::RECNOINFO ;
-ok(1, $dbh->{bval} == undef ) ;
-ok(2, $dbh->{cachesize} == undef) ;
-ok(3, $dbh->{psize} == undef) ;
-ok(4, $dbh->{flags} == undef) ;
-ok(5, $dbh->{lorder} == undef);
-ok(6, $dbh->{reclen} == undef);
-ok(7, $dbh->{bfname} eq undef);
+ok(1, $dbh->{bval} == 0 ) ;
+ok(2, $dbh->{cachesize} == 0) ;
+ok(3, $dbh->{psize} == 0) ;
+ok(4, $dbh->{flags} == 0) ;
+ok(5, $dbh->{lorder} == 0);
+ok(6, $dbh->{reclen} == 0);
+ok(7, $dbh->{bfname} eq "");
$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 ($@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ ? "ok 15\n" : "not ok 15\n") ;
+ok(15, $@ =~ /^DB_File::RECNOINFO::STORE - Unknown element 'fred' at/ );
eval 'my $q = $dbh->{fred}' ;
-print ($@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ? "ok 16\n" : "not ok 16\n") ;
+ok(16, $@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ );
# Now check the interface to RECNOINFO
my $X ;
my @h ;
ok(17, $X = tie @h, 'DB_File', $Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO ) ;
-#print (($X = tie(%h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_BTREE )) ? "ok 19\n" : "not ok 19");
-ok(18, ( (stat($Dfile))[2] & 0777) == 0640) ;
+ok(18, ( (stat($Dfile))[2] & 0777) == ($^O eq 'os2' ? 0666 : 0640)) ;
#my $l = @h ;
my $l = $X->length ;
-print (!$l ? "ok 19\n" : "not ok 19\n");
+ok(19, !$l );
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)
@@ -93,45 +92,58 @@ foreach (@data)
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
my @push_data = qw(added to the end) ;
-#push (@h, @push_data) ;
+#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) ;
+my $popped = pop (@data) ;
+#my $value = pop(@h) ;
my $value = $X->pop ;
-print ($value eq 'end' ? "not ok 26\n" : "ok 26\n");
+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 );
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
@@ -143,22 +155,22 @@ 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
-print($h[-1] eq $data[-1] ? "ok 31\n" : "not ok 31\n") ;
-print($h[-1] eq $h[$X->length -1] ? "ok 32\n" : "not ok 32\n") ;
+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"' ;
-print ($@ eq "" ? "ok 33\n" : "not ok 33\n") ;
-print ($h[0] eq "abcd" ? "ok 34\n" : "not ok 34\n") ;
+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' ;
-print ($@ =~ '^Modification of non-creatable array value attempted' ? "ok 35\n" : "not ok 35\n") ;
+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.
@@ -167,4 +179,70 @@ untie(@h);
unlink $Dfile;
+{
+ # 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 = `cat $Dfile` ;
+ ok(49, $x eq "abc\ndef\n\nghi\n") ;
+ unlink $Dfile;
+}
+
+{
+ # 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 = `cat $Dfile` ;
+ ok(51, $x eq "abc-def--ghi-") ;
+ unlink $Dfile;
+}
+
+{
+ # 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 = `cat $Dfile` ;
+ ok(53, $x eq "abc def ghi ") ;
+ unlink $Dfile;
+}
+
+{
+ # 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 = `cat $Dfile` ;
+ ok(55, $x eq "abc--def-------ghi--") ;
+ unlink $Dfile;
+}
+
exit ;
diff --git a/t/lib/env.t b/t/lib/env.t
new file mode 100755
index 0000000000..5a8220778a
--- /dev/null
+++ b/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/t/lib/fatal.t b/t/lib/fatal.t
new file mode 100755
index 0000000000..fe2f63d072
--- /dev/null
+++ b/t/lib/fatal.t
@@ -0,0 +1,23 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..2\n";
+
+sub false { 0; }
+
+sub true { 1; }
+
+use Fatal qw(true false);
+
+eval { true(); };
+
+print "not " if $@;
+print "ok 1\n";
+
+eval { false(); };
+print "not " unless $@;
+print "ok 2\n";
diff --git a/t/lib/filecache.t b/t/lib/filecache.t
new file mode 100755
index 0000000000..a97fdd532c
--- /dev/null
+++ b/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/t/lib/filecopy.t b/t/lib/filecopy.t
new file mode 100755
index 0000000000..8c64be1c98
--- /dev/null
+++ b/t/lib/filecopy.t
@@ -0,0 +1,43 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..5\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 "file-$$";
+
+print "not " if move("file-$$", "copy-$$") or not -e "copy-$$";
+print "ok 4\n";
+
+move "copy-$$", "file-$$";
+
+print "not " unless -e "file-$$" and not -e "copy-$$";
+print "ok 5\n";
+
+unlink "file-$$";
diff --git a/t/lib/filefind.t b/t/lib/filefind.t
new file mode 100755
index 0000000000..21e29a2d7f
--- /dev/null
+++ b/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/t/lib/filehand.t b/t/lib/filehand.t
index 0199a52ace..11836f1c52 100755
--- a/t/lib/filehand.t
+++ b/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,17 +13,70 @@ BEGIN {
use FileHandle;
use strict subs;
+autoflush STDOUT 1;
+
$mystdout = new_from_fd FileHandle 1,"w";
$| = 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";
+
+
$buffer = <$fh>;
print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n";
+
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 "not " 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') {
+ $wr->autoflush;
+ $wr->printf("ok %d\n",11);
+ print $rd->getline;
+}
+else {
+ if (fork) {
+ $wr->close;
+ print $rd->getline;
+ }
+ else {
+ $rd->close;
+ $wr->printf("ok %d\n",11);
+ exit(0);
+ }
+}
diff --git a/t/lib/filepath.t b/t/lib/filepath.t
new file mode 100755
index 0000000000..c014f741d6
--- /dev/null
+++ b/t/lib/filepath.t
@@ -0,0 +1,20 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+}
+
+print "1..2\n";
+
+use File::Path;
+
+mkpath("foo/bar");
+
+print "not " unless -d "foo" && -d "foo/bar";
+print "ok 1\n";
+
+rmtree("foo");
+
+print "not " if -e "foo";
+print "ok 2\n";
diff --git a/t/lib/findbin.t b/t/lib/findbin.t
new file mode 100755
index 0000000000..3e742f9a4f
--- /dev/null
+++ b/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/t/lib/gdbm.t b/t/lib/gdbm.t
index 0d2c1fe023..c888c00f85 100755
--- a/t/lib/gdbm.t
+++ b/t/lib/gdbm.t
@@ -26,7 +26,7 @@ if (! -e $Dfile) {
}
($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");
+print (($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) ? "ok 2\n" : "not ok 2\n");
while (($key,$value) = each(%h)) {
$i++;
}
@@ -83,7 +83,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;
}
diff --git a/t/lib/getopt.t b/t/lib/getopt.t
new file mode 100755
index 0000000000..fb70f10aae
--- /dev/null
+++ b/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/t/lib/hostname.t b/t/lib/hostname.t
new file mode 100755
index 0000000000..e4ac36521c
--- /dev/null
+++ b/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/t/lib/io_pipe.t b/t/lib/io_pipe.t
index 225d04b46a..6f9d30c82f 100755
--- a/t/lib/io_pipe.t
+++ b/t/lib/io_pipe.t
@@ -35,7 +35,7 @@ elsif(defined $pid)
}
else
{
- die;
+ die "# error = $!";
}
$pipe = new IO::Pipe;
diff --git a/t/lib/io_sock.t b/t/lib/io_sock.t
index e888c5e514..156f6cb78f 100755
--- a/t/lib/io_sock.t
+++ b/t/lib/io_sock.t
@@ -17,7 +17,10 @@ print "1..5\n";
use IO::Socket;
-$port = 4002 + int(rand(time) & 0xff);
+srand(time);
+$port = 4002 + int(rand 0xff);
+print "# using port $port.\n";
+$SIG{ALRM} = sub {};
$pid = fork();
@@ -51,7 +54,6 @@ if($pid) {
# Wait for a small pause, so that we can ensure the listen socket is setup
# the parent will awake us with a SIGALRM
- $SIG{ALRM} = sub {};
sleep(10);
$sock = IO::Socket::INET->new(PeerPort => $port,
diff --git a/t/lib/io_taint.t b/t/lib/io_taint.t
new file mode 100755
index 0000000000..698db45c72
--- /dev/null
+++ b/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 ($@ !~ /^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/t/lib/io_udp.t b/t/lib/io_udp.t
index 84e5067b85..e85583fdb3 100755
--- a/t/lib/io_udp.t
+++ b/t/lib/io_udp.t
@@ -5,7 +5,8 @@ BEGIN {
@INC = '../lib' if -d '../lib';
require Config; import Config;
if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
- $Config{'extensions'} !~ /\bIO\b/) &&
+ $Config{'extensions'} !~ /\bIO\b/ ||
+ $^O eq 'os2') &&
!(($^O eq 'VMS') && $Config{d_socket})) {
print "1..0\n";
exit 0;
@@ -18,8 +19,8 @@ print "1..3\n";
use Socket;
use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
-$udpa = IO::Socket::INET->new(Proto => 'udp', Addr => 'localhost');
-$udpb = IO::Socket::INET->new(Proto => 'udp', Addr => 'localhost');
+$udpa = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost');
+$udpb = IO::Socket::INET->new(Proto => 'udp', LocalAddr => 'localhost');
print "ok 1\n";
diff --git a/t/lib/ndbm.t b/t/lib/ndbm.t
index e3093dbcfb..15aa93a725 100755
--- a/t/lib/ndbm.t
+++ b/t/lib/ndbm.t
@@ -29,7 +29,7 @@ if (! -e $Dfile) {
}
($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");
+print (($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) ? "ok 2\n" : "not ok 2\n");
while (($key,$value) = each(%h)) {
$i++;
}
@@ -86,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;
}
diff --git a/t/lib/odbm.t b/t/lib/odbm.t
index b49aa91043..0b1fa50cb9 100755
--- a/t/lib/odbm.t
+++ b/t/lib/odbm.t
@@ -29,7 +29,7 @@ if (! -e $Dfile) {
}
($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");
+print (($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) ? "ok 2\n" : "not ok 2\n");
while (($key,$value) = each(%h)) {
$i++;
}
@@ -86,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;
}
diff --git a/t/lib/opcode.t b/t/lib/opcode.t
index e171aca70d..a785fce48b 100755
--- a/t/lib/opcode.t
+++ b/t/lib/opcode.t
@@ -77,7 +77,7 @@ print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++;
die $t unless $t == 16;
print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work
-print length opmask() == int(opcodes()/8)+1 ? "ok $t\n" : "not ok $t\n"; $t++;
+print length opmask() == int((opcodes()+7)/8) ? "ok $t\n" : "not ok $t\n"; $t++;
# --- verify_opset
diff --git a/t/lib/parsewords.t b/t/lib/parsewords.t
new file mode 100755
index 0000000000..47a75881dc
--- /dev/null
+++ b/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/t/lib/posix.t b/t/lib/posix.t
index 23007ff059..6ae88c0dd2 100755
--- a/t/lib/posix.t
+++ b/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/t/lib/safe2.t b/t/lib/safe2.t
index 61c6c8ffec..586eace6a8 100755
--- a/t/lib/safe2.t
+++ b/t/lib/safe2.t
@@ -119,7 +119,8 @@ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
my $t = 30;
$cpt->rdo('/non/existant/file.name');
-print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) ?
+print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) ||
+ $! =~ /A file or directory in the path name does not exist/ ?
"ok $t\n" : "not ok $t # $!\n"); $t++;
print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++;
diff --git a/t/lib/sdbm.t b/t/lib/sdbm.t
index a754bb72a4..1bb3fde392 100755
--- a/t/lib/sdbm.t
+++ b/t/lib/sdbm.t
@@ -28,7 +28,7 @@ if (! -e $Dfile) {
}
($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");
+print (($mode & 0777) == ($^O eq 'os2' ? 0666 : 0640) ? "ok 2\n" : "not ok 2\n");
while (($key,$value) = each(%h)) {
$i++;
}
@@ -85,7 +85,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;
}
diff --git a/t/lib/searchdict.t b/t/lib/searchdict.t
new file mode 100755
index 0000000000..447c425b27
--- /dev/null
+++ b/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/t/lib/selectsaver.t b/t/lib/selectsaver.t
new file mode 100755
index 0000000000..3b58d709ab
--- /dev/null
+++ b/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/t/lib/socket.t b/t/lib/socket.t
index 1e1027e081..4e382958ce 100755
--- a/t/lib/socket.t
+++ b/t/lib/socket.t
@@ -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/t/lib/symbol.t b/t/lib/symbol.t
new file mode 100755
index 0000000000..03449a3ed7
--- /dev/null
+++ b/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/t/lib/texttabs.t b/t/lib/texttabs.t
new file mode 100755
index 0000000000..ea9012c652
--- /dev/null
+++ b/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/t/lib/textwrap.t b/t/lib/textwrap.t
new file mode 100755
index 0000000000..9c8d1b4975
--- /dev/null
+++ b/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/t/lib/timelocal.t b/t/lib/timelocal.t
new file mode 100755
index 0000000000..adc1b1b061
--- /dev/null
+++ b/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/t/op/bop.t b/t/op/bop.t
new file mode 100755
index 0000000000..0c55029b93
--- /dev/null
+++ b/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/t/op/delete.t b/t/op/delete.t
index 010cbf1003..4e00566cd7 100755
--- a/t/op/delete.t
+++ b/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/t/op/each.t b/t/op/each.t
index 7a58fc8dcc..4106e54c50 100755
--- a/t/op/each.t
+++ b/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..7\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,18 @@ 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";}
diff --git a/t/op/glob.t b/t/op/glob.t
index b4038442bd..fce2952968 100755
--- a/t/op/glob.t
+++ b/t/op/glob.t
@@ -5,11 +5,12 @@
print "1..4\n";
@ops = <op/*>;
-$list = join(' ',@ops);
-chop($otherway = `echo op/*`);
-
-print $list eq $otherway ? "ok 1\n" : "not ok 1\n$list\n$otherway\n";
+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";
diff --git a/t/op/gv.t b/t/op/gv.t
new file mode 100755
index 0000000000..ece32d936c
--- /dev/null
+++ b/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/t/op/inc.t b/t/op/inc.t
new file mode 100755
index 0000000000..e5a2a921b3
--- /dev/null
+++ b/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/t/op/magic.t b/t/op/magic.t
index b43f71c809..b46dade75d 100755
--- a/t/op/magic.t
+++ b/t/op/magic.t
@@ -30,7 +30,7 @@ system './perl', '-e', <<'END';
print "ok 3\n";
}
else {
- print "not ok 3 $a\n";
+ print "not ok 3 ($x @_)\n";
}
}
diff --git a/t/op/misc.t b/t/op/misc.t
index 8fdd11a7d4..024a514a6c 100755
--- a/t/op/misc.t
+++ b/t/op/misc.t
@@ -37,6 +37,12 @@ for (@prgs){
}
__END__
+$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.
@@ -169,3 +175,30 @@ 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 TIEHANDLE {
+ bless {}, shift;
+ }
+ sub READLINE {
+ "Out of inspiration";
+ }
+ sub DESTROY {
+ print "and destroyed as well\n";
+ }
+}
+{
+ local(*FOO);
+ tie(*FOO,'foo');
+ print FOO "sentence.", "reversed", "a", "is", "This";
+ print "-- ", <FOO>, " --\n";
+}
+EXPECT
+This is a reversed sentence.
+-- Out of inspiration --
+and destroyed as well
diff --git a/t/op/overload.t b/t/op/overload.t
index 183cb273f7..fca26b4085 100755
--- a/t/op/overload.t
+++ b/t/op/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:
diff --git a/t/op/pack.t b/t/op/pack.t
index 1cfcd60b08..b11fe234e7 100755
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -2,7 +2,7 @@
# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
-print "1..8\n";
+print "1..25\n";
$format = "c2x5CCxsdila6";
# Need the expression in here to force ary[5] to be numeric. This avoids
@@ -41,3 +41,38 @@ 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++;
+
diff --git a/t/op/re_tests b/t/op/re_tests
index f8c4c6eafb..c20fb89e80 100644
--- a/t/op/re_tests
+++ b/t/op/re_tests
@@ -53,6 +53,42 @@ 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-
diff --git a/t/op/readdir.t b/t/op/readdir.t
index 1215f11c8a..ca19ebc7db 100755
--- a/t/op/readdir.t
+++ b/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/t/op/recurse.t b/t/op/recurse.t
new file mode 100755
index 0000000000..6b21c66106
--- /dev/null
+++ b/t/op/recurse.t
@@ -0,0 +1,90 @@
+#!./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,0) will take quite a long time.
+#
+# In fact, the current Perl, 5.004, will complain loudly:
+# "Deep recursion on subroutine." (see perldiag) when
+# computing the ackermann(4,0) because the recursion will
+# become so deep (>100 levels) that Perl suspects the script
+# has been lost in an infinite recursion.
+
+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/t/op/ref.t b/t/op/ref.t
index 38e34f002b..0787295dde 100755
--- a/t/op/ref.t
+++ b/t/op/ref.t
@@ -1,6 +1,6 @@
#!./perl
-print "1..41\n";
+print "1..47\n";
# Test glob operations.
@@ -189,12 +189,30 @@ 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";
+
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 47\n"]; # package destruction
+ my $ref2 = bless ["ok 46\n"]; # lexical destruction
+ local $ref1 = bless ["ok 45\n"]; # dynamic destruction
1; # flush any temp values on stack
}
diff --git a/t/op/sort.t b/t/op/sort.t
index dc01e5f11d..44c7c04185 100755
--- a/t/op/sort.t
+++ b/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..14\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,20 @@ $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";
diff --git a/t/op/split.t b/t/op/split.t
index 2354530817..4144bbb88f 100755
--- a/t/op/split.t
+++ b/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..14\n";
$FS = ':';
@@ -58,3 +58,10 @@ 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";
diff --git a/t/op/stat.t b/t/op/stat.t
index d1ddb2696a..b018b6cb2c 100755
--- a/t/op/stat.t
+++ b/t/op/stat.t
@@ -116,8 +116,9 @@ if (! -b '.') {print "ok 34\n";} else {print "not ok 34\n";}
$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 '/bin';
-chdir '/bin' || die "Can't cd to /bin";
+($bin) = grep {-d} qw(/bin /usr/bin)
+ or print ("not ok 35\n"), goto tty_test;
+chdir $bin || die "Can't cd to $bin: $!";
while (defined($_ = <*>)) {
$cnt++;
$uid++ if -u;
diff --git a/t/op/substr.t b/t/op/substr.t
index 08e1c39969..e34216fb17 100755
--- a/t/op/substr.t
+++ b/t/op/substr.t
@@ -2,7 +2,7 @@
# $RCSfile: substr.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:31 $
-print "1..22\n";
+print "1..25\n";
$a = 'abcdefxyz';
@@ -45,3 +45,24 @@ $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");
+
+# with lexicals (and in re-entered scopes)
+for (0,1) {
+ my $txt;
+ unless ($_) {
+ $txt = "Foo";
+ substr($txt, -1) = "X";
+ print $txt eq "FoX" ? "ok 23\n" : "not ok 23\n";
+ }
+ else {
+ substr($txt, 0, 1) = "X";
+ print $txt eq "X" ? "ok 24\n" : "not ok 24\n";
+ }
+}
+
+# coersion of references
+{
+ my $s = [];
+ substr($s, 0, 1) = 'Foo';
+ print substr($s,0,7) eq "FooRRAY" ? "ok 25\n" : "not ok 25\n";
+}
diff --git a/t/op/sysio.t b/t/op/sysio.t
new file mode 100755
index 0000000000..554fdf5b0a
--- /dev/null
+++ b/t/op/sysio.t
@@ -0,0 +1,173 @@
+#!./perl
+
+print "1..30\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');
+
+$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";
+
+close(I);
+
+unlink $outfile;
+
+1;
+
+# eof
diff --git a/t/op/tie.t b/t/op/tie.t
index cf116519e6..77e74db4e2 100755
--- a/t/op/tie.t
+++ b/t/op/tie.t
@@ -3,7 +3,7 @@
# This test harness will (eventually) test the "tie" functionality
# without the need for a *DBM* implementation.
-# Currently it only tests use strict "untie".
+# Currently it only tests the untie warning
chdir 't' if -d 't';
@INC = "../lib";
@@ -11,6 +11,9 @@ $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";
@@ -22,7 +25,7 @@ for (@prgs){
$results = $@ ;
$results =~ s/\n+$//;
$expected =~ s/\n+$//;
- if ( $status or $results !~ /^$expected/){
+ if ( $status or $results and $results !~ /^WARNING: $expected/){
print STDERR "STATUS: $status\n";
print STDERR "PROG: $prog\n";
print STDERR "EXPECTED:\n$expected\n";
@@ -74,7 +77,8 @@ EXPECT
########
# strict behaviour, without any extra references
-use strict 'untie';
+#use warning 'untie';
+local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
@@ -82,26 +86,29 @@ EXPECT
########
# strict behaviour, with 1 extra references generating an error
-use strict 'untie';
+#use warning 'untie';
+local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
untie %h;
EXPECT
-Can't untie: 1 inner references still exist at
+untie attempted while 1 inner references still exist
########
# strict behaviour, with 1 extra references via tied generating an error
-use strict 'untie';
+#use warning 'untie';
+local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
untie %h;
EXPECT
-Can't untie: 1 inner references still exist at
+untie attempted while 1 inner references still exist
########
# strict behaviour, with 1 extra references which are destroyed
-use strict 'untie';
+#use warning 'untie';
+local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$a = 0 ;
@@ -110,7 +117,8 @@ EXPECT
########
# strict behaviour, with extra 1 references via tied which are destroyed
-use strict 'untie';
+#use warning 'untie';
+local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
@@ -120,22 +128,25 @@ EXPECT
########
# strict error behaviour, with 2 extra references
-use strict 'untie';
+#use warning 'untie';
+local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$b = tied %h ;
untie %h;
EXPECT
-Can't untie: 2 inner references still exist at
+untie attempted while 2 inner references still exist
########
# strict behaviour, check scope of strictness.
-no strict 'untie';
+#no warning 'untie';
+local $^W = 0 ;
use Tie::Hash ;
$A = tie %H, Tie::StdHash;
$C = $B = tied %H ;
{
- use strict 'untie';
+ #use warning 'untie';
+ local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
diff --git a/t/op/write.t b/t/op/write.t
index d14cef3cd6..46ec8130b9 100755
--- a/t/op/write.t
+++ b/t/op/write.t
@@ -2,7 +2,7 @@
# $RCSfile: write.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:38 $
-print "1..3\n";
+print "1..5\n";
format OUT =
the quick brown @<<
@@ -133,3 +133,35 @@ if (`cat Op_write.tmp` eq $right)
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/t/re_tests b/t/re_tests
deleted file mode 100644
index 2ac666ab38..0000000000
--- a/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/taint.c b/taint.c
index 6c64b39fc7..d9fac77b5f 100644
--- a/taint.c
+++ b/taint.c
@@ -8,37 +8,25 @@
#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;
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;
+
+ if (tainted) {
+ DEBUG_u(PerlIO_printf(PerlIO_stderr(),
+ "%s %d %d %d\n", s, tainted, uid, euid));
+ 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 +34,24 @@ void
taint_env()
{
SV** svp;
+ MAGIC *mg = 0;
- 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}");
- }
- 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}");
- }
+ svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE);
+ if (!svp || *svp == &sv_undef ||
+ ((mg = mg_find(*svp, 't')) && mg->mg_len & 1))
+ {
+ TAINT;
+ if (mg && MgTAINTEDDIR(mg))
+ taint_proper("Insecure directory in %s%s", "$ENV{PATH}");
+ else
+ taint_proper("Insecure %s%s", "$ENV{PATH}");
}
-}
+ svp = hv_fetch(GvHVn(envgv),"IFS",3,FALSE);
+ if (svp && *svp != &sv_undef &&
+ (mg = mg_find(*svp, 't')) && mg->mg_len & 1)
+ {
+ TAINT;
+ taint_proper("Insecure %s%s", "$ENV{IFS}");
+ }
+}
diff --git a/toke.c b/toke.c
index f3958c14a4..2ebb0c2b16 100644
--- a/toke.c
+++ b/toke.c
@@ -40,28 +40,39 @@ 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 SV * sub_const _((CV *cv));
+
+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_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>
@@ -70,6 +81,12 @@ static SV * sub_const _((CV *cv));
#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
@@ -142,7 +159,7 @@ 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);
@@ -174,7 +191,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;
@@ -209,19 +226,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);
@@ -258,7 +276,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);
@@ -274,12 +292,12 @@ 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;
}
@@ -334,6 +352,7 @@ register char *s;
return s;
}
for (;;) {
+ STRLEN prevlen;
while (s < bufend && isSPACE(*s))
s++;
if (s < bufend && *s == '#') {
@@ -344,7 +363,7 @@ 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_catpv(linestr,";}");
@@ -352,25 +371,26 @@ register char *s;
}
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);
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) {
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);
}
}
@@ -507,7 +527,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 :
@@ -530,7 +553,7 @@ char *s;
if(isDIGIT(*s)) {
char *d;
int c;
- for( d=s, c = 1; isDIGIT(*d) || (*d == '.' && c--); d++);
+ 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 */
@@ -595,19 +618,40 @@ sublex_start()
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);
@@ -615,7 +659,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);
@@ -632,21 +676,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
@@ -667,7 +703,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;
@@ -788,10 +824,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';
@@ -997,6 +1031,8 @@ GV *gv;
/* filehandle or package name makes it a method */
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));
@@ -1111,8 +1147,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 */
@@ -1121,7 +1157,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 */
@@ -1147,20 +1183,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));
}
@@ -1180,6 +1218,59 @@ 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))) {
+ char tmpbuf[1024];
+ sprintf(tmpbuf, "Literal %s now requires backslash", tokenbuf);
+ yyerror(tmpbuf);
+ }
+ }
+
+ 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 */
@@ -1263,6 +1354,9 @@ yylex()
return yylex();
}
+ case LEX_INTERPPUSH:
+ return sublex_push();
+
case LEX_INTERPSTART:
if (bufptr == bufend)
return sublex_done();
@@ -1350,7 +1444,7 @@ 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:
@@ -1363,6 +1457,8 @@ yylex()
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);
@@ -1406,7 +1502,7 @@ yylex()
}
}
sv_catpv(linestr, "\n");
- oldoldbufptr = oldbufptr = s = SvPVX(linestr);
+ oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr);
bufend = SvPVX(linestr) + SvCUR(linestr);
if (perldb && curstash != debstash) {
SV *sv = NEWSV(85,0);
@@ -1418,26 +1514,26 @@ 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);
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 */
}
@@ -1448,14 +1544,14 @@ 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;
+ oldoldbufptr = oldbufptr = bufptr = linestart = s;
if (perldb && curstash != debstash) {
SV *sv = NEWSV(85,0);
@@ -1520,7 +1616,7 @@ yylex()
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)
@@ -1673,35 +1769,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);
}
- ++s;
- Mop(OP_MODULO);
+ tokenbuf[0] = '%';
+ s = scan_ident(s, bufend, tokenbuf+1, TRUE);
+ if (!tokenbuf[1]) {
+ if (s == bufend)
+ yyerror("Final % should be \\% or %name");
+ PREREF('%');
+ }
+ pending_ident = '%';
+ TERM('%');
case '^':
s++;
@@ -1776,7 +1856,7 @@ yylex()
case XOPERATOR:
while (s < bufend && (*s == ' ' || *s == '\t'))
s++;
- if (s < bufend && (isALPHA(*s) || *s == '_')) {
+ if (s < bufend && isIDFIRST(*s)) {
d = scan_word(s, tokenbuf, FALSE, &len);
while (d < bufend && (*d == ' ' || *d == '\t'))
d++;
@@ -1868,7 +1948,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++;
@@ -1906,7 +1986,7 @@ yylex()
warn("Reversed %c= operator",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;
@@ -1984,67 +2064,72 @@ 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);
+ CLINE;
+
+ if (expect == XOPERATOR) {
+ if (lex_formbrack && lex_brackets == lex_formbrack) {
+ expect = XTERM;
+ depcom();
+ return ','; /* grandfather non-comma-format format */
}
- else if (!tokenbuf[1])
+ }
+
+ 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, FALSE);
+ 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);
+ pending_ident = '#';
TOKEN(DOLSHARP);
}
+
+ if (expect == XOPERATOR)
+ no_op("Scalar", bufptr);
+ tokenbuf[0] = '$';
s = scan_ident(s, 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("Scalar",s);
+ if (!tokenbuf[1]) {
+ if (s == bufend)
+ yyerror("Final $ should be \\$ or $name");
+ PREREF('$');
}
- 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++) ;
+ /* 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,'='))) {
+ }
+ else if (*s == '{') {
+ tokenbuf[0] = '%';
+ if (dowarn && strEQ(tokenbuf+1, "SIG") &&
+ (t = strchr(s, '}')) && (t = strchr(t, '=')))
+ {
char tmpbuf[1024];
STRLEN len;
for (t++; isSPACE(*t); t++) ;
@@ -2055,113 +2140,44 @@ yylex()
}
}
}
- 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] = '%';
- }
- }
- 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
- force_ident(tokenbuf+1, *tokenbuf);
- }
- else
- force_ident(tokenbuf+1, *tokenbuf);
- }
- else {
- if (s == bufend)
- yyerror("Final $ should be \\$ or $name");
- PREREF('$');
}
+
+ 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 (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, 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) {
@@ -2177,13 +2193,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 */
@@ -2200,7 +2211,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;
@@ -2327,12 +2338,22 @@ yylex()
if (*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 (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)))
@@ -2372,19 +2393,8 @@ yylex()
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++;
@@ -2476,8 +2486,8 @@ yylex()
last_lop = oldbufptr;
last_lop_op = OP_ENTERSUB;
/* Check for a constant sub */
- if (SvPOK(cv) && !SvCUR(cv)) {
- SV *sv = sub_const(cv);
+ {
+ SV *sv = cv_const_sv(cv);
if (sv) {
SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
@@ -2511,6 +2521,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)
@@ -2568,13 +2579,15 @@ yylex()
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)) = '<';
@@ -2765,10 +2778,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:
@@ -2827,10 +2846,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);
@@ -2872,10 +2891,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);
@@ -2889,7 +2908,7 @@ yylex()
case KEY_if:
yylval.ival = curcop->cop_line;
- OPERATOR(IF);
+ PRETERMBLOCK(IF);
case KEY_index:
LOP(OP_INDEX,XTERM);
@@ -2920,7 +2939,6 @@ yylex()
UNI(OP_LCFIRST);
case KEY_local:
- yylval.ival = 0;
OPERATOR(LOCAL);
case KEY_length:
@@ -2971,8 +2989,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);
@@ -3061,6 +3078,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;
@@ -3192,16 +3222,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);
@@ -3393,11 +3423,11 @@ yylex()
case KEY_until:
yylval.ival = curcop->cop_line;
- OPERATOR(UNTIL);
+ PRETERMBLOCK(UNTIL);
case KEY_unless:
yylval.ival = curcop->cop_line;
- OPERATOR(UNLESS);
+ PRETERMBLOCK(UNLESS);
case KEY_unlink:
LOP(OP_UNLINK,XTERM);
@@ -3449,7 +3479,7 @@ yylex()
case KEY_while:
yylval.ival = curcop->cop_line;
- OPERATOR(WHILE);
+ PRETERMBLOCK(WHILE);
case KEY_warn:
hints |= HINT_BLOCK_SCOPE;
@@ -4227,20 +4257,21 @@ 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;
}
- 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",
@@ -4277,10 +4308,8 @@ 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 == 'o')
@@ -4307,14 +4336,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))
pmflag(&pm->op_pmflags,*s++);
-
pm->op_pmpermflags = pm->op_pmflags;
+
lex_op = (OP*)pm;
yylval.ival = OP_MATCH;
return s;
@@ -4392,8 +4421,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);
}
@@ -4540,7 +4567,7 @@ register char *s;
if (!rsfp) {
d = s;
while (s < bufend &&
- (*s != term || bcmp(s,tokenbuf,len) != 0) ) {
+ (*s != term || memNE(s,tokenbuf,len)) ) {
if (*s++ == '\n')
curcop->cop_line++;
}
@@ -4552,14 +4579,14 @@ 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))) {
+ !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) {
curcop->cop_line = multi_start;
missingterm(tokenbuf);
}
@@ -4573,7 +4600,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);
@@ -4718,7 +4745,7 @@ 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;
@@ -4764,8 +4791,9 @@ char *start;
croak("panic: scan_num");
case '0':
{
- U32 i;
+ UV u;
I32 shift;
+ bool overflowed = FALSE;
if (s[1] == 'x') {
shift = 4;
@@ -4775,8 +4803,10 @@ char *start;
goto decimal;
else
shift = 3;
- i = 0;
+ u = 0;
for (;;) {
+ UV n, b;
+
switch (*s) {
default:
goto out;
@@ -4789,25 +4819,27 @@ 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':
@@ -4847,6 +4879,7 @@ char *start;
}
*d = '\0';
sv = NEWSV(92,0);
+ SET_NUMERIC_STANDARD();
value = atof(tokenbuf);
tryi32 = I_32(value);
if (!floatit && (double)tryi32 == value)
@@ -4897,8 +4930,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;
@@ -4947,22 +4980,20 @@ start_subparse()
CV* outsidecv = compcv;
AV* comppadlist;
-#ifndef __QNX__
if (compcv) {
assert(SvTYPE(compcv) == SVt_PVCV);
}
-#endif
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);
@@ -4987,27 +5018,6 @@ start_subparse()
return oldsavestack_ix;
}
-SV *
-sub_const(cv)
-CV *cv;
-{
- OP *o;
- SV *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 (type != OP_CONST || sv)
- return Nullsv;
- sv = ((SVOP*)o)->op_sv;
- }
- return sv;
-}
-
int
yywarn(s)
char *s;
@@ -5052,7 +5062,7 @@ char *s;
(void)strcpy(tname,"within string");
}
else if (yychar < 32)
- (void)sprintf(tname,"next char ^%c",yychar+64);
+ (void)sprintf(tname,"next char ^%c",toCTRL(yychar));
else
(void)sprintf(tname,"next char %c",yychar);
(void)sprintf(buf, "%s at %s line %d, %s\n",
@@ -5068,7 +5078,7 @@ char *s;
else if (in_eval)
sv_catpv(GvSV(errgv),buf);
else
- fputs(buf,stderr);
+ PerlIO_printf(PerlIO_stderr(), "%s",buf);
if (++error_count >= 10)
croak("%s has too many errors.\n",
SvPVX(GvSV(curcop->cop_filegv)));
diff --git a/universal.c b/universal.c
index 830e2066ac..476b60d3c0 100644
--- a/universal.c
+++ b/universal.c
@@ -74,11 +74,44 @@ int level;
return &sv_no;
}
+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, *rv;
+ SV *sv;
char *name;
if (items != 2)
@@ -87,39 +120,8 @@ XS(XS_UNIVERSAL_isa)
sv = ST(0);
name = (char *)SvPV(ST(1),na);
- if (!SvROK(sv)) {
- rv = &sv_no;
- }
- else if((sv = (SV*)SvRV(sv)) && SvOBJECT(sv) &&
- &sv_yes == isa_lookup(SvSTASH(sv), name, strlen(name), 0)) {
- rv = &sv_yes;
- }
- else {
- char *s;
-
- switch (SvTYPE(sv)) {
- case SVt_NULL:
- case SVt_IV:
- case SVt_NV:
- case SVt_RV:
- case SVt_PV:
- case SVt_PVIV:
- case SVt_PVNV:
- case SVt_PVBM:
- case SVt_PVMG: s = "SCALAR"; break;
- case SVt_PVLV: s = "LVALUE"; break;
- case SVt_PVAV: s = "ARRAY"; break;
- case SVt_PVHV: s = "HASH"; break;
- case SVt_PVCV: s = "CODE"; break;
- case SVt_PVGV: s = "GLOB"; break;
- case SVt_PVFM: s = "FORMATLINE"; break;
- case SVt_PVIO: s = "FILEHANDLE"; break;
- default: s = "UNKNOWN"; break;
- }
- rv = strEQ(s,name) ? &sv_yes : &sv_no;
- }
+ ST(0) = (sv_derived_from(sv, name) ? &sv_yes : &sv_no) ;
- ST(0) = rv;
XSRETURN(1);
}
@@ -132,6 +134,7 @@ XS(XS_UNIVERSAL_can)
SV *rv;
GV *gv;
CV *cvp;
+ HV *pkg = NULL;
if (items != 2)
croak("Usage: UNIVERSAL::can(object-ref, method)");
@@ -140,8 +143,17 @@ XS(XS_UNIVERSAL_can)
name = (char *)SvPV(ST(1),na);
rv = &sv_undef;
- if(SvROK(sv) && (sv = (SV*)SvRV(sv)) && SvOBJECT(sv)) {
- gv = gv_fetchmethod(SvSTASH(sv), name);
+ if(SvROK(sv)) {
+ sv = (SV*)SvRV(sv);
+ if(SvOBJECT(sv))
+ pkg = SvSTASH(sv);
+ }
+ else {
+ pkg = gv_stashsv(sv, FALSE);
+ }
+
+ if (pkg) {
+ gv = gv_fetchmethod(pkg, name);
if(gv && GvCV(gv)) {
/* If the sub is only a stub then we may have a gv to AUTOLOAD */
@@ -169,9 +181,9 @@ static
XS(XS_UNIVERSAL_class)
{
dXSARGS;
- if(SvROK(ST(0))) {
+ if(SvROK(ST(0)) && SvOBJECT(SvRV(ST(0)))) {
SV *sv = sv_newmortal();
- sv_setpv(sv, HvNAME(SvSTASH(ST(0))));
+ sv_setpv(sv, HvNAME(SvSTASH(SvRV(ST(0)))));
ST(0) = sv;
}
XSRETURN(1);
diff --git a/unixish.h b/unixish.h
index 7c9989f43a..4474563755 100644
--- a/unixish.h
+++ b/unixish.h
@@ -9,27 +9,27 @@
* 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
@@ -46,7 +46,7 @@
* This symbol is defined if this system has a stat structure declaring
* st_rdev
*/
-#define USE_STAT_RDEV /**/
+#define USE_STAT_RDEV / **/
/* ACME_MESS:
* This symbol, if defined, indicates that error messages should be
@@ -60,14 +60,14 @@
* 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 / **/
#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
# include <signal.h>
diff --git a/util.c b/util.c
index 68cfd4f4ae..d14a1178f9 100644
--- a/util.c
+++ b/util.c
@@ -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(Perl_debug_log,"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(Perl_debug_log,"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(Perl_debug_log,"0x%x: (%05d) rfree\n",where,an++);
- fprintf(Perl_debug_log,"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(Perl_debug_log,"0x%lx: (%05d) rfree\n",where,an++);
- fprintf(Perl_debug_log,"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*/
@@ -155,12 +152,12 @@ unsigned long size;
void
safefree(where)
-char *where;
+Malloc_t where;
{
#if !(defined(I286) || defined(atarist))
- DEBUG_m( fprintf(Perl_debug_log,"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(Perl_debug_log,"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*/
@@ -170,27 +167,28 @@ char *where;
/* safe version of calloc */
-char *
+Malloc_t
safecalloc(count, size)
MEM_SIZE count;
MEM_SIZE size;
{
- char *ptr;
+ Malloc_t ptr;
-#ifdef MSDOS
- if (size * count > 0xffff) {
- fprintf(stderr, "Allocation too large: %lx\n", size * count) FLUSH;
- my_exit(1);
- }
-#endif /* MSDOS */
+#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
#if !(defined(I286) || defined(atarist))
- DEBUG_m(fprintf(stderr,"0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
+ DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%x: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
#else
- DEBUG_m(fprintf(stderr,"0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
+ DEBUG_m(PerlIO_printf(PerlIO_stderr(), "0x%lx: (%05d) calloc %ld x %ld bytes\n",ptr,an++,(long)count,(long)size));
#endif
size *= count;
ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
@@ -201,24 +199,24 @@ MEM_SIZE size;
else if (nomemok)
return Nullch;
else {
- fputs(no_mem,stderr) FLUSH;
+ PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
my_exit(1);
}
/*NOTREACHED*/
}
-#endif /* !safemalloc */
+#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]++;
@@ -227,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;
@@ -250,13 +248,13 @@ char *where;
safefree(where);
}
-char *
+Malloc_t
safexcalloc(x,count,size)
I32 x;
MEM_SIZE count;
MEM_SIZE size;
{
- register char *where;
+ register Malloc_t where;
where = safexmalloc(x, size * count + ALIGN);
xcount[x]++;
@@ -273,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];
}
}
@@ -408,7 +406,135 @@ 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_i18nl10n(printwarn)
int printwarn;
@@ -419,41 +545,262 @@ perl_init_i18nl10n(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 LC_ALL
+ char *lc_all = getenv("LC_ALL");
+#endif /* LC_ALL */
+#ifdef USE_LOCALE_CTYPE
+ char *lc_ctype = getenv("LC_CTYPE");
+ char *curctype = NULL;
+#endif /* USE_LOCALE_CTYPE */
+#ifdef USE_LOCALE_COLLATE
+ char *lc_collate = getenv("LC_COLLATE");
+ char *curcoll = NULL;
+#endif /* USE_LOCALE_COLLATE */
+#ifdef USE_LOCALE_NUMERIC
+ char *lc_numeric = getenv("LC_NUMERIC");
+ char *curnum = NULL;
+#endif /* USE_LOCALE_NUMERIC */
+ char *lang = getenv("LANG");
+ bool setlocale_failure = FALSE;
+
+#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 */
+
+ 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");
+
+#ifdef LC_ALL
+ PerlIO_printf(PerlIO_stderr(),
+ "\tLC_ALL = %c%s%c,\n",
+ lc_all ? '"' : '(',
+ lc_all ? lc_all : "unset",
+ lc_all ? '"' : ')');
+#endif /* 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",
+ (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;
@@ -473,52 +820,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(Perl_debug_log,"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 *
@@ -548,91 +867,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;
@@ -665,96 +943,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;
}
@@ -787,148 +1035,6 @@ register I32 len;
return newaddr;
}
-#if !defined(I_STDARG) && !defined(I_VARARGS)
-
-/*
- * Fallback on the old hackers way of doing varargs
- */
-
-/*VARARGS1*/
-char *
-mess(pat,a1,a2,a3,a4)
-char *pat;
-long a1, a2, a3, a4;
-{
- char *s;
- char *s_start;
- I32 usermess = strEQ(pat,"%s");
- SV *tmpstr;
-
- 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);
- }
-
- 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)) ) {
- (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);
- }
- (void)strcpy(s,".\n");
- s += 2;
- }
- 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;
-}
-
-/*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);
-#else
- my_exit((U32)((errno&255)?errno:((statusvalue&255)?statusvalue:255)));
-#endif
-}
-
-/*VARARGS1*/
-void warn(pat,a1,a2,a3,a4)
-char *pat;
-long a1, a2, a3, a4;
-{
- char *message;
- SV *sv;
- 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);
- }
- 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)
@@ -965,7 +1071,7 @@ mess(pat, args)
}
va_end(*args);
- if (s[-1] != '\n') {
+ if (!(s > s_start && s[-1] == '\n')) {
if (dirty)
strcpy(s, " during global destruction.\n");
else {
@@ -992,10 +1098,10 @@ mess(pat, args)
if (s - s_start >= sizeof(buf)) { /* Ooops! */
if (usermess)
- fputs(SvPVX(tmpstr), stderr);
+ PerlIO_puts(PerlIO_stderr(), SvPVX(tmpstr));
else
- fputs(buf, stderr);
- fputs("panic: message overflow - memory corrupted!\n",stderr);
+ PerlIO_puts(PerlIO_stderr(), buf);
+ PerlIO_puts(PerlIO_stderr(), "panic: message overflow - memory corrupted!\n");
my_exit(1);
}
if (usermess)
@@ -1005,22 +1111,32 @@ mess(pat, args)
}
#ifdef I_STDARG
-void
-croak(char* pat, ...)
+OP *
+die(char* pat, ...)
#else
/*VARARGS0*/
-void
-croak(pat, va_alist)
+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;
+ /* 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);
+ }
+
#ifdef I_STDARG
va_start(args, pat);
#else
@@ -1028,24 +1144,79 @@ croak(pat, va_alist)
#endif
message = mess(pat, &args);
va_end(args);
+
if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) {
dSP;
+ SV *msg = sv_2mortal(newSVpv(message, 0));
PUSHMARK(sp);
EXTEND(sp, 1);
- PUSHs(sv_2mortal(newSVpv(message,0)));
+ PUSHs(msg);
PUTBACK;
perl_call_sv((SV*)cv, G_DISCARD);
+
+ /* It's okay for the __DIE__ hook to modify the message. */
+ message = SvPV(msg, na);
+ }
+
+ restartop = die_where(message);
+ if ((!restartop && was_in_eval) || oldrunlevel > 1)
+ Siglongjmp(top_env, 3);
+ return restartop;
+}
+
+#ifdef I_STDARG
+void
+croak(char* pat, ...)
+#else
+/*VARARGS0*/
+void
+croak(pat, va_alist)
+ char *pat;
+ va_dcl
+#endif
+{
+ va_list args;
+ char *message;
+ 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) {
+ SV *olddiehook = diehook;
+ diehook = Nullsv; /* sv_2cv might call croak() */
+ cv = sv_2cv(olddiehook, &stash, &gv, 0);
+ diehook = olddiehook;
+ if (cv && !CvDEPTH(cv)) {
+ dSP;
+ SV *msg = sv_2mortal(newSVpv(message, 0));
+
+ PUSHMARK(sp);
+ EXTEND(sp, 1);
+ PUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ /* It's okay for the __DIE__ hook to modify the message. */
+ message = SvPV(msg, na);
+ }
}
if (in_eval) {
restartop = die_where(message);
Siglongjmp(top_env, 3);
}
- fputs(message,stderr);
- (void)Fflush(stderr);
+ PerlIO_puts(PerlIO_stderr(),message);
+ (void)PerlIO_flush(PerlIO_stderr());
if (e_tmpname) {
if (e_fp) {
- fclose(e_fp);
+ PerlIO_close(e_fp);
e_fp = Nullfp;
}
(void)UNLINK(e_tmpname);
@@ -1084,24 +1255,28 @@ 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 *oldwarnhook = warnhook;
+ warnhook = Nullsv; /* sv_2cv might end up calling warn() */
+ cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
+ warnhook = oldwarnhook;
+ if (cv && !CvDEPTH(cv)) {
+ dSP;
+
+ PUSHMARK(sp);
+ EXTEND(sp, 1);
+ PUSHs(sv_2mortal(newSVpv(message,0)));
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+ 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 */
void
@@ -1213,22 +1388,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
@@ -1258,14 +1435,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 */
@@ -1419,9 +1588,9 @@ VTOH(vtohs,short)
VTOH(vtohl,long)
#endif
-#if (!defined(DOSISH) || defined(HAS_FORK)) && !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;
@@ -1430,17 +1599,25 @@ char *mode;
register I32 this, that;
register I32 pid;
SV *sv;
- I32 doexec = strNE(cmd,"-");
+ I32 doexec =
+#ifdef AMIGAOS
+ 1;
+#else
+ strNE(cmd,"-");
+#endif
+#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) {
@@ -1494,17 +1671,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
@@ -1517,12 +1696,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
@@ -1554,33 +1733,152 @@ int newfd;
}
#endif
-#if (!defined(DOSISH) || defined(HAS_FORK)) && !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;
- 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
+ PerlIO_close(ptr);
#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);
+ rsignal_restore(SIGHUP, &hstat);
+ rsignal_restore(SIGINT, &istat);
+ rsignal_restore(SIGQUIT, &qstat);
return(pid < 0 ? pid : status);
}
#endif /* !DOSISH */
@@ -1659,13 +1957,23 @@ int status;
return;
}
-#if defined(atarist) || (defined(OS2) && !defined(HAS_FORK))
+#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
@@ -1715,29 +2023,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
@@ -1748,18 +2033,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;
}
@@ -1767,10 +2058,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;
}
@@ -1778,8 +2069,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;
}
@@ -1827,18 +2118,23 @@ char *b;
}
#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'))
@@ -1854,14 +2150,33 @@ 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/utils/Makefile b/utils/Makefile
index 33947c87f1..958dc038d7 100644
--- a/utils/Makefile
+++ b/utils/Makefile
@@ -4,16 +4,16 @@ 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
+splain: ../lib/diagnostics.pm
+
clean:
realclean:
diff --git a/utils/c2ph.PL b/utils/c2ph.PL
index 219af02933..5f4523aa84 100644
--- a/utils/c2ph.PL
+++ b/utils/c2ph.PL
@@ -25,9 +25,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 +46,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 +95,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 +140,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 +193,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 +251,7 @@ compiler and gcc.
Anyway, here it is. Should run on perl v4 or greater. Maybe less.
---tom
+ --tom
=cut
diff --git a/utils/h2ph.PL b/utils/h2ph.PL
index 951705a6dc..1b2ce312a0 100644
--- a/utils/h2ph.PL
+++ b/utils/h2ph.PL
@@ -26,22 +26,18 @@ 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{installsitearchlib}";
-
+$Config{startperl}
+ eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+ if \$running_under_some_shell;
!GROK!THIS!
# In the following, perl variables are not expanded during extraction.
print OUT <<'!NO!SUBS!';
+use Config;
+$perlincl = @Config{installsitearch};
+
chdir '/usr/include' || die "Can't cd /usr/include";
@isatype = split(' ',<<END);
@@ -58,6 +54,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, ">-");
@@ -106,7 +106,7 @@ foreach $file (@ARGV) {
$args = "local($args) = \@_;\n$t ";
}
s/^\s+//;
- do expr();
+ expr();
$new =~ s/(["\\])/\\$1/g;
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g;
@@ -120,7 +120,7 @@ foreach $file (@ARGV) {
}
else {
s/^\s+//;
- do expr();
+ expr();
$new = 1 if $new eq '';
if ($t ne '') {
$new =~ s/(['\\])/\\$1/g;
@@ -148,7 +148,7 @@ foreach $file (@ARGV) {
elsif (s/^if\s+//) {
$new = '';
$inif = 1;
- do expr();
+ expr();
$inif = 0;
print OUT $t,"if ($new) {\n";
$tab += 4;
@@ -157,7 +157,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);
@@ -197,10 +197,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') {
@@ -252,56 +273,63 @@ sub expr {
}
}
##############################################################################
+__END__
- # 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
+=head1 NAME
+
+h2ph - convert .h C header files to .ph Perl header files
+
+=head1 SYNOPSIS
+
+B<h2ph [headerfiles]>
+
+=head1 DESCRIPTION
+
+I<h2ph>
converts any C header files specified to the corresponding Perl header file
format.
It is most easily run while in /usr/include:
-.nf
cd /usr/include; h2ph * sys/*
-.fi
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/utils/h2xs.PL b/utils/h2xs.PL
index e3d60ec0bc..73df801a24 100644
--- a/utils/h2xs.PL
+++ b/utils/h2xs.PL
@@ -25,21 +25,22 @@ 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.
print OUT <<'!NO!SUBS!';
+
=head1 NAME
h2xs - convert .h C header files to Perl extensions
=head1 SYNOPSIS
-B<h2xs> [B<-AOPXcf>] [B<-v> version] [B<-n> module_name] [B<-p> prefix] [B<-s> sub] [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>
@@ -71,6 +72,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.
@@ -79,11 +85,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
@@ -113,10 +128,18 @@ These macros are assumed to have a return type of B<char *>, e.g., S<-s sec_rgy_
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
@@ -158,6 +181,17 @@ XS-based.
h2xs -n DCE::rgynbase -p sec_rgy_ \
-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
+ # Make XS without defines in perl.h, but with function declarations
+ # visible from perl.h. Name of the extension is perl1.
+ # When scanning perl.h, define -DEXT=extern -DdEXT= -DINIT(x)=
+ # Extra backslashes below because the string is passed to shell.
+ # Note that a directory with perl header files would
+ # be added automatically to include path.
+ h2xs -xAn perl1 -F "-DEXT=extern -DdEXT= -DINIT\(x\)=" perl.h
+
+ # Same with function declaration in proto.h as visible from perl.h.
+ h2xs -xAn perl2 perl.h,proto.h
+
=head1 ENVIRONMENT
No environment variables are used.
@@ -172,30 +206,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] [-p prefix] [-s subs] [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.
- -p Specify a prefix which should be removed from the Perl function names.
- -s Create subroutines for specified macros.
-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.
@@ -203,7 +240,7 @@ extra_libraries
}
-getopts("AOPXcfhxv:n:p:s:") || usage;
+getopts("AF:OPXcdfhn:p:s:v:x") || usage;
usage if $opt_h;
@@ -226,6 +263,8 @@ if( $path_h ){
warn "Nesting of headerfile ignored with -n\n";
}
$path_h .= ".h" unless $path_h =~ /\.h$/;
+ $fullpath = $path_h;
+ $path_h =~ s/,.*$// if $opt_x;
if ($^O eq 'VMS') { # Consider overrides of default location
if ($path_h !~ m![:>\[]!) {
my($hadsys) = ($path_h =~ s!^sys/!!i);
@@ -238,33 +277,39 @@ if( $path_h ){
}
}
elsif ($^O eq 'os2') {
- $path_h = "/usr/include/$path_h" unless $path_h =~ m#^([a-z]:)?[./]#i;
+ $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" 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>) {
+ 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";
+ 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";
- }
+ 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;
}
@@ -307,9 +352,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";
@@ -447,6 +519,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!
#
@@ -466,7 +557,7 @@ $pod = <<"END" unless $opt_P;
#unedited.
#
#Blah blah blah.
-#
+#$const_doc$fdecl_doc
#=head1 AUTHOR
#
#$author, $email
@@ -609,12 +700,18 @@ 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--;
@@ -631,37 +728,85 @@ EOP
for $arg (0 .. $numargs - 1) {
print $fh <<"EOP";
- $argtypes[$arg] $argnames[$arg]
+ $argtypes[$arg] $argnames[$arg]$argarrays[$arg]
EOP
}
}
-my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*';
+# 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) {
- require C::Scan; # Run-time directive
- require Config; # Run-time directive
- my $c = new C::Scan 'filename' => $path_h;
- $c->set('includeDirs' => [$Config::Config{shrpdir}]);
-
- my $fdec = $c->get('parsed_fdecls');
-
- for $decl (@$fdec) { print_decl(\*XS, $decl) }
+ 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";
@@ -728,6 +873,16 @@ if (!@files) {
unless ($@) { @files = readdir(D); closedir(D); }
}
if (!@files) { @files = map {chomp && $_} `ls`; }
+if ($^O eq 'VMS') {
+ foreach (@files) {
+ # Clip trailing '.' for portability -- non-VMS OSs don't expect it
+ s%\.$%%;
+ # Fix up for case-sensitive file systems
+ s/$modfname/$modfname/i && next;
+ $_ = "\U$_" if $_ eq 'manifest' or $_ eq 'changes';
+ $_ = 'Makefile.PL' if $_ eq 'makefile.pl';
+ }
+}
print MANI join("\n",@files);
close MANI;
!NO!SUBS!
diff --git a/utils/perlbug.PL b/utils/perlbug.PL
index 9527025aac..7f894d89a2 100644
--- a/utils/perlbug.PL
+++ b/utils/perlbug.PL
@@ -25,9 +25,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.
@@ -213,7 +213,7 @@ EOF
if( !$domain) {
$guess = "";
- } elsif ($Is_VMS && !$::Config{'has_sockets'}) {
+ } elsif ($Is_VMS && !$::Config{'d_socket'}) {
$guess = "$domain\:\:$me";
} else {
$guess = "$me\@$domain" if $domain;
diff --git a/utils/perldoc.PL b/utils/perldoc.PL
index e53d542cb9..e0f8a43b86 100644
--- a/utils/perldoc.PL
+++ b/utils/perldoc.PL
@@ -25,16 +25,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
@@ -58,6 +59,9 @@ $Is_VMS = $^O eq 'VMS';
sub usage{
warn "@_\n" if @_;
+ # Make sure exit status is success under VMS, so shell doesn't
+ # display error messages left over from startup.
+ ($! = 0, $^E = 1) if $^O eq 'VMS';
die <<EOF;
perldoc [-h] [-v] [-u] PageName|ModuleName|ProgramName...
-h Display this help message.
@@ -113,8 +117,8 @@ sub containspod {
local($")="/";
my(@p,$p,$cip);
foreach $p (split(/\//, $file)){
- if ($Is_VMS and not scalar @p) {
- # VMS filesystems don't begin at '/'
+ if (($Is_VMS or $^O eq 'os2') and not scalar @p) {
+ # VMSish filesystems don't begin at '/'
push(@p,$p);
next;
}
@@ -218,13 +222,13 @@ if( ! -t STDOUT ) { $opt_f = 1 }
unless($Is_VMS) {
$tmp = "/tmp/perldoc1.$$";
+ push @pagers, qw( more less pg view cat );
+ unshift @pagers, $ENV{PAGER} if $ENV{PAGER};
$goodresult = 0;
- @pagers = qw( more less pg view cat );
- unshift(@pagers,$ENV{PAGER}) if $ENV{PAGER};
} else {
$tmp = 'Sys$Scratch:perldoc.tmp1_'.$$;
- @pagers = qw( most more less type/page );
- unshift(@pagers,$ENV{PERLDOC_PAGER}) if $ENV{PERLDOC_PAGER};
+ push @pagers, qw( most more less type/page );
+ unshift @pagers, $ENV{PERLDOC_PAGER} if $ENV{PERLDOC_PAGER};
$goodresult = 1;
}
@@ -244,7 +248,11 @@ foreach (@found) {
close(TMP);
} elsif(not $opt_u) {
open(TMP,">>$tmp");
- $rslt = `pod2man $_ | nroff -man`;
+ if($^O =~ /hpux/) {
+ $rslt = `pod2man $_ | nroff -man | col -x`;
+ } else {
+ $rslt = `pod2man $_ | nroff -man`;
+ }
if ($Is_VMS) { $err = !($? % 2) || $rslt =~ /IVVERB/; }
else { $err = $?; }
print TMP $rslt unless $err;
@@ -293,10 +301,11 @@ B<perldoc> [B<-h>] [B<-v>] [B<-t>] [B<-u>] PageName|ModuleName|ProgramName
=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.
diff --git a/utils/pl2pm.PL b/utils/pl2pm.PL
index e8277bb673..8d47481341 100644
--- a/utils/pl2pm.PL
+++ b/utils/pl2pm.PL
@@ -25,9 +25,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 +56,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/utils/splain.PL b/utils/splain.PL
new file mode 100644
index 0000000000..53954db65a
--- /dev/null
+++ b/utils/splain.PL
@@ -0,0 +1,47 @@
+#!/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)) =~ s/\.PL$//;
+$file =~ s/\.pl$//
+ if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
+
+# 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/vms/Makefile b/vms/Makefile
index 5246b50506..3622ad9c42 100644
--- a/vms/Makefile
+++ b/vms/Makefile
@@ -1,4 +1,4 @@
-#> This file produced from Descrip.MMS by mms2make.pl
+#> 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
#>
@@ -18,21 +18,33 @@
#### Start of system configuration section. ####
+#> .ifdef AXE
# File type to use for object files
+#> O = .abj
# File type to use for object libraries
+#> OLB = .alb
# File type to use for executable images
+#> E = .axe
+#> .else
# 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
+#> .endif
+#> .ifdef __AXP__
+#> DECC = 1
+#> ARCH = VMS_AXP
+#> OBJVAL = $(O)
+#> .else
ARCH = VMS_VAX
OBJVAL = $@
+#> .endif
# Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_00301#
+PERL_VERSION = 5_00311#
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
@@ -40,19 +52,51 @@ ARCHCORE = [.lib.$(ARCH).$(PERL_VERSION).CORE]
ARCHAUTO = [.lib.$(ARCH).$(PERL_VERSION).auto]
+#> .ifdef DECC_PIPES_BROKEN
+#> PIPES_BROKEN = 1
+#> .endif
+#> .ifdef GNUC
+#> .first:
+#> @ $$@[.vms]fndvers.com "" "" "[.vms]Makefile"
+#> @ If f$$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]
+#> CC = gcc
# -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=$@/NoCase_Hack/Optimize=2/CC1="""""-fno-builtin"""""
+#> DBGSPECFLAGS =
+#> XTRADEF = ,GNUC_ATTRIBUTE_CHECK
+#> XTRAOBJS =
+#> LIBS1 = GNU_CC:[000000]GCCLIB.OLB/Library
+#> LIBS2 = sys$$Share:VAXCRTL/Shareable
+#> POSIX =
+#> .else
XTRAOBJS =
LIBS1 = $(XTRAOBJS)
DBGSPECFLAGS = /Show=(Source,Include,Expansion)
+#> .ifdef decc
# 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:
+#> @ Set Process/Privilege=(NoSYSNAM)
+#> @ $$@[.vms]fndvers.com "" "" "[.vms]Makefile"
+#> @ 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
+#> .else
+#> @ If f$$TrnLnm("Sys").eqs."" .and. f$$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS DECC$Library_Include
+#> .endif
+#>
+#> LIBS2 =
+#> XTRACCFLAGS = /Include=[]/Standard=Relaxed_ANSI/Prefix=All/Obj=$(OBJVAL)
+#> XTRADEF =
+#> POSIX = POSIX
+#> .else # VAXC
.first:
@ $$@[.vms]fndvers.com "" "" "[.vms]Makefile"
@ If f$$TrnLnm("Sys").eqs."" .and. f$$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS sys$$Library
@@ -61,15 +105,34 @@ DBGSPECFLAGS = /Show=(Source,Include,Expansion)
XTRACCFLAGS = /Include=[]/Object=$(O)
XTRADEF =
LIBS2 = sys$$Share:VAXCRTL/Shareable
+POSIX =
+#> .endif
+#> .endif
+#> .ifdef __DEBUG__
+#> DBGCCFLAGS = /List/Debug/NoOpt$(DBGSPECFLAGS)
+#> DBGLINKFLAGS = /Trace/Debug/Map/Full/Cross
+#> DBG = DBG
+#> .else
DBGCCFLAGS = /NoList
DBGLINKFLAGS = /NoMap
DBG =
+#> .endif
+#> .ifdef SOCKET
+#> SOCKDEF = ,VMS_DO_SOCKETS
+#> SOCKLIB = SocketShr/Share
# 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.
+#> SOCKC = sockadapt.c
+#> SOCKH = sockadapt.h
+#> SOCKCLIS = ,$(SOCKC)
+#> SOCKHLIS = ,$(SOCKH)
+#> SOCKOBJ = ,sockadapt$(O)
+#> SOCKPM = [.lib]Socket.pm
+#> .else
SOCKDEF =
SOCKLIB =
SOCKC =
@@ -78,6 +141,7 @@ SOCKCLIS =
SOCKHLIS =
SOCKOBJ =
SOCKPM =
+#> .endif
# C preprocessor manifest "DEBUGGING" ==> perl -D, not the VMS debugger
CFLAGS = /Define=(DEBUGGING$(SOCKDEF)$(XTRADEF))$(XTRACCFLAGS)$(DBGCCFLAGS)
@@ -104,8 +168,13 @@ MYEXT = DynaLoader
# 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),
+#> .ifdef SOCKET
+#> EXT = $(MYEXT) Socket
+#> extobj = $(myextobj) [.ext.socket]socket$(O),
+#> .else
EXT = $(MYEXT)
extobj = $(myextobj)
+#> .endif
#### End of system configuration section. ####
@@ -114,16 +183,16 @@ 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, universal.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), universal$(O), globals$(O), vms$(O) $(SOCKOBJ)
@@ -134,17 +203,23 @@ 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
+#> .ifdef SOCKET
+#> acs = $(ARCHCORE)$(SOCKH)
+#> .else
acs =
+#> .endif
CRTL = []crtl.opt
CRTLOPTS =,$(CRTL)/Options
.suffixes:
+#> .ifdef LINK_ONLY
+#> .else
.suffixes: $(O) .c .xs
.xs.c :
@@ -157,13 +232,14 @@ CRTLOPTS =,$(CRTL)/Options
.xs$(O) :
$(XSUBPP) $< >$(MMS$SOURCE_NAME).c
$(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c
+#> .endif
all : base extras libmods utils podxform archcorefiles preplibrary perlpods
@ $(NOOP)
base : miniperl perl
@ $(NOOP)
-extras : Fcntl FileHandle IO Opcode 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
@ $(NOOP)
@@ -208,7 +284,11 @@ 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"
+#> .ifdef gnuc
+#> Link $(LINKFLAGS)/Exe=$@ perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option, crtl.opt/Option
+#> .else
Link $(LINKFLAGS)/Exe=$@ 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=$@ $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option
@@ -218,8 +298,18 @@ $(DBG)perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts
# perlshr_gbl*.mar, perlshr_gbl*$(O) - VAX only
# The song and dance with gen_shrfls.opt accomodates DCL's 255 character
# line length limit.
+#> .ifdef PIPES_BROKEN
# 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)
+#> $(CC) $(CFLAGS)/NoObject/NoList/PreProcess=perl.i perl.h
+#> @ $(MINIPERL) -e "print join('|',@ARGV),'|';" "~~NOCC~~perl.i~~$(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 perl.i;, 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
+#> .else
$(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
@@ -227,6 +317,7 @@ $(DBG)perlshr_xtras.ts : perl.h config.h vmsish.h proto.h [.vms]gen_shrfls.pl $(
@ 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
+#> .endif
$(ARCHDIR)config.pm : [.lib]config.pm
Create/Directory $(ARCHDIR)
@@ -282,43 +373,43 @@ Opcode : [.lib]Opcode.pm [.lib]ops.pm [.lib]Safe.pm [.lib.auto.Opcode]Opcode$(E)
[.ext.Opcode]Makefile : [.ext.Opcode]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Opcode]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
-FileHandle : [.lib]FileHandle.pm [.lib.auto.FileHandle]FileHandle$(E)
+Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
@ $(NOOP)
-[.lib]FileHandle.pm : [.ext.FileHandle]Makefile
+[.lib]Fcntl.pm : [.ext.Fcntl]Makefile
@ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
- @ Set Default [.ext.FileHandle]
+ @ Set Default [.ext.Fcntl]
$(MMS)
@ Set Default [--]
-[.lib.auto.FileHandle]FileHandle$(E) : [.ext.FileHandle]Makefile
- @ Set Default [.ext.FileHandle]
+[.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.FileHandle]Makefile : [.ext.FileHandle]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
- $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.FileHandle]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+[.ext.Fcntl]Makefile : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+ $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
-Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
+POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E)
@ $(NOOP)
-[.lib]Fcntl.pm : [.ext.Fcntl]Makefile
+[.lib]POSIX.pm : [.ext.POSIX]Makefile
@ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
- @ Set Default [.ext.Fcntl]
+ @ Set Default [.ext.POSIX]
$(MMS)
@ Set Default [--]
-[.lib.auto.Fcntl]Fcntl$(E) : [.ext.Fcntl]Makefile
- @ Set Default [.ext.Fcntl]
+[.lib.auto.POSIX]POSIX$(E) : [.ext.POSIX]Makefile
+ @ 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.Fcntl]Makefile : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
- $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+[.ext.POSIX]Makefile : [.ext.POSIX]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(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)
@@ -558,6 +649,30 @@ printconfig :
@ $$@[.vms]make_command $(MMS) $(MMSQUALIFIERS) $(MMSTARGETS)
@ $$@[.vms]myconfig "$(CC)" "$(CFLAGS)" "$(LINKFLAGS)" "$(LIBS1)" "$(LIBS2)" "$(SOCKLIB)" "$(EXT)" "$(DBG)"
+#> .ifdef SOCKET
+#>
+#> .ifdef LINK_ONLY
+#> .else
+#> $(SOCKOBJ) : $(SOCKC) $(SOCKH)
+#>
+#> [.ext.Socket]Socket$(O) : [.ext.Socket]Socket.c
+#> $(CC) $(CFLAGS) /Object=$@ [.ext.Socket]Socket.c
+#>
+#> [.ext.Socket]Socket.c : [.ext.Socket]Socket.xs $(MINIPERL_EXE)
+#> $(XSUBPP) [.ext.Socket]Socket.xs >$@
+#> .endif # !LINK_ONLY
+#>
+#> vmsish.h : $(SOCKH)
+#>
+#> $(SOCKC) : [.vms]$(SOCKC)
+#> Copy/Log/NoConfirm [.vms]$(SOCKC) []$(SOCKC)
+#>
+#> $(SOCKH) : [.vms]$(SOCKH)
+#> Copy/Log/NoConfirm [.vms]$(SOCKH) []$(SOCKH)
+#>
+#> [.lib]Socket.pm : [.ext.Socket]Socket.pm
+#> Copy/Log/NoConfirm [.ext.Socket]Socket.pm $@
+#> .endif
# The following three header files are generated automatically
# keywords.h : keywords.pl
@@ -589,8 +704,11 @@ perly.h : [.vms]perly_h.vms
# rename y.tab.h perly.h
# $(INSTPERL) [.vms]vms_yfix.pl perly.c perly.h [.vms]perly_c.vms [.vms]perly_h.vms
+#> .ifdef LINK_ONLY
+#> .else
perly$(O) : perly.c, perly.h, $(h)
$(CC) $(CFLAGS) perly.c
+#> .endif
test : all
- @[.VMS]Test.Com "$(E)"
@@ -651,6 +769,12 @@ $(ARCHCORE)patchlevel.h : patchlevel.h
$(ARCHCORE)perl.h : perl.h
@ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
Copy/Log perl.h $@
+$(ARCHCORE)perlio.h : perlio.h
+ @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
+ Copy/Log perlio.h $@
+$(ARCHCORE)perlsdio.h : perlsdio.h
+ @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
+ Copy/Log perlsdio.h $@
$(ARCHCORE)perly.h : perly.h
@ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
Copy/Log perly.h $@
@@ -678,6 +802,11 @@ $(ARCHCORE)util.h : util.h
$(ARCHCORE)vmsish.h : vmsish.h
@ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
Copy/Log vmsish.h $@
+#> .ifdef SOCKET
+#> $(ARCHCORE)$(SOCKH) : $(SOCKH)
+#> @ If f$$Search("$(ARCHDIR)CORE.dir").eqs."" Then Create/Directory $(ARCHCORE)
+#> Copy/Log $(SOCKH) $@
+#> .endif
$(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) $@
@@ -691,6 +820,8 @@ $(ARCHAUTO)time.stamp :
@ If f$$Search("$(ARCHDIR)auto.dir").eqs."" Then Create/Directory $(ARCHAUTO)
@ If f$$Search("$@").eqs."" Then Copy/NoConfirm _NLA0: $(MMS$TARGET)
+#> .ifdef LINK_ONLY
+#> .else
# AUTOMATICALLY GENERATED MAKE DEPENDENCIES--PUT NOTHING BELOW THIS LINE
av$(O) : EXTERN.h
av$(O) : av.c
@@ -1271,6 +1402,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
@@ -1340,6 +1494,7 @@ globals$(O) : scope.h
globals$(O) : sv.h
globals$(O) : vmsish.h
globals$(O) : util.h
+#> .endif # !LINK_ONLY
config.h : [.vms]config.vms
Copy/Log/NoConfirm [.vms]config.vms []config.h
@@ -1360,9 +1515,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
@@ -1386,7 +1541,8 @@ tidy : cleanlis
- 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("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*./Exclude=Makefile.
+ - If f$$Search("[.lib]perlbug.;-1").nes."" Then Purge/NoConfirm/Log [.lib]perlbug.
- If f$$Search("[.lib.pod]*.;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.
clean : tidy
@@ -1402,6 +1558,11 @@ clean : tidy
Set Default [.ext.Opcode]
- $(MMS) clean
Set Default [--]
+#> .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("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;*
@@ -1435,6 +1596,11 @@ realclean : clean
Set Default [.ext.Opcode]
- $(MMS) realclean
Set Default [--]
+#> .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);"
@@ -1444,7 +1610,7 @@ realclean : clean
- 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("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*/Exclude=Makefile.
- 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*.;*
diff --git a/vms/config.vms b/vms/config.vms
index e1d609a747..186df810cc 100644
--- a/vms/config.vms
+++ b/vms/config.vms
@@ -8,10 +8,10 @@
* GenConfig.pl when producing Config.pm.
*
* config.h for VMS
- * Version: 5.002_01
+ * Version: 5.003_08
*/
-/* 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,26 @@
*/
#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_00301" /**/
+#define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_00310" /**/
+#define ARCHLIB ARCHLIB_EXP /*config-skip*/
/* CPPSTDIN:
* This symbol contains the first part of the string which will invoke
@@ -215,18 +220,6 @@
*/
#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 /**/
-
/* HAS_GETPRIORITY:
* This symbol, if defined, indicates that the getpriority routine is
* available to get a process's priority.
@@ -262,13 +255,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
@@ -378,23 +379,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
@@ -494,36 +478,50 @@
* 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.
+#ifdef USE_STDIO_PTR
+# define FILE_ptr(fp) ((*fp)->_ptr)
+# define FILE_cnt(fp) ((*fp)->_cnt)
+#endif
+
+/* FILE_filbuf:
+ * This macro is used to access the internal stdio _filbuf function
+ * (or equivalent), if STDIO_CNT_LVALUE and STDIO_PTR_LVALUE
+ * are defined. It is typically either _filbuf or __filbuf.
+ * This macro will only be defined if both STDIO_CNT_LVALUE and
+ * STDIO_PTR_LVALUE are defined.
*/
-#undef FILE_ptr
-#undef STDIO_PTR_LVALUE
-#undef FILE_cnt
-#undef STDIO_CNT_LVALUE
+#define FILE_filbuf(fp) do { register int c; if ((c = fgetc(fp)) != EOF) \
+ ungetc(c,(fp)); } while (0);
/* FILE_base:
* This macro is used to access the _base field (or equivalent) of the
@@ -536,8 +534,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
@@ -648,7 +648,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
@@ -681,7 +685,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
@@ -779,6 +783,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.
@@ -796,6 +806,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>.
@@ -820,6 +836,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
@@ -1045,13 +1067,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
@@ -1100,13 +1130,39 @@
* 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 translate strings to doubles.
+ */
+#define HAS_STRTOD /**/
+
+/* HAS_STRTOL:
+ * This symbol, if defined, indicates that the strtol routine is
+ * available to translate strings to integers.
+ */
+#define HAS_STRTOL /**/
+
+/* HAS_STRTOUL:
+ * This symbol, if defined, indicates that the strtoul routine is
+ * available to translate strings to integers.
+ */
+#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
@@ -1143,7 +1199,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.
@@ -1184,12 +1244,6 @@
*/
#define I_MATH /**/
-/* I_LOCALE:
- * This symbol, if defined, indicates to the C program that it should
- * include <locale.h>.
- */
-#undef I_LOCALE /**/
-
/* INTSIZE:
* This symbol contains the size of an int, so that the C preprocessor
* can make decisions based on it.
@@ -1203,6 +1257,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.
@@ -1218,6 +1280,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:
@@ -1294,6 +1364,13 @@
#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
@@ -1305,21 +1382,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.
@@ -1330,6 +1432,7 @@
* any changes to FndVers.Com instead.
*/
#define SITEARCH_EXP "/perl_root/lib/site_perl/VMS_VAX" /**/
+#define SITEARCH SITEARCH_EXP /*config-skip*/
/* SCRIPTDIR:
* This symbol holds the name of the directory in which the user wants
@@ -1409,11 +1512,27 @@
*/
#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
@@ -1450,18 +1569,44 @@
*/
#define HAS_SAFE_MEMCPY /**/
+/* HAS_SANE_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp() routine is
+ * available to compare memory blocks for relative magnitude. If this
+ * symbol is not defined, and if HAS_MEMCMP is defined, then memcmp()
+ * may be used only to compare memory blocks for equality.
+ */
+#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.
@@ -1485,6 +1630,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.
*/
@@ -1545,10 +1720,12 @@
#undef DB_Hash_t /**/
#undef DB_Prefix_t /**/
-/* BIN_SH:
- * This variable contains the path to the shell.
+/* 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 BIN_SH "MCR" /**/
+#undef USE_PERLIO /**/
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
diff --git a/vms/descrip.mms b/vms/descrip.mms
index 31d13e8eb8..b86cbd53ce 100644
--- a/vms/descrip.mms
+++ b/vms/descrip.mms
@@ -65,7 +65,7 @@ OBJVAL = $(MMS$TARGET_NAME)$(O)
.endif
# Updated by fndvers.com -- do not edit by hand
-PERL_VERSION = 5_00301#
+PERL_VERSION = 5_00311#
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
@@ -94,6 +94,7 @@ XTRADEF = ,GNUC_ATTRIBUTE_CHECK
XTRAOBJS =
LIBS1 = GNU_CC:[000000]GCCLIB.OLB/Library
LIBS2 = Sys$Share:VAXCRTL/Shareable
+POSIX =
.else
XTRAOBJS =
LIBS1 = $(XTRAOBJS)
@@ -117,6 +118,7 @@ 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"
@@ -126,6 +128,7 @@ XTRADEF =
XTRACCFLAGS = /Include=[]/Object=$(O)
XTRADEF =
LIBS2 = Sys$Share:VAXCRTL/Shareable
+POSIX =
.endif
.endif
@@ -211,16 +214,16 @@ 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, universal.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), universal$(O), globals$(O), vms$(O) $(SOCKOBJ)
@@ -231,7 +234,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
@@ -267,7 +270,7 @@ all : base extras libmods utils podxform archcorefiles preplibrary perlpods
@ $(NOOP)
base : miniperl perl
@ $(NOOP)
-extras : Fcntl FileHandle IO Opcode 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
@ $(NOOP)
@@ -401,43 +404,43 @@ Opcode : [.lib]Opcode.pm [.lib]ops.pm [.lib]Safe.pm [.lib.auto.Opcode]Opcode$(E)
[.ext.Opcode]Descrip.MMS : [.ext.Opcode]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Opcode]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
-FileHandle : [.lib]FileHandle.pm [.lib.auto.FileHandle]FileHandle$(E)
+Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
@ $(NOOP)
-[.lib]FileHandle.pm : [.ext.FileHandle]Descrip.MMS
+[.lib]Fcntl.pm : [.ext.Fcntl]Descrip.MMS
@ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
- @ Set Default [.ext.FileHandle]
+ @ Set Default [.ext.Fcntl]
$(MMS)
@ Set Default [--]
-[.lib.auto.FileHandle]FileHandle$(E) : [.ext.FileHandle]Descrip.MMS
- @ Set Default [.ext.FileHandle]
+[.lib.auto.Fcntl]Fcntl$(E) : [.ext.Fcntl]Descrip.MMS
+ @ 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.FileHandle]Descrip.MMS : [.ext.FileHandle]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
- $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.FileHandle]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+[.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+ $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
-Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
+POSIX : [.lib]POSIX.pm [.lib.auto.POSIX]POSIX$(E)
@ $(NOOP)
-[.lib]Fcntl.pm : [.ext.Fcntl]Descrip.MMS
+[.lib]POSIX.pm : [.ext.POSIX]Descrip.MMS
@ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
- @ Set Default [.ext.Fcntl]
+ @ Set Default [.ext.POSIX]
$(MMS)
@ Set Default [--]
-[.lib.auto.Fcntl]Fcntl$(E) : [.ext.Fcntl]Descrip.MMS
- @ Set Default [.ext.Fcntl]
+[.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.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
- $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+[.ext.POSIX]Descrip.MMS : [.ext.POSIX]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(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)
@@ -797,6 +800,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)
@@ -1424,6 +1433,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
@@ -1514,9 +1546,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
@@ -1540,7 +1572,8 @@ tidy : cleanlis
- 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("[.utils]*.;-1").nes."" Then Purge/NoConfirm/Log [.utils]*./Exclude=Makefile.
+ - If F$Search("[.lib]perlbug.;-1").nes."" Then Purge/NoConfirm/Log [.lib]perlbug.
- If F$Search("[.lib.pod]*.;-1").nes."" Then Purge/NoConfirm/Log [.lib.pod]*.
clean : tidy
@@ -1556,6 +1589,11 @@ clean : tidy
Set Default [.ext.Opcode]
- $(MMS) clean
Set Default [--]
+.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("Config.H").nes."" Then Delete/NoConfirm/Log Config.H;*
@@ -1589,6 +1627,11 @@ realclean : clean
Set Default [.ext.Opcode]
- $(MMS) realclean
Set Default [--]
+.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);"
@@ -1598,7 +1641,7 @@ realclean : clean
- 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("[.utils]*.").nes."" Then Delete/NoConfirm/Log [.utils]*.;*/Exclude=Makefile.
- 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*.;*
diff --git a/vms/ext/DCLsym/0README.txt b/vms/ext/DCLsym/0README.txt
new file mode 100644
index 0000000000..9dc721d36b
--- /dev/null
+++ b/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/vms/ext/DCLsym/DCLsym.pm b/vms/ext/DCLsym/DCLsym.pm
new file mode 100644
index 0000000000..057951dd99
--- /dev/null
+++ b/vms/ext/DCLsym/DCLsym.pm
@@ -0,0 +1,268 @@
+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:
+
+=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/vms/ext/DCLsym/DCLsym.xs b/vms/ext/DCLsym/DCLsym.xs
new file mode 100644
index 0000000000..3918eb11e5
--- /dev/null
+++ b/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/vms/ext/DCLsym/Makefile.PL b/vms/ext/DCLsym/Makefile.PL
new file mode 100644
index 0000000000..8e6f5bce40
--- /dev/null
+++ b/vms/ext/DCLsym/Makefile.PL
@@ -0,0 +1,3 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile( 'VERSION_FROM' => 'DCLsym.pm' );
diff --git a/vms/ext/DCLsym/test.pl b/vms/ext/DCLsym/test.pl
new file mode 100644
index 0000000000..57f2afbd20
--- /dev/null
+++ b/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/vms/ext/Stdio/Stdio.pm b/vms/ext/Stdio/Stdio.pm
index f87631a32a..ad16af366f 100644
--- a/vms/ext/Stdio/Stdio.pm
+++ b/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.01
+# Revised: 10-Dec-1996
package VMS::Stdio;
@@ -12,8 +12,8 @@ use Carp '&croak';
use DynaLoader ();
use Exporter ();
-$VERSION = '2.0';
-@ISA = qw( Exporter DynaLoader FileHandle );
+$VERSION = '2.01';
+@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;
}
@@ -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
@@ -152,7 +153,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 +188,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 +231,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/vms/ext/Stdio/Stdio.xs b/vms/ext/Stdio/Stdio.xs
index 79eb95335e..200268c7f1 100644
--- a/vms/ext/Stdio/Stdio.xs
+++ b/vms/ext/Stdio/Stdio.xs
@@ -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);
}
@@ -225,7 +225,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/vms/ext/Stdio/test.pl b/vms/ext/Stdio/test.pl
index 12e508aa1f..0b50d63e3a 100755..100644
--- a/vms/ext/Stdio/test.pl
+++ b/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/vms/ext/filespec.t b/vms/ext/filespec.t
index 7c1d4c9d4e..38cd5368c9 100755..100644
--- a/vms/ext/filespec.t
+++ b/vms/ext/filespec.t
@@ -8,7 +8,7 @@ foreach (<DATA>) {
next if /^\s*$/;
push(@tests,$_);
}
-print '1..',scalar(@tests)+1,"\n";
+print '1..',scalar(@tests)+3,"\n";
foreach $test (@tests) {
($arg,$func,$expect) = split(/\t+/,$test);
@@ -24,6 +24,10 @@ foreach $test (@tests) {
}
print +(rmsexpand('[]') eq "\U$ENV{DEFAULT}" ? 'ok ' : 'not ok '),++$idx,"\n";
+print +(rmsexpand('from.here') eq "\L$ENV{DEFAULT}from.here" ?
+ 'ok ' : 'not ok '),++$idx,"\n";
+print +(rmsexpand('from.here','cant:[get.there];2') eq
+ 'cant:[get.there]from.here;2' ? 'ok ' : 'not ok '),++$idx,"\n";
__DATA__
@@ -81,6 +85,7 @@ 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 []
diff --git a/vms/fndvers.com b/vms/fndvers.com
index f1ddc03eca..f1ddc03eca 100755..100644
--- a/vms/fndvers.com
+++ b/vms/fndvers.com
diff --git a/vms/gen_shrfls.pl b/vms/gen_shrfls.pl
index 6972c67edf..87b493fdd0 100644
--- a/vms/gen_shrfls.pl
+++ b/vms/gen_shrfls.pl
@@ -34,7 +34,7 @@
# (i.e. /Define=DEBUGGING,EMBED,MULTIPLICITY)?
#
# Author: Charles Bailey bailey@genetics.upenn.edu
-# Revised: 20-Feb-1996
+# Revised: 3-Dec-1996
require 5.000;
@@ -222,10 +222,10 @@ 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//;
@@ -330,7 +330,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);
@@ -345,6 +345,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/vms/genconfig.pl b/vms/genconfig.pl
index a1df9c1362..521be99e11 100644
--- a/vms/genconfig.pl
+++ b/vms/genconfig.pl
@@ -6,16 +6,18 @@
# 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. 23-Apr-1996 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
@@ -50,6 +52,8 @@ $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;
@@ -91,10 +95,13 @@ osvers='$osvers'
prefix='$prefix'
builddir='$builddir'
installbin='$installbin'
+installscript='$installscript'
installman1dir='$installman1dir'
installman3dir='$installman3dir'
installprivlib='$installprivlib'
installarchlib='$installarchlib'
+installsitelib='$installsitelib'
+installsitearch='$installsitearch'
EndOfIntro
foreach (@ARGV) {
@@ -146,6 +153,14 @@ foreach (@ARGV) {
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;
}
elsif ($key eq 'exe_ext') {
@@ -246,7 +261,7 @@ while (<IN>) {
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 = lc $token;
$token = "d_$token" unless $token =~ /^i_/;
print OUT "$token='$state'\n";
}
@@ -262,7 +277,7 @@ while (<IN>) {
}
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/;
+ $token = lc $token;
print OUT "$token='$val'\n";
if ($token =~ s/exp$//) {print OUT "$token='$val'\n";}
}
@@ -304,7 +319,7 @@ if (open(PL,"${outdir}patchlevel.h")) {
else { warn "Can't read ${outdir}patchlevel.h - skipping 'PATCHLEVEL'"; }
# simple pager support for perldoc
-if (`most` =~ /IVVERB/) {
+if (`most not..file` =~ /IVVERB/) {
$pager = 'more';
if (`more nl:` =~ /IVVERB/) { $pager = 'type/page'; }
}
diff --git a/vms/genopt.com b/vms/genopt.com
index 70013aec42..53ee6a82b6 100644
--- a/vms/genopt.com
+++ b/vms/genopt.com
@@ -9,6 +9,21 @@ $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)
+$ 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
$ if y .nes. "" then write file y
$ element=element+1
$ goto loop
diff --git a/vms/perlvms.pod b/vms/perlvms.pod
index b7804f0b42..e065b08baa 100644
--- a/vms/perlvms.pod
+++ b/vms/perlvms.pod
@@ -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
@@ -238,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>,
@@ -261,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
@@ -277,6 +292,8 @@ 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
@@ -328,6 +345,7 @@ your copy of Perl:
getsockopt, listen, recv, select(system call)*,
send, setsockopt, shutdown, socket
+=over 4
=item File tests
@@ -596,8 +614,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
@@ -611,7 +638,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>.
@@ -633,6 +660,21 @@ 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.
@@ -675,6 +717,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/vms/perly_c.vms b/vms/perly_c.vms
index c4cbeabcf1..28b84e492f 100644
--- a/vms/perly_c.vms
+++ b/vms/perly_c.vms
@@ -13,1105 +13,1055 @@ 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,
+ 40, 0, 7, 5, 8, 6, 9, 9, 9, 10,
+ 10, 10, 10, 22, 22, 22, 22, 22, 22, 13,
+ 13, 13, 12, 12, 12, 12, 37, 37, 11, 11,
+ 11, 11, 11, 11, 11, 11, 11, 24, 24, 25,
+ 25, 26, 27, 28, 29, 30, 39, 39, 1, 1,
+ 1, 1, 3, 3, 41, 41, 36, 36, 4, 42,
+ 42, 43, 14, 14, 14, 23, 23, 23, 34, 34,
+ 34, 34, 34, 34, 34, 34, 35, 35, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
+ 15, 15, 31, 31, 32, 32, 32, 2, 2, 38,
+ 21, 16, 17, 18, 19, 20, 33, 33, 33, 33,
};
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, 6, 3, 3, 1, 2, 3, 1,
- 3, 5, 6, 3, 5, 2, 4, 4, 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, 4, 4, 0, 2, 8, 8,
+ 5, 5, 10, 9, 8, 11, 3, 0, 1, 0,
+ 1, 1, 1, 1, 1, 1, 0, 1, 1, 1,
+ 1, 1, 4, 3, 5, 5, 0, 1, 0, 3,
+ 2, 6, 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,
- 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,
+ 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, 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, 48, 59, 59, 0, 59, 8, 49,
+ 9, 11, 0, 50, 51, 52, 0, 0, 0, 61,
+ 0, 14, 4, 151, 0, 0, 126, 0, 146, 0,
+ 59, 59, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 158, 159, 0,
+ 0, 0, 0, 0, 0, 0, 0, 12, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 10, 0, 0,
+ 0, 0, 116, 118, 0, 0, 0, 0, 152, 0,
+ 54, 0, 60, 0, 7, 167, 170, 169, 168, 0,
+ 0, 0, 0, 0, 0, 4, 0, 4, 0, 4,
+ 0, 4, 0, 4, 4, 0, 0, 0, 0, 0,
+ 141, 0, 0, 0, 0, 74, 0, 165, 0, 132,
+ 0, 0, 0, 0, 0, 161, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 106, 0, 162, 163,
+ 164, 166, 0, 0, 37, 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, 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, 0, 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, 54, 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, 0, 0, 0, 0, 0, 98, 99, 0, 0,
+ 0, 0, 0, 0, 0, 0, 13, 0, 53, 58,
+ 0, 0, 0, 72, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 4, 145,
+ 147, 0, 0, 0, 0, 0, 0, 0, 108, 0,
+ 130, 0, 0, 105, 28, 0, 0, 19, 0, 0,
+ 0, 63, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 77, 0,
+ 78, 0, 0, 0, 0, 0, 0, 0, 128, 0,
+ 0, 56, 55, 0, 3, 0, 149, 0, 76, 109,
+ 0, 45, 0, 31, 46, 0, 32, 0, 0, 0,
+ 0, 25, 0, 26, 160, 0, 0, 39, 44, 0,
+ 0, 0, 148, 157, 75, 0, 133, 0, 135, 0,
+ 107, 0, 0, 0, 0, 0, 0, 0, 115, 0,
+ 113, 0, 124, 0, 129, 62, 73, 0, 0, 0,
+ 0, 6, 21, 0, 0, 0, 0, 0, 0, 70,
+ 134, 136, 123, 0, 121, 0, 0, 114, 0, 119,
+ 125, 111, 150, 0, 0, 0, 7, 0, 0, 0,
+ 0, 0, 0, 122, 120, 71, 29, 30, 23, 0,
+ 0, 24, 0, 35, 0, 0, 5, 0, 0, 0,
+ 34, 22, 33, 0, 36,
};
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, 17, 85, 337, 88, 313, 3, 11,
+ 12, 68, 272, 268, 70, 71, 72, 73, 74, 75,
+ 76, 278, 78, 279, 262, 265, 269, 281, 263, 266,
+ 116, 204, 90, 79, 242, 181, 145, 276, 13, 2,
+ 14, 15, 16,
};
dEXT short yysindex[] = { 0,
- 0, 0, 303, 0, 0, 0, -53, 0, 0, 0,
- 0, 0, 607, 0, 0, 0, -111, -242, -32, 0,
- -216, 0, 0, 0, 149, 149, 0, 8, 0, 2109,
- 0, 0, -15, -8, 4, 6, 32, 2109, 13, 20,
- 57, 149, 994, 2109, 1057, -206, 149, 2109, 938, 1291,
- 2109, 2109, 2109, 2109, 2109, 1347, 0, 2109, 2109, 1403,
- 149, 149, 149, 149, -203, 0, 68, 664, 491, -67,
- -52, 0, 0, -21, 73, 65, 0, 7, 0, -135,
- 0, -126, 0, 0, 0, 0, 0, 2109, 92, 2109,
- 491, 7, -135, 2109, 7, 2109, 7, 2109, 7, 2109,
- 7, 1466, 101, 491, 112, 1700, 938, 0, 102, 0,
- 1228, -22, 1228, 39, -58, 2109, 0, 68, 0, 68,
- -67, 0, 2109, 0, 1228, 472, 472, 472, -88, -88,
- 78, -10, 472, 472, 0, -85, 0, 0, 0, 0,
- 7, 0, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109,
- 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109, 2109,
- 2109, 2109, 2109, 2109, 0, 0, -29, 2109, 2109, 2109,
- 2109, 2109, 2109, 1756, 0, 0, 0, -46, 2109, 391,
- 0, 2109, -25, 2109, 7, -214, 129, -203, -5, -203,
- 1, -167, 9, -167, 117, 52, 0, 2109, 0, 0,
- 23, 60, 132, 2109, 1812, 1875, 0, 53, 0, 68,
- 2109, 86, 0, 0, 491, -214, -214, -214, -214, -147,
- 0, -54, 382, 1228, 1090, 771, 115, 491, 2942, 1523,
- 314, 1554, 392, 677, 472, 472, 2109, 0, 2109, 0,
- 141, 89, -42, 99, 46, 114, 64, 0, 26, 0,
- 0, 124, 0, 143, 0, 2109, 0, 0, 7, 0,
- 7, 0, 7, 7, 146, 0, 7, 0, 2109, 7,
- 35, 0, 0, 0, 37, 0, 49, 0, 55, 0,
- 130, 2109, 63, 2109, 67, 166, 2109, 0, 66, 0,
- 71, 0, 74, 0, 0, 0, 1170, -203, -203, -167,
- 0, 2109, -167, 131, -203, 7, 0, 0, 0, 0,
- 185, 0, 1119, 76, 0, 161, 0, 0, 0, 0,
- 0, 0, 0, 58, 0, 1466, 0, -203, 0, 0,
- 0, 7, 162, 0, -167, 7, 0, 0,
+ 0, 0, -178, 0, 0, 0, -49, 0, 0, 0,
+ 0, 0, 616, 0, 0, 0, -108, -233, 3, 0,
+ -230, 0, 0, 0, -24, -24, 0, 28, 0, 1899,
+ 0, 0, -17, -12, -11, -10, -35, 1899, 39, 54,
+ 60, 992, 936, -24, 1055, 1319, -217, 0, 0, -24,
+ 1899, 1899, 1899, 1899, 1899, 1899, 1375, 0, 1899, 1899,
+ 1431, -24, -24, -24, -24, 1899, -161, 0, 277, 3829,
+ -69, -42, 0, 0, -4, 88, 89, 97, 0, 24,
+ 0, -107, 0, -105, 0, 0, 0, 0, 0, 1899,
+ 114, 1899, 328, 24, -107, 0, 24, 0, 24, 0,
+ 24, 0, 24, 0, 0, 115, 3829, 133, 1490, 936,
+ 0, 328, 0, -69, 97, 0, 1899, 0, 137, 0,
+ 328, -19, 56, 19, 1899, 0, 97, 98, 98, 98,
+ -82, -82, 93, -21, 98, 98, 0, -87, 0, 0,
+ 0, 0, 328, 24, 0, 1899, 1899, 1899, 1899, 1899,
+ 1899, 1899, 1899, 1899, 1899, 1899, 1899, 1899, 1899, 1899,
+ 1899, 1899, 1899, 1899, 1899, 1899, 0, 0, -32, 1899,
+ 1899, 1899, 1899, 1899, 1899, 1665, 0, 1899, 0, 0,
+ -8, 1899, 357, 0, 1899, 82, 1899, 24, 1899, -161,
+ 1899, -161, 1899, -234, 1899, -234, 144, 1724, 0, 0,
+ 0, 4, 11, 138, 1899, 97, 1780, 1836, 0, 61,
+ 0, 1899, 96, 0, 0, -176, -176, 0, -176, -176,
+ -95, 0, 21, 1092, 328, 373, 434, 92, 3829, 1204,
+ 3238, 3721, 2430, 815, 419, 98, 98, 1899, 0, 1899,
+ 0, 173, -80, 55, -68, 57, -54, 68, 0, 6,
+ 3829, 0, 0, 157, 0, 178, 0, 1899, 0, 0,
+ -176, 0, 181, 0, 0, 183, 0, -176, 190, 112,
+ 209, 0, 231, 0, 0, 210, 277, 0, 0, 237,
+ 224, 1899, 0, 0, 0, 9, 0, 15, 0, 17,
+ 0, 105, 1899, 163, 1899, 81, 119, 1899, 0, 168,
+ 0, 175, 0, 185, 0, 0, 0, 1146, 112, 112,
+ 112, 0, 0, 1899, 112, 1899, 112, 1899, 279, 0,
+ 0, 0, 0, 143, 0, 3863, 202, 0, 300, 0,
+ 0, 0, 0, -161, -161, -234, 0, 321, -234, 326,
+ -161, 309, 112, 0, 0, 0, 0, 0, 0, 398,
+ 112, 0, 112, 0, 1724, -161, 0, -234, -161, 336,
+ 0, 0, 0, 112, 0,
};
dEXT short yyrindex[] = { 0,
- 0, 0, 269, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 220, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 2241, 1964, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 2857, 2901,
+ 0, 0, 0, 0, 0, 0, 0, 2159, 1989, 0,
+ 0, 2799, 2867, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 107, 0, 360, -1, 62, 3027,
- 3078, 0, 0, 2286, 2020, 0, 0, 0, 0, -12,
- 0, 0, 0, 0, 0, 0, 0, 2415, 0, 0,
- 1251, 0, 82, 173, 0, 0, 0, 0, 0, 0,
- 0, 157, 0, 1661, 0, 0, 178, 0, 2150, 0,
- 3927, 3027, 3958, 0, 0, 2415, 0, 2537, 454, 2581,
- 548, 0, 0, 0, 3989, 3384, 3425, 3461, 3122, 3163,
- 2636, 0, 3497, 3533, 0, 0, 0, 0, 0, 0,
- 0, 0, 2680, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 65, 0, -25, 193,
+ 2910, 2954, 0, 0, 2225, 2048, 0, 333, 0, 0,
+ 0, 2, 0, 0, 0, 0, 0, 0, 0, 2284,
+ 0, 0, 3575, 0, 257, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 3017, 0, 0, 348,
+ 0, 3642, 496, 557, 2395, 0, 0, 0, 2111, 0,
+ 3695, 2910, 0, 0, 2284, 0, 2520, 3065, 3103, 3190,
+ 659, 2997, 2563, 0, 3301, 3354, 0, 0, 0, 0,
+ 0, 0, 3741, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 163, 882,
- 0, 178, 0, 2415, 0, 2, 0, 107, 0, 107,
- 0, 175, 0, 175, 0, 165, 0, 0, 0, 0,
- 0, 180, 0, 0, 0, 0, 0, 0, 0, 2723,
- 0, 2985, 0, 0, 2785, 11, 14, 33, 59, 833,
- 0, 0, -30, 4020, 4036, 3817, 3850, 3275, 0, 1611,
- 4179, 4114, 4098, 3894, 3569, 3646, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 2631, 0, 0,
+ 0, 331, 880, 0, 348, 0, 2284, 0, 352, 65,
+ 0, 65, 0, 164, 0, 164, 0, 338, 0, 0,
+ 0, 0, 358, 0, 0, 2674, 0, 0, 0, 0,
+ 0, 0, 2718, 0, 0, -22, 36, 0, 91, 110,
+ -33, 0, 0, 2573, 1267, 1531, 3476, 3521, 3675, 0,
+ -27, 3826, 3794, 1587, -6, 3392, 3440, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 3787, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 134, 0, 0, 0, 0, 0, 0, 359, 0, 0,
+ 0, 0, 0, 0, 0, 0, 155, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 168, 0,
+ 0, 0, 0, 0, 0, 0, 0, 348, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 178, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 107, 107, 175,
- 0, 0, 175, 0, 107, 0, 0, 0, 0, 0,
- 0, 0, 2462, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 190, 0, 107, 0, 0,
- 0, 0, 0, 0, 175, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 349, 0, 0,
+ 0, 0, 0, 0, 0, 1953, 0, 0, 0, 0,
+ 0, 0, 0, 65, 65, 164, 0, 0, 164, 0,
+ 65, 0, 0, 0, 0, 0, 0, 0, 0, 880,
+ 0, 0, 0, 0, 368, 65, 0, 164, 65, 0,
+ 0, 0, 0, 0, 0,
};
dEXT short yygindex[] = { 0,
- 0, 0, 0, 148, -13, 106, 0, 0, 0, -91,
- -184, 452, -11, 4373, 886, 0, 0, 0, 0, 0,
- 234, -62, -173, 460, -20, 0, 0, 174, 0, -131,
- 0, 0, 0, 0,
+ 0, 0, 0, 136, -29, 0, 4145, 680, -78, 0,
+ 0, 0, -193, -13, 3266, 519, 0, 0, 0, 0,
+ 0, 400, 885, 0, 0, 267, -196, 63, 124, 250,
+ -16, -167, 20, 0, 0, 320, 356, 0, 0, 0,
+ 0, 0, 0,
};
-#define YYTABLESIZE 4657
-dEXT short yytable[] = { 65,
- 208, 68, 168, 79, 283, 20, 61, 213, 254, 268,
- 80, 23, 250, 80, 80, 255, 289, 206, 256, 95,
- 97, 99, 101, 170, 94, 181, 81, 80, 80, 110,
- 212, 96, 80, 115, 150, 261, 124, 157, 172, 13,
- 82, 263, 38, 98, 132, 100, 49, 90, 136, 267,
- 116, 16, 105, 209, 17, 169, 260, 13, 262, 106,
- 38, 239, 80, 272, 176, 168, 294, 61, 170, 16,
- 171, 102, 17, 14, 141, 306, 23, 307, 184, 148,
- 149, 188, 186, 190, 189, 192, 191, 194, 193, 308,
- 196, 14, 270, 237, 201, 309, 107, 150, 332, 15,
- 169, 173, 60, 273, 291, 60, 25, 23, 264, 265,
- 49, 143, 174, 316, 23, 323, 252, 15, 325, 60,
- 60, 257, 293, 175, 177, 314, 23, 214, 23, 23,
- 179, 182, 216, 217, 218, 219, 220, 221, 222, 25,
- 198, 205, 25, 25, 25, 78, 25, 149, 25, 25,
- 337, 25, 199, 18, 60, 21, 242, 243, 244, 245,
- 246, 247, 249, 207, 251, 25, 321, 322, 211, 259,
- 25, 258, 274, 327, 18, 269, 282, 280, 92, 93,
- 287, 288, 295, 296, 61, 302, 271, 312, 180, 326,
- 317, 290, 275, 277, 279, 318, 334, 25, 319, 281,
- 330, 331, 336, 19, 49, 168, 292, 18, 148, 149,
- 18, 18, 18, 37, 18, 35, 18, 18, 147, 18,
- 148, 145, 310, 13, 167, 285, 37, 286, 238, 25,
- 35, 25, 25, 18, 333, 148, 149, 150, 18, 148,
- 149, 80, 80, 80, 80, 298, 76, 299, 304, 300,
- 301, 148, 149, 303, 0, 151, 305, 186, 315, 152,
- 153, 154, 155, 80, 80, 18, 185, 80, 2, 0,
- 311, 23, 156, 158, 159, 160, 161, 329, 162, 163,
- 0, 0, 164, 148, 149, 165, 166, 167, 148, 149,
- 324, 0, 328, 0, 148, 149, 0, 18, 0, 18,
- 18, 39, 148, 149, 39, 39, 39, 0, 39, 0,
- 39, 39, 0, 39, 68, 0, 148, 149, 335, 148,
- 149, 0, 338, 144, 145, 146, 147, 39, 148, 149,
- 148, 149, 39, 60, 60, 60, 60, 0, 0, 148,
- 149, 0, 148, 149, 0, 148, 149, 0, 148, 149,
- 0, 148, 149, 148, 149, 60, 60, 148, 149, 39,
- 148, 149, 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, 0, 25, 25,
- 25, 39, 148, 149, 39, 25, 25, 25, 25, 25,
- 57, 154, 25, 25, 168, 84, 0, 148, 149, 25,
- 85, 0, 0, 25, 0, 25, 25, 0, 57, 163,
- 0, 0, 164, 148, 149, 165, 166, 167, 0, 0,
- 18, 18, 18, 18, 18, 18, 150, 18, 18, 18,
- 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
- 0, 0, 57, 18, 18, 0, 18, 18, 18, 148,
- 149, 0, 0, 18, 18, 18, 18, 18, 0, 0,
- 18, 18, 168, 0, 0, 0, 0, 18, 148, 149,
- 0, 18, 168, 18, 18, 89, 156, 0, 0, 156,
- 156, 156, 0, 156, 143, 156, 156, 143, 156, 118,
- 120, 108, 0, 0, 150, 0, 117, 0, 123, 0,
- 0, 143, 143, 0, 150, 253, 143, 156, 0, 0,
- 137, 138, 139, 140, 39, 39, 39, 39, 39, 39,
- 0, 39, 39, 39, 0, 0, 0, 39, 0, 120,
- 39, 39, 39, 39, 143, 0, 143, 39, 39, 0,
- 39, 39, 39, 157, 0, 0, 0, 39, 39, 39,
- 39, 39, 168, 0, 39, 39, 204, 120, 4, 5,
- 6, 39, 7, 8, 210, 39, 143, 39, 39, 156,
- 157, 168, 0, 157, 157, 157, 0, 157, 102, 157,
- 157, 102, 157, 0, 150, 0, 0, 0, 152, 153,
- 154, 155, 0, 0, 0, 102, 102, 0, 0, 0,
- 102, 157, 0, 150, 160, 161, 0, 162, 163, 0,
- 0, 164, 0, 0, 165, 166, 167, 0, 0, 0,
- 120, 57, 57, 57, 57, 120, 0, 0, 0, 51,
- 102, 0, 61, 63, 47, 0, 56, 0, 64, 59,
- 0, 58, 0, 57, 57, 0, 4, 5, 6, 0,
- 7, 8, 0, 0, 0, 57, 152, 153, 154, 155,
- 62, 0, 0, 157, 0, 0, 152, 153, 154, 155,
- 158, 159, 160, 161, 0, 162, 163, 0, 0, 164,
- 0, 0, 165, 166, 167, 162, 163, 60, 0, 164,
- 0, 0, 165, 166, 167, 0, 0, 0, 0, 0,
- 156, 156, 156, 156, 156, 0, 156, 156, 156, 0,
- 0, 0, 156, 0, 0, 143, 143, 143, 143, 23,
- 0, 0, 52, 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, 168, 0, 0,
- 0, 151, 0, 0, 0, 152, 153, 154, 155, 164,
- 0, 0, 165, 166, 167, 0, 0, 0, 156, 158,
- 159, 160, 161, 0, 162, 163, 0, 0, 164, 150,
- 0, 165, 166, 167, 157, 157, 157, 157, 157, 0,
- 157, 157, 157, 0, 0, 0, 157, 0, 0, 102,
- 102, 102, 102, 0, 0, 0, 0, 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, 168, 22, 24, 25, 26, 27, 28, 0, 29,
- 30, 31, 0, 56, 0, 32, 56, 0, 33, 34,
- 35, 36, 0, 0, 0, 37, 38, 0, 39, 40,
- 41, 56, 0, 150, 0, 42, 43, 44, 45, 46,
- 0, 0, 48, 49, 0, 0, 0, 0, 0, 50,
- 87, 87, 0, 53, 39, 54, 55, 39, 39, 39,
- 0, 39, 103, 39, 39, 56, 39, 87, 112, 0,
- 0, 0, 87, 0, 121, 144, 145, 146, 147, 0,
- 39, 0, 0, 0, 0, 39, 87, 87, 87, 87,
- 0, 0, 0, 0, 0, 0, 0, 148, 149, 0,
- 0, 0, 0, 154, 155, 0, 0, 0, 0, 0,
- 51, 0, 39, 61, 63, 47, 0, 56, 0, 64,
- 59, 163, 58, 0, 164, 0, 0, 165, 166, 167,
- 0, 0, 121, 0, 0, 0, 0, 0, 0, 0,
- 0, 62, 0, 0, 39, 0, 0, 39, 0, 0,
- 0, 0, 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, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 240, 0, 0, 0, 0, 62, 0, 0,
- 23, 0, 0, 52, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 163, 0, 0, 164, 0,
- 0, 165, 166, 167, 60, 0, 0, 0, 0, 51,
- 0, 0, 61, 63, 47, 0, 56, 0, 64, 59,
- 0, 58, 0, 0, 56, 56, 56, 56, 0, 0,
- 0, 0, 0, 0, 0, 114, 23, 0, 0, 52,
- 62, 0, 0, 0, 0, 0, 56, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 39, 39, 39,
- 39, 39, 39, 0, 39, 39, 39, 60, 0, 0,
- 39, 0, 0, 39, 39, 39, 39, 0, 0, 0,
- 39, 39, 0, 39, 39, 39, 0, 0, 0, 0,
- 39, 39, 39, 39, 39, 0, 0, 39, 39, 0,
- 168, 157, 52, 0, 39, 0, 0, 0, 39, 0,
- 39, 39, 0, 0, 119, 25, 26, 27, 28, 85,
- 29, 30, 31, 0, 0, 0, 32, 0, 0, 168,
- 320, 0, 150, 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, 0, 0,
- 50, 150, 0, 0, 53, 0, 54, 55, 0, 0,
- 109, 25, 26, 27, 28, 0, 29, 30, 31, 0,
- 168, 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, 135, 150, 0, 135, 0, 50, 0, 0, 0,
- 53, 0, 54, 55, 0, 0, 0, 0, 135, 135,
- 0, 0, 0, 24, 25, 26, 27, 28, 168, 29,
- 30, 31, 0, 51, 0, 32, 61, 63, 47, 0,
- 56, 0, 64, 59, 0, 58, 38, 0, 39, 40,
- 41, 0, 0, 135, 0, 42, 43, 44, 45, 46,
- 150, 0, 48, 49, 62, 0, 0, 0, 0, 50,
- 0, 0, 0, 53, 0, 54, 55, 0, 0, 0,
- 0, 0, 0, 0, 152, 0, 154, 155, 0, 51,
- 0, 60, 61, 63, 47, 0, 56, 131, 64, 59,
- 0, 58, 0, 162, 163, 0, 0, 164, 0, 151,
- 165, 166, 167, 152, 153, 154, 155, 0, 0, 0,
- 62, 0, 0, 23, 0, 0, 52, 158, 159, 160,
- 161, 0, 162, 163, 0, 0, 164, 0, 0, 165,
- 166, 167, 0, 0, 0, 51, 0, 60, 61, 63,
- 47, 0, 56, 0, 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, 0, 0, 0, 0, 0,
- 0, 0, 0, 60, 0, 135, 0, 0, 51, 0,
- 0, 61, 63, 47, 0, 56, 0, 64, 59, 0,
- 58, 0, 0, 0, 154, 155, 0, 0, 0, 0,
- 0, 0, 135, 135, 135, 135, 0, 0, 52, 62,
- 0, 162, 163, 0, 0, 164, 0, 0, 165, 166,
- 167, 0, 0, 0, 135, 135, 0, 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, 0, 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, 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, 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, 130, 0, 82, 130, 50, 0, 0, 0, 53,
- 0, 54, 55, 0, 0, 0, 0, 0, 130, 130,
- 0, 22, 24, 25, 26, 27, 28, 0, 29, 30,
- 31, 0, 51, 0, 32, 61, 63, 47, 0, 56,
- 200, 64, 59, 0, 58, 38, 0, 39, 40, 41,
- 0, 0, 0, 130, 42, 43, 44, 45, 46, 0,
- 0, 48, 49, 62, 0, 0, 0, 0, 50, 0,
- 0, 0, 53, 0, 54, 55, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 51, 0,
- 60, 61, 63, 47, 0, 56, 248, 64, 59, 0,
- 58, 0, 0, 0, 0, 0, 0, 152, 153, 154,
- 155, 0, 0, 0, 0, 0, 0, 0, 0, 62,
- 0, 0, 159, 160, 161, 52, 162, 163, 0, 0,
- 164, 0, 0, 165, 166, 167, 0, 0, 152, 153,
- 154, 155, 0, 0, 51, 0, 60, 61, 63, 47,
- 0, 56, 276, 64, 59, 161, 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, 278, 64, 59, 0, 58,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 130, 130, 130, 130, 0, 52, 62, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 130, 130, 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, 136, 0, 53, 136, 54, 55,
- 0, 0, 24, 25, 26, 27, 28, 0, 29, 30,
- 31, 136, 136, 0, 32, 0, 136, 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, 136, 0, 136, 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, 136, 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, 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, 119, 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, 0, 0,
- 48, 49, 62, 0, 0, 0, 0, 50, 0, 0,
- 0, 53, 0, 54, 55, 0, 0, 0, 0, 0,
- 143, 0, 0, 143, 0, 0, 0, 0, 0, 60,
- 0, 0, 0, 0, 0, 0, 0, 143, 143, 0,
- 0, 0, 143, 0, 0, 0, 0, 0, 0, 0,
+#define YYTABLESIZE 4333
+dEXT short yytable[] = { 69,
+ 62, 280, 274, 62, 105, 214, 183, 64, 170, 20,
+ 64, 62, 299, 90, 23, 15, 90, 256, 18, 213,
+ 208, 172, 96, 82, 301, 64, 84, 98, 100, 102,
+ 90, 90, 124, 15, 83, 90, 18, 83, 303, 125,
+ 152, 270, 271, 134, 283, 91, 305, 138, 174, 320,
+ 252, 83, 83, 171, 284, 321, 83, 322, 240, 64,
+ 57, 83, 117, 118, 27, 90, 189, 92, 191, 126,
+ 193, 172, 195, 184, 197, 198, 42, 210, 108, 294,
+ 173, 139, 140, 141, 142, 319, 83, 4, 5, 6,
+ 238, 7, 8, 109, 42, 202, 203, 27, 23, 110,
+ 27, 27, 27, 171, 27, 23, 27, 27, 211, 27,
+ 23, 23, 23, 300, 23, 302, 144, 338, 175, 340,
+ 150, 151, 257, 27, 57, 258, 304, 176, 27, 205,
+ 329, 16, 216, 217, 219, 220, 221, 222, 223, 327,
+ 178, 18, 349, 21, 159, 352, 23, 177, 80, 16,
+ 17, 182, 180, 185, 199, 27, 243, 244, 245, 246,
+ 247, 248, 250, 20, 362, 254, 94, 95, 17, 282,
+ 259, 203, 170, 200, 41, 261, 207, 217, 285, 62,
+ 209, 217, 170, 212, 277, 291, 293, 27, 170, 27,
+ 27, 286, 41, 288, 290, 43, 20, 323, 292, 20,
+ 20, 20, 151, 20, 152, 20, 20, 19, 20, 150,
+ 151, 328, 298, 15, 152, 306, 150, 151, 307, 2,
+ 152, 309, 20, 310, 296, 239, 297, 20, 150, 151,
+ 311, 169, 86, 68, 312, 344, 68, 87, 64, 64,
+ 64, 64, 150, 151, 90, 90, 90, 90, 314, 316,
+ 68, 68, 47, 90, 20, 47, 47, 47, 350, 47,
+ 104, 47, 47, 64, 47, 83, 83, 83, 83, 90,
+ 90, 315, 90, 90, 83, 150, 151, 317, 47, 324,
+ 83, 83, 318, 47, 203, 68, 20, 325, 20, 20,
+ 83, 83, 330, 83, 83, 83, 83, 83, 83, 331,
+ 150, 151, 150, 151, 261, 150, 151, 150, 151, 332,
+ 47, 150, 151, 150, 151, 150, 151, 150, 151, 343,
+ 27, 27, 27, 27, 27, 27, 345, 27, 27, 27,
+ 27, 27, 27, 27, 27, 27, 27, 27, 27, 27,
+ 346, 69, 47, 27, 27, 47, 27, 27, 27, 27,
+ 27, 150, 151, 150, 151, 27, 27, 27, 27, 27,
+ 27, 351, 153, 27, 150, 151, 353, 355, 154, 155,
+ 156, 157, 27, 65, 27, 27, 364, 150, 151, 57,
+ 156, 158, 160, 161, 162, 163, 164, 165, 155, 153,
+ 166, 65, 40, 167, 168, 169, 38, 165, 156, 43,
+ 166, 150, 151, 167, 168, 169, 166, 40, 38, 167,
+ 168, 169, 77, 218, 188, 150, 151, 360, 170, 20,
+ 20, 20, 20, 20, 20, 65, 20, 20, 20, 20,
+ 20, 20, 20, 20, 20, 20, 20, 20, 20, 150,
+ 151, 342, 20, 20, 273, 20, 20, 20, 20, 20,
+ 152, 0, 0, 0, 20, 20, 20, 20, 20, 20,
+ 0, 0, 20, 170, 68, 68, 68, 68, 0, 0,
+ 0, 20, 0, 20, 20, 47, 47, 47, 47, 47,
+ 47, 255, 47, 47, 47, 0, 0, 0, 47, 68,
+ 68, 47, 47, 47, 47, 152, 0, 0, 47, 47,
+ 0, 47, 47, 47, 47, 47, 0, 0, 0, 170,
+ 47, 47, 47, 47, 47, 47, 0, 0, 47, 0,
+ 0, 0, 357, 0, 170, 0, 0, 47, 167, 47,
+ 47, 167, 167, 167, 0, 167, 151, 167, 167, 151,
+ 167, 152, 0, 89, 89, 264, 0, 267, 146, 147,
+ 148, 149, 0, 151, 151, 106, 152, 0, 151, 167,
+ 0, 114, 89, 122, 0, 0, 0, 0, 89, 0,
+ 0, 0, 0, 150, 151, 0, 0, 0, 0, 0,
+ 89, 89, 89, 89, 0, 0, 151, 0, 151, 168,
+ 0, 0, 168, 168, 168, 0, 168, 110, 168, 168,
+ 110, 168, 0, 0, 65, 65, 65, 65, 0, 0,
+ 0, 0, 0, 0, 110, 110, 156, 157, 151, 110,
+ 168, 167, 4, 5, 6, 0, 7, 8, 114, 65,
+ 65, 0, 164, 165, 0, 0, 166, 0, 0, 167,
+ 168, 169, 0, 0, 0, 0, 0, 0, 52, 110,
+ 0, 62, 64, 50, 0, 57, 0, 65, 60, 154,
+ 59, 156, 157, 4, 5, 6, 0, 7, 8, 0,
+ 0, 0, 0, 0, 58, 0, 0, 164, 165, 63,
+ 0, 166, 168, 0, 167, 168, 169, 241, 0, 347,
+ 348, 0, 0, 0, 0, 0, 354, 0, 0, 100,
+ 0, 0, 100, 0, 0, 0, 61, 156, 157, 0,
+ 0, 361, 0, 0, 363, 275, 100, 100, 0, 0,
+ 0, 100, 0, 0, 165, 0, 0, 166, 0, 0,
+ 167, 168, 169, 0, 0, 0, 0, 0, 23, 165,
+ 0, 53, 166, 0, 0, 167, 168, 169, 0, 0,
+ 0, 100, 167, 167, 167, 167, 167, 0, 167, 167,
+ 167, 0, 0, 0, 167, 0, 0, 151, 151, 151,
+ 151, 0, 0, 0, 0, 167, 151, 167, 167, 167,
+ 167, 167, 151, 151, 151, 151, 167, 167, 167, 167,
+ 167, 167, 151, 151, 167, 151, 151, 151, 151, 151,
+ 151, 151, 0, 167, 151, 167, 167, 151, 151, 151,
+ 0, 0, 0, 168, 168, 168, 168, 168, 0, 168,
+ 168, 168, 0, 0, 0, 168, 0, 0, 110, 110,
+ 110, 110, 0, 0, 0, 0, 168, 110, 168, 168,
+ 168, 168, 168, 110, 110, 110, 110, 168, 168, 168,
+ 168, 168, 168, 110, 110, 168, 110, 110, 110, 110,
+ 110, 110, 110, 0, 168, 110, 168, 168, 110, 110,
+ 110, 22, 24, 25, 26, 27, 28, 0, 29, 30,
+ 31, 0, 0, 0, 32, 0, 0, 33, 34, 35,
+ 36, 0, 0, 0, 37, 38, 0, 39, 40, 41,
+ 42, 43, 0, 0, 0, 170, 44, 45, 46, 47,
+ 48, 49, 47, 0, 51, 47, 47, 47, 0, 47,
+ 0, 47, 47, 54, 47, 55, 56, 115, 0, 0,
+ 100, 100, 100, 100, 0, 127, 0, 152, 47, 100,
+ 0, 0, 0, 47, 0, 100, 100, 100, 100, 0,
+ 0, 0, 0, 0, 0, 100, 100, 0, 100, 100,
+ 100, 100, 100, 100, 100, 0, 0, 100, 52, 0,
+ 47, 62, 64, 50, 115, 57, 0, 65, 60, 0,
+ 59, 0, 0, 0, 0, 0, 0, 0, 334, 335,
+ 336, 0, 0, 0, 339, 0, 341, 0, 0, 63,
+ 0, 206, 47, 0, 0, 47, 0, 0, 0, 115,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 52, 136, 136, 136, 136, 0,
- 143, 0, 143, 0, 136, 0, 0, 0, 136, 136,
- 136, 136, 0, 0, 0, 0, 0, 136, 136, 0,
- 0, 136, 136, 136, 136, 136, 0, 136, 136, 0,
- 0, 136, 143, 0, 136, 136, 136, 0, 0, 0,
- 0, 129, 0, 0, 129, 0, 0, 0, 0, 0,
- 0, 119, 119, 119, 119, 0, 0, 0, 129, 129,
- 119, 0, 0, 129, 119, 119, 119, 119, 0, 0,
- 0, 0, 0, 119, 119, 0, 0, 119, 119, 119,
- 119, 119, 0, 119, 119, 0, 104, 119, 0, 104,
- 119, 119, 119, 129, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 104, 104, 0, 0, 0, 104, 0,
+ 0, 0, 356, 0, 52, 0, 61, 62, 64, 50,
+ 358, 57, 359, 65, 60, 0, 59, 0, 0, 0,
+ 0, 0, 0, 365, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 63, 0, 0, 23, 0,
+ 0, 53, 0, 0, 0, 0, 115, 0, 0, 0,
+ 0, 115, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 61, 0, 0, 0, 0, 52, 0, 0,
+ 62, 64, 50, 0, 57, 0, 65, 60, 0, 59,
+ 0, 154, 155, 156, 157, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 23, 0, 0, 53, 63, 164,
+ 165, 0, 0, 166, 0, 0, 167, 168, 169, 0,
+ 0, 0, 0, 0, 0, 47, 47, 47, 47, 47,
+ 47, 0, 47, 47, 47, 61, 0, 0, 47, 0,
+ 0, 47, 47, 47, 47, 0, 0, 0, 47, 47,
+ 0, 47, 47, 47, 47, 47, 0, 0, 0, 0,
+ 47, 47, 47, 47, 47, 47, 0, 23, 47, 0,
+ 53, 0, 170, 0, 0, 0, 333, 47, 0, 47,
+ 47, 0, 113, 25, 26, 27, 28, 87, 29, 30,
+ 31, 0, 0, 0, 32, 0, 0, 0, 159, 0,
+ 0, 0, 0, 0, 152, 38, 0, 39, 40, 41,
+ 42, 43, 0, 0, 0, 0, 44, 45, 46, 47,
+ 48, 49, 0, 0, 51, 0, 170, 0, 0, 0,
+ 0, 0, 0, 54, 0, 55, 56, 0, 24, 25,
+ 26, 27, 28, 0, 29, 30, 31, 0, 0, 0,
+ 32, 295, 0, 0, 0, 0, 159, 0, 152, 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, 170, 0, 0, 0, 0, 54,
+ 0, 55, 56, 0, 0, 0, 0, 84, 0, 0,
+ 84, 119, 25, 26, 27, 28, 0, 29, 30, 31,
+ 0, 0, 0, 32, 84, 84, 152, 0, 0, 84,
+ 0, 0, 0, 0, 38, 0, 39, 40, 41, 42,
+ 43, 0, 0, 0, 0, 44, 45, 46, 47, 48,
+ 49, 52, 0, 51, 62, 64, 50, 0, 57, 84,
+ 65, 60, 54, 59, 55, 56, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 123, 154, 155,
+ 156, 157, 63, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 160, 161, 162, 163, 164, 165, 0, 0,
+ 166, 0, 0, 167, 168, 169, 0, 52, 0, 61,
+ 62, 64, 50, 0, 57, 133, 65, 60, 0, 59,
+ 0, 0, 0, 0, 0, 0, 153, 0, 0, 0,
+ 0, 0, 154, 155, 156, 157, 0, 0, 63, 0,
+ 0, 0, 0, 0, 53, 158, 160, 161, 162, 163,
+ 164, 165, 0, 0, 166, 0, 0, 167, 168, 169,
+ 0, 0, 0, 52, 0, 61, 62, 64, 50, 0,
+ 57, 0, 65, 60, 0, 59, 0, 0, 0, 0,
+ 0, 0, 0, 0, 153, 0, 0, 0, 0, 0,
+ 154, 155, 156, 157, 63, 0, 0, 0, 0, 0,
+ 53, 0, 0, 158, 160, 161, 162, 163, 164, 165,
+ 0, 0, 166, 0, 0, 167, 168, 169, 0, 0,
+ 0, 61, 52, 137, 0, 62, 64, 50, 0, 57,
+ 201, 65, 60, 0, 59, 0, 0, 0, 84, 84,
+ 84, 84, 0, 0, 0, 0, 0, 84, 0, 0,
+ 0, 0, 0, 63, 84, 0, 53, 0, 0, 0,
+ 0, 0, 0, 84, 84, 0, 84, 84, 84, 84,
+ 84, 85, 0, 0, 85, 24, 25, 26, 27, 28,
+ 61, 29, 30, 31, 0, 0, 0, 32, 85, 85,
+ 0, 0, 0, 85, 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, 85, 0, 0, 54, 86, 55, 56,
+ 86, 24, 25, 26, 27, 28, 0, 29, 30, 31,
+ 0, 0, 0, 32, 86, 86, 0, 0, 0, 86,
+ 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, 86,
+ 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, 249, 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, 85, 85, 85, 85, 0, 0, 0, 0,
+ 0, 85, 52, 0, 61, 62, 64, 50, 0, 57,
+ 287, 65, 60, 0, 59, 0, 0, 85, 85, 0,
+ 85, 85, 85, 85, 85, 0, 0, 0, 0, 0,
+ 0, 0, 0, 63, 0, 0, 0, 0, 0, 53,
+ 0, 0, 0, 0, 0, 0, 0, 0, 86, 86,
+ 86, 86, 0, 0, 0, 0, 0, 86, 52, 0,
+ 61, 62, 64, 50, 0, 57, 289, 65, 60, 0,
+ 59, 0, 0, 86, 86, 0, 86, 86, 86, 86,
+ 86, 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, 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, 0, 0, 53, 0, 54, 55, 0,
- 0, 143, 143, 143, 143, 0, 0, 0, 0, 0,
- 143, 0, 0, 0, 143, 143, 143, 143, 0, 0,
- 0, 0, 0, 143, 143, 0, 0, 143, 143, 143,
- 143, 143, 0, 143, 143, 145, 0, 143, 145, 0,
- 143, 143, 143, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 145, 145, 0, 0, 0, 145, 0, 0,
+ 0, 24, 25, 26, 27, 28, 61, 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, 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, 91, 0, 0, 91, 0, 0, 0,
+ 0, 0, 0, 38, 0, 39, 40, 41, 42, 43,
+ 91, 91, 0, 0, 44, 45, 46, 47, 48, 49,
+ 0, 0, 51, 0, 53, 0, 0, 0, 0, 144,
+ 0, 54, 144, 55, 56, 0, 24, 25, 26, 27,
+ 28, 0, 29, 30, 31, 91, 144, 144, 32, 0,
+ 0, 144, 0, 0, 0, 0, 0, 0, 0, 38,
+ 0, 39, 40, 41, 42, 43, 0, 0, 0, 0,
+ 44, 45, 46, 47, 48, 49, 0, 0, 51, 144,
+ 0, 144, 0, 0, 0, 0, 0, 54, 127, 55,
+ 56, 127, 24, 25, 26, 27, 28, 0, 29, 30,
+ 31, 0, 0, 0, 32, 127, 127, 0, 0, 0,
+ 127, 144, 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, 127, 0,
+ 127, 0, 0, 54, 0, 55, 56, 0, 0, 0,
+ 0, 151, 0, 0, 151, 24, 25, 26, 27, 28,
+ 0, 29, 30, 31, 0, 0, 0, 32, 151, 151,
+ 127, 0, 0, 151, 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, 137,
+ 0, 151, 137, 151, 0, 0, 54, 0, 55, 56,
+ 0, 0, 0, 0, 0, 0, 137, 137, 0, 0,
+ 0, 137, 0, 0, 91, 91, 91, 91, 0, 0,
+ 0, 0, 0, 151, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 91,
+ 91, 137, 91, 0, 0, 0, 0, 0, 0, 0,
+ 144, 144, 144, 144, 0, 112, 0, 0, 112, 144,
+ 0, 0, 0, 0, 0, 144, 144, 144, 144, 0,
+ 0, 137, 112, 112, 0, 144, 144, 112, 144, 144,
+ 144, 144, 144, 144, 144, 0, 0, 144, 0, 0,
+ 144, 144, 144, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 112, 0, 112, 0, 127,
+ 127, 127, 127, 0, 153, 0, 0, 153, 127, 0,
+ 0, 0, 0, 0, 127, 127, 127, 127, 0, 0,
+ 0, 153, 153, 0, 127, 127, 153, 127, 127, 127,
+ 127, 127, 127, 127, 0, 0, 127, 0, 0, 127,
+ 127, 127, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 153, 0, 0, 0,
+ 0, 0, 151, 151, 151, 151, 0, 0, 0, 0,
+ 0, 151, 0, 0, 0, 0, 0, 151, 151, 151,
+ 151, 0, 0, 0, 0, 0, 153, 151, 151, 0,
+ 151, 151, 151, 151, 151, 151, 151, 0, 0, 151,
+ 0, 0, 151, 151, 151, 0, 0, 0, 0, 0,
+ 137, 137, 137, 137, 0, 154, 0, 0, 0, 137,
+ 0, 0, 0, 0, 0, 137, 137, 137, 137, 0,
+ 0, 0, 154, 154, 0, 137, 137, 154, 137, 137,
+ 137, 137, 137, 137, 137, 0, 0, 137, 0, 0,
+ 137, 137, 137, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 154, 0, 154, 0, 0,
+ 0, 0, 0, 0, 0, 0, 112, 112, 112, 112,
+ 0, 0, 0, 0, 0, 112, 0, 0, 0, 0,
+ 0, 112, 112, 112, 112, 0, 0, 154, 0, 0,
+ 170, 112, 112, 0, 112, 112, 112, 112, 112, 112,
+ 112, 0, 0, 112, 0, 0, 112, 112, 112, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 152, 0, 0, 153, 153, 153, 153, 0,
+ 139, 0, 0, 0, 153, 0, 0, 0, 0, 0,
+ 153, 153, 153, 153, 0, 0, 0, 139, 139, 0,
+ 153, 153, 139, 153, 153, 153, 153, 153, 153, 153,
+ 0, 0, 153, 0, 0, 153, 153, 153, 0, 0,
+ 0, 0, 0, 104, 0, 0, 104, 0, 0, 0,
+ 139, 0, 139, 88, 0, 0, 88, 0, 0, 0,
+ 104, 104, 0, 0, 0, 104, 0, 0, 0, 0,
+ 88, 88, 0, 0, 0, 88, 0, 0, 0, 0,
+ 0, 0, 139, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 104, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 88, 154, 154, 154, 154,
+ 0, 66, 0, 0, 66, 154, 0, 0, 0, 0,
+ 0, 154, 154, 154, 154, 104, 0, 0, 66, 66,
+ 0, 154, 154, 66, 154, 154, 154, 154, 154, 154,
+ 154, 0, 0, 154, 0, 0, 154, 154, 154, 0,
+ 0, 0, 0, 0, 69, 0, 154, 155, 156, 157,
+ 0, 0, 0, 66, 0, 0, 0, 0, 0, 0,
+ 0, 69, 69, 163, 164, 165, 69, 0, 166, 0,
+ 0, 167, 168, 169, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 66, 0, 0, 0, 0, 103, 0,
+ 0, 103, 0, 0, 69, 0, 69, 0, 0, 0,
+ 0, 0, 0, 0, 0, 103, 103, 0, 0, 0,
+ 103, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 139, 139, 139, 139, 0, 69, 0, 0, 0,
+ 139, 0, 0, 0, 0, 0, 139, 139, 139, 139,
+ 103, 0, 0, 0, 0, 0, 139, 139, 0, 139,
+ 139, 139, 139, 139, 139, 139, 0, 0, 139, 0,
+ 0, 139, 139, 139, 104, 104, 104, 104, 0, 140,
+ 103, 0, 140, 104, 88, 88, 88, 88, 0, 104,
+ 104, 104, 104, 0, 0, 0, 140, 140, 0, 104,
+ 104, 140, 104, 104, 104, 104, 104, 104, 104, 88,
+ 88, 104, 88, 0, 104, 104, 104, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 83, 0, 0, 83, 0, 145, 0, 0,
- 0, 0, 129, 129, 129, 129, 0, 0, 0, 83,
- 83, 129, 0, 0, 0, 129, 129, 129, 129, 0,
- 0, 0, 0, 0, 129, 129, 0, 145, 129, 129,
- 129, 129, 129, 0, 129, 129, 0, 0, 129, 0,
- 0, 129, 129, 129, 83, 0, 0, 104, 104, 104,
- 104, 0, 0, 0, 0, 0, 104, 0, 0, 0,
- 104, 104, 104, 104, 0, 0, 0, 131, 0, 104,
- 104, 0, 0, 104, 104, 104, 104, 104, 0, 104,
- 104, 0, 0, 104, 131, 131, 104, 104, 104, 131,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 146, 0, 0, 0, 0, 0, 131, 0, 131,
- 0, 0, 0, 0, 0, 0, 0, 0, 146, 146,
- 0, 0, 0, 146, 0, 0, 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, 146, 0, 146, 0, 0, 96, 0, 0, 96,
- 0, 0, 0, 0, 0, 0, 145, 145, 145, 145,
- 0, 0, 0, 96, 96, 145, 0, 0, 96, 145,
- 145, 145, 145, 146, 0, 0, 0, 0, 145, 145,
- 0, 0, 145, 145, 145, 145, 145, 0, 145, 145,
- 58, 0, 145, 58, 0, 145, 145, 145, 96, 0,
- 0, 0, 0, 83, 83, 83, 83, 58, 58, 0,
- 0, 0, 58, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 83, 83, 0, 96, 83,
- 0, 0, 0, 61, 0, 0, 0, 0, 0, 0,
- 0, 0, 58, 0, 0, 0, 0, 0, 0, 0,
- 61, 61, 0, 0, 0, 61, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 58, 0, 0, 0, 0, 0, 131, 131,
- 131, 131, 0, 61, 0, 61, 0, 131, 0, 0,
- 0, 131, 131, 131, 131, 59, 0, 0, 59, 0,
- 131, 131, 0, 0, 131, 131, 131, 131, 131, 0,
- 131, 131, 59, 59, 131, 61, 0, 131, 131, 131,
- 0, 0, 146, 146, 146, 146, 0, 0, 0, 0,
- 0, 146, 0, 0, 0, 146, 146, 146, 146, 0,
- 0, 0, 0, 0, 146, 146, 0, 59, 146, 146,
- 146, 146, 146, 0, 146, 146, 0, 0, 146, 0,
- 0, 146, 146, 146, 0, 0, 0, 145, 0, 0,
- 145, 0, 0, 0, 0, 0, 0, 96, 96, 96,
- 96, 0, 0, 0, 145, 145, 96, 0, 0, 145,
- 96, 96, 96, 96, 0, 0, 0, 0, 0, 96,
- 96, 0, 0, 96, 96, 96, 96, 96, 0, 96,
- 96, 132, 0, 96, 132, 0, 96, 96, 96, 145,
- 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, 61, 61, 61, 61, 0, 284,
- 0, 0, 0, 61, 157, 0, 0, 61, 61, 61,
- 61, 0, 0, 0, 0, 0, 61, 61, 0, 0,
- 61, 61, 61, 61, 61, 95, 61, 61, 95, 0,
- 61, 0, 168, 61, 61, 61, 0, 0, 0, 0,
+ 0, 140, 0, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 66, 66, 66, 66, 0, 153, 0, 0,
+ 153, 66, 0, 0, 0, 0, 0, 66, 66, 66,
+ 66, 0, 0, 0, 153, 153, 0, 66, 66, 153,
+ 66, 66, 66, 66, 66, 66, 66, 0, 0, 66,
+ 0, 0, 66, 66, 66, 69, 69, 69, 69, 0,
+ 110, 0, 0, 110, 69, 0, 0, 0, 0, 153,
+ 69, 69, 69, 69, 0, 0, 0, 110, 110, 0,
+ 69, 69, 110, 69, 69, 69, 69, 69, 69, 69,
+ 0, 0, 69, 0, 0, 69, 69, 69, 0, 103,
+ 103, 103, 103, 0, 117, 0, 0, 117, 103, 0,
+ 0, 0, 110, 0, 103, 103, 103, 103, 0, 0,
+ 0, 117, 117, 0, 103, 103, 117, 103, 103, 103,
+ 103, 103, 103, 103, 0, 0, 103, 0, 0, 103,
+ 103, 103, 0, 0, 0, 0, 0, 101, 0, 0,
+ 101, 0, 0, 0, 0, 0, 117, 0, 0, 0,
+ 0, 0, 0, 0, 101, 101, 0, 138, 0, 101,
+ 138, 0, 0, 0, 0, 0, 0, 0, 0, 0,
+ 140, 140, 140, 140, 138, 138, 0, 0, 0, 140,
+ 0, 0, 0, 0, 0, 140, 140, 140, 140, 101,
+ 0, 0, 0, 0, 0, 140, 140, 0, 140, 140,
+ 140, 140, 140, 140, 140, 95, 0, 140, 95, 138,
+ 140, 140, 140, 0, 0, 0, 0, 0, 0, 0,
0, 0, 95, 95, 0, 0, 0, 95, 0, 0,
- 0, 0, 0, 0, 0, 0, 59, 59, 59, 59,
- 0, 0, 0, 0, 150, 0, 0, 102, 0, 0,
- 102, 0, 0, 0, 0, 0, 0, 95, 59, 59,
- 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, 95, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 109, 102,
- 0, 109, 0, 0, 0, 0, 0, 0, 145, 145,
- 145, 145, 0, 0, 0, 109, 109, 145, 0, 0,
- 109, 145, 145, 145, 145, 0, 0, 0, 0, 0,
- 145, 145, 0, 0, 145, 145, 145, 145, 145, 0,
- 145, 145, 92, 0, 145, 92, 0, 145, 145, 145,
- 109, 0, 132, 132, 132, 132, 0, 0, 0, 92,
- 92, 132, 0, 0, 92, 132, 132, 132, 132, 0,
- 0, 0, 0, 0, 132, 132, 0, 0, 132, 132,
- 132, 132, 132, 93, 132, 132, 93, 0, 132, 0,
- 0, 132, 132, 132, 92, 0, 0, 0, 0, 0,
- 93, 93, 151, 0, 0, 93, 152, 153, 154, 155,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 156,
- 158, 159, 160, 161, 0, 162, 163, 0, 0, 164,
- 0, 0, 165, 166, 167, 93, 95, 95, 95, 95,
- 0, 0, 0, 0, 0, 95, 0, 0, 0, 95,
- 95, 95, 95, 0, 0, 0, 0, 0, 95, 95,
- 0, 0, 95, 95, 95, 95, 95, 0, 95, 95,
- 0, 0, 95, 0, 0, 95, 95, 95, 102, 102,
- 102, 102, 0, 0, 0, 0, 0, 102, 0, 0,
- 0, 102, 102, 102, 102, 71, 0, 0, 71, 0,
- 102, 102, 0, 0, 102, 102, 102, 102, 102, 0,
- 102, 102, 71, 71, 102, 0, 0, 102, 102, 102,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 109,
- 109, 109, 109, 0, 0, 0, 0, 0, 109, 0,
- 0, 0, 109, 109, 109, 109, 0, 71, 0, 0,
- 0, 109, 109, 0, 0, 109, 109, 109, 109, 109,
- 0, 109, 109, 0, 0, 109, 0, 0, 109, 109,
- 109, 0, 0, 92, 92, 92, 92, 0, 0, 0,
- 0, 0, 92, 0, 0, 0, 92, 92, 92, 92,
- 0, 0, 0, 0, 0, 92, 92, 0, 0, 92,
- 92, 92, 92, 92, 87, 92, 92, 87, 0, 92,
- 0, 0, 0, 0, 93, 93, 93, 93, 0, 0,
- 0, 87, 87, 93, 0, 0, 87, 93, 93, 93,
- 93, 0, 0, 0, 0, 0, 93, 93, 0, 0,
- 93, 93, 93, 93, 93, 88, 93, 93, 88, 0,
- 93, 0, 0, 0, 0, 0, 87, 0, 0, 0,
- 0, 0, 88, 88, 0, 0, 0, 88, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 89, 0, 0, 89, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 88, 89, 89,
- 0, 0, 0, 89, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 85, 0, 0,
- 85, 0, 0, 0, 0, 0, 71, 71, 71, 71,
- 0, 0, 0, 89, 85, 85, 0, 0, 0, 85,
- 0, 0, 0, 0, 0, 0, 0, 0, 71, 71,
- 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, 84,
- 0, 0, 84, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 86, 84, 84, 0, 0,
- 0, 84, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 87, 87, 87, 87, 0,
- 0, 84, 0, 0, 87, 0, 0, 0, 87, 87,
- 87, 87, 0, 0, 0, 0, 0, 87, 87, 0,
- 0, 87, 87, 87, 87, 87, 72, 87, 87, 72,
- 0, 0, 0, 0, 0, 0, 88, 88, 88, 88,
- 0, 0, 0, 72, 72, 88, 0, 0, 72, 88,
- 88, 88, 88, 0, 0, 0, 0, 0, 88, 88,
- 0, 0, 88, 88, 88, 88, 88, 0, 88, 88,
- 0, 0, 89, 89, 89, 89, 0, 0, 72, 0,
- 0, 89, 0, 0, 0, 89, 89, 89, 89, 0,
- 0, 0, 0, 0, 89, 89, 0, 0, 89, 89,
- 89, 89, 89, 0, 89, 89, 0, 0, 85, 85,
- 85, 85, 0, 0, 0, 0, 0, 85, 0, 0,
- 0, 85, 85, 85, 85, 0, 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, 0, 0, 0, 0, 0, 86, 86, 0, 0,
- 86, 86, 86, 86, 86, 0, 86, 86, 0, 0,
- 84, 84, 84, 84, 0, 0, 0, 0, 0, 84,
- 0, 0, 0, 84, 84, 84, 84, 73, 0, 0,
- 73, 0, 84, 84, 0, 0, 84, 84, 84, 84,
- 84, 0, 84, 84, 73, 73, 0, 0, 0, 73,
+ 0, 0, 0, 0, 0, 0, 0, 0, 153, 153,
+ 153, 153, 0, 96, 0, 0, 96, 153, 0, 0,
+ 0, 0, 0, 153, 153, 153, 153, 95, 0, 0,
+ 96, 96, 0, 153, 153, 96, 153, 153, 153, 153,
+ 153, 153, 153, 0, 0, 153, 0, 0, 153, 153,
+ 153, 110, 110, 110, 110, 0, 0, 0, 0, 0,
+ 110, 0, 0, 0, 0, 96, 110, 110, 110, 110,
+ 0, 0, 0, 0, 0, 0, 110, 110, 0, 110,
+ 110, 110, 110, 110, 110, 110, 0, 0, 110, 0,
+ 0, 110, 110, 110, 0, 117, 117, 117, 117, 0,
+ 97, 0, 0, 97, 117, 0, 0, 0, 0, 0,
+ 117, 117, 117, 117, 0, 0, 0, 97, 97, 0,
+ 117, 117, 97, 117, 117, 117, 117, 117, 117, 117,
+ 0, 0, 117, 0, 0, 117, 117, 117, 101, 101,
+ 101, 101, 0, 0, 0, 0, 0, 101, 0, 0,
+ 0, 0, 97, 101, 101, 101, 101, 0, 138, 138,
+ 138, 138, 0, 101, 101, 93, 101, 101, 101, 101,
+ 101, 101, 101, 107, 0, 101, 0, 112, 0, 0,
+ 121, 0, 0, 138, 138, 0, 0, 128, 129, 130,
+ 131, 132, 0, 0, 135, 136, 0, 0, 170, 0,
+ 0, 143, 0, 0, 0, 0, 95, 95, 95, 95,
+ 0, 93, 0, 0, 93, 95, 0, 0, 0, 0,
+ 0, 95, 95, 95, 95, 0, 0, 186, 93, 93,
+ 152, 95, 95, 93, 95, 95, 95, 95, 95, 95,
+ 95, 0, 0, 0, 96, 96, 96, 96, 0, 0,
+ 0, 0, 0, 96, 0, 0, 0, 0, 0, 96,
+ 96, 96, 96, 93, 94, 0, 0, 94, 0, 96,
+ 96, 0, 96, 96, 96, 96, 96, 96, 96, 0,
+ 0, 94, 94, 0, 0, 0, 94, 0, 224, 225,
+ 226, 227, 228, 229, 230, 231, 232, 233, 234, 235,
+ 236, 237, 92, 0, 0, 92, 0, 0, 0, 0,
+ 0, 0, 0, 251, 0, 0, 94, 0, 0, 92,
+ 92, 0, 0, 0, 92, 0, 0, 0, 0, 0,
+ 0, 97, 97, 97, 97, 0, 0, 0, 0, 0,
+ 97, 0, 0, 0, 0, 0, 97, 97, 97, 97,
+ 80, 0, 0, 80, 92, 0, 97, 97, 0, 97,
+ 97, 97, 97, 97, 97, 97, 0, 80, 80, 0,
+ 0, 0, 80, 0, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 81, 0, 0, 81,
+ 0, 0, 0, 308, 154, 155, 156, 157, 0, 0,
+ 0, 0, 80, 81, 81, 0, 0, 0, 81, 161,
+ 162, 163, 164, 165, 0, 0, 166, 0, 0, 167,
+ 168, 169, 0, 0, 0, 0, 0, 0, 0, 0,
+ 326, 82, 0, 0, 82, 0, 0, 0, 81, 0,
+ 0, 0, 93, 93, 93, 93, 0, 0, 82, 82,
+ 0, 93, 0, 82, 0, 0, 0, 93, 93, 93,
+ 93, 0, 0, 0, 0, 0, 0, 93, 93, 0,
+ 93, 93, 93, 93, 93, 93, 93, 0, 0, 0,
+ 0, 0, 0, 82, 0, 143, 0, 0, 143, 0,
+ 0, 0, 0, 0, 0, 94, 94, 94, 94, 0,
+ 0, 0, 143, 143, 94, 0, 0, 143, 0, 0,
+ 94, 94, 94, 94, 0, 0, 0, 0, 0, 0,
+ 94, 94, 0, 94, 94, 94, 94, 94, 94, 94,
+ 0, 0, 0, 92, 92, 92, 92, 143, 0, 0,
+ 0, 0, 92, 0, 0, 0, 0, 0, 92, 92,
+ 92, 92, 142, 0, 0, 142, 0, 0, 92, 92,
+ 0, 92, 92, 92, 92, 92, 92, 92, 0, 142,
+ 142, 0, 0, 0, 142, 0, 0, 0, 0, 0,
+ 0, 80, 80, 80, 80, 79, 0, 0, 79, 0,
+ 80, 0, 0, 0, 0, 0, 80, 80, 80, 80,
+ 0, 0, 79, 79, 142, 131, 80, 80, 131, 80,
+ 80, 80, 80, 80, 80, 80, 0, 81, 81, 81,
+ 81, 0, 131, 131, 0, 0, 81, 131, 0, 0,
+ 0, 0, 81, 81, 81, 81, 0, 79, 0, 0,
+ 0, 0, 81, 81, 0, 81, 81, 81, 81, 81,
+ 81, 102, 0, 0, 102, 0, 0, 131, 0, 0,
+ 0, 0, 82, 82, 82, 82, 0, 0, 102, 102,
+ 0, 82, 0, 102, 0, 0, 0, 82, 82, 0,
+ 82, 170, 0, 0, 0, 0, 0, 82, 82, 0,
+ 82, 82, 82, 82, 82, 82, 0, 67, 0, 0,
+ 67, 0, 0, 102, 87, 0, 0, 87, 0, 0,
+ 0, 0, 0, 152, 67, 67, 143, 143, 143, 143,
+ 0, 87, 87, 0, 0, 143, 87, 0, 0, 0,
+ 0, 143, 143, 0, 0, 0, 89, 0, 0, 89,
+ 0, 143, 143, 0, 143, 143, 143, 143, 143, 67,
+ 0, 0, 0, 89, 89, 0, 87, 0, 89, 0,
+ 0, 159, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 74, 0, 0, 74, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 74, 74, 73,
- 0, 0, 74, 0, 0, 0, 0, 72, 72, 72,
- 72, 0, 0, 0, 0, 0, 72, 0, 0, 0,
- 72, 72, 72, 72, 75, 0, 0, 75, 0, 72,
- 72, 0, 74, 72, 72, 72, 72, 72, 0, 72,
- 72, 75, 75, 0, 0, 0, 75, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 123, 0, 0,
- 123, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 123, 123, 75, 0, 0, 123,
- 0, 0, 0, 0, 0, 0, 0, 0, 94, 0,
- 0, 94, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 94, 94, 0, 0, 123,
- 94, 0, 0, 0, 0, 0, 0, 0, 0, 134,
- 0, 0, 134, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 134, 134, 0, 0,
- 94, 134, 0, 0, 0, 0, 0, 0, 0, 0,
- 76, 0, 0, 76, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 77, 76, 76, 77,
- 0, 134, 76, 0, 0, 0, 0, 0, 73, 73,
- 73, 73, 0, 77, 77, 0, 0, 73, 77, 0,
- 0, 73, 73, 73, 73, 0, 0, 0, 0, 0,
- 73, 73, 76, 0, 73, 73, 73, 73, 73, 0,
- 73, 74, 74, 74, 74, 0, 0, 0, 77, 0,
- 74, 0, 0, 0, 74, 74, 0, 74, 78, 0,
- 0, 78, 0, 74, 74, 0, 0, 74, 74, 74,
- 74, 74, 0, 74, 79, 78, 78, 79, 0, 0,
- 78, 0, 0, 0, 0, 75, 75, 75, 75, 0,
- 0, 79, 79, 0, 75, 0, 79, 0, 75, 75,
- 0, 0, 0, 0, 0, 0, 0, 75, 75, 0,
- 78, 75, 75, 75, 75, 75, 0, 75, 123, 123,
- 123, 123, 0, 0, 0, 0, 79, 123, 0, 0,
- 0, 123, 123, 0, 0, 0, 0, 0, 0, 81,
- 123, 123, 81, 0, 123, 123, 123, 123, 123, 94,
- 94, 94, 94, 0, 0, 0, 81, 81, 94, 0,
- 0, 81, 94, 94, 0, 0, 0, 0, 0, 0,
- 0, 94, 94, 0, 0, 94, 94, 94, 94, 94,
- 134, 134, 134, 134, 0, 0, 0, 0, 0, 134,
- 0, 81, 0, 134, 134, 0, 0, 0, 0, 0,
- 0, 0, 134, 134, 0, 0, 134, 134, 134, 134,
- 134, 76, 76, 76, 76, 0, 0, 0, 0, 0,
- 76, 0, 0, 0, 0, 76, 0, 77, 77, 77,
- 77, 0, 0, 76, 76, 0, 77, 76, 76, 76,
- 76, 76, 0, 0, 0, 0, 0, 0, 0, 77,
- 77, 0, 0, 77, 77, 77, 77, 77, 0, 0,
+ 0, 0, 0, 142, 142, 142, 142, 0, 89, 170,
+ 0, 0, 142, 0, 0, 159, 0, 0, 142, 142,
+ 0, 0, 0, 0, 0, 0, 0, 0, 142, 142,
+ 0, 142, 142, 142, 142, 142, 79, 79, 79, 79,
+ 0, 152, 0, 170, 0, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 131, 131, 131, 131,
+ 0, 79, 79, 0, 0, 131, 0, 0, 0, 0,
+ 0, 131, 131, 0, 0, 152, 0, 0, 0, 0,
+ 0, 131, 131, 0, 131, 131, 131, 131, 131, 0,
+ 0, 0, 0, 0, 0, 0, 0, 154, 155, 156,
+ 157, 0, 102, 102, 102, 102, 0, 0, 0, 0,
+ 0, 102, 0, 162, 163, 164, 165, 102, 102, 166,
+ 0, 0, 167, 168, 169, 0, 0, 102, 102, 0,
+ 102, 102, 102, 102, 102, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 67, 67,
+ 67, 67, 0, 0, 0, 87, 87, 87, 87, 0,
+ 0, 0, 0, 0, 87, 0, 0, 0, 0, 0,
+ 0, 0, 0, 67, 67, 0, 0, 0, 0, 0,
+ 87, 87, 0, 87, 87, 87, 87, 89, 89, 89,
+ 89, 0, 0, 0, 0, 0, 89, 0, 0, 153,
+ 0, 0, 0, 0, 0, 154, 155, 156, 157, 0,
+ 0, 0, 89, 89, 0, 89, 89, 89, 158, 160,
+ 161, 162, 163, 164, 165, 0, 0, 166, 0, 0,
+ 167, 168, 169, 153, 0, 0, 0, 0, 0, 154,
+ 155, 156, 157, 0, 0, 0, 0, 67, 0, 0,
+ 0, 81, 0, 160, 161, 162, 163, 164, 165, 0,
+ 0, 166, 0, 0, 167, 168, 169, 97, 99, 101,
+ 103, 0, 0, 0, 0, 0, 111, 0, 0, 120,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 78,
- 78, 78, 78, 0, 0, 0, 0, 0, 78, 0,
- 0, 0, 0, 0, 0, 79, 79, 79, 79, 0,
- 0, 78, 78, 0, 79, 78, 78, 78, 78, 78,
- 0, 0, 91, 0, 0, 0, 0, 79, 79, 0,
- 104, 79, 79, 79, 79, 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,
- 81, 81, 81, 81, 0, 0, 0, 0, 0, 81,
- 0, 0, 183, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 81, 81, 0, 0, 81, 81, 81, 0,
+ 0, 0, 0, 0, 179, 0, 0, 0, 0, 0,
+ 0, 0, 0, 0, 0, 0, 0, 0, 187, 0,
+ 0, 190, 0, 192, 0, 194, 0, 196, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 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, 215, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 297, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 313,
+ 0, 0, 0, 0, 0, 253, 0, 0, 0, 0,
+ 0, 0, 260,
};
dEXT short yycheck[] = { 13,
- 59, 13, 91, 17, 59, 59, 36, 93, 182, 194,
- 41, 123, 59, 44, 257, 41, 59, 40, 44, 33,
- 34, 35, 36, 91, 40, 88, 59, 58, 59, 43,
- 41, 40, 63, 45, 123, 41, 50, 63, 91, 41,
- 257, 41, 41, 40, 56, 40, 59, 40, 60, 41,
- 257, 41, 40, 116, 41, 123, 188, 59, 190, 40,
- 59, 91, 93, 41, 78, 91, 41, 36, 91, 59,
- 123, 40, 59, 41, 278, 41, 123, 41, 92, 294,
- 295, 95, 94, 97, 96, 99, 98, 101, 100, 41,
- 102, 59, 41, 123, 106, 41, 40, 123, 41, 41,
- 123, 123, 41, 44, 59, 44, 0, 123, 276, 277,
- 123, 44, 40, 287, 123, 300, 179, 59, 303, 58,
- 59, 184, 59, 59, 260, 59, 123, 141, 123, 123,
- 257, 40, 144, 145, 146, 147, 148, 149, 150, 33,
- 40, 40, 36, 37, 38, 257, 40, 295, 42, 43,
- 335, 45, 41, 6, 93, 8, 168, 169, 170, 171,
- 172, 173, 174, 125, 178, 59, 298, 299, 91, 41,
- 64, 185, 41, 305, 0, 59, 91, 125, 31, 32,
- 40, 93, 59, 41, 36, 40, 198, 125, 83, 59,
- 125, 93, 204, 205, 206, 125, 328, 91, 125, 211,
- 125, 41, 41, 257, 123, 91, 93, 33, 294, 295,
- 36, 37, 38, 41, 40, 59, 42, 43, 41, 45,
- 41, 59, 93, 59, 313, 237, 59, 239, 258, 123,
- 41, 125, 126, 59, 326, 294, 295, 123, 64, 294,
- 295, 272, 273, 274, 275, 259, 13, 261, 269, 263,
- 264, 294, 295, 267, -1, 281, 270, 269, 93, 285,
- 286, 287, 288, 294, 295, 91, 93, 298, 0, -1,
- 282, 123, 298, 299, 300, 301, 302, 93, 304, 305,
- -1, -1, 308, 294, 295, 311, 312, 313, 294, 295,
- 302, -1, 306, -1, 294, 295, -1, 123, -1, 125,
- 126, 33, 294, 295, 36, 37, 38, -1, 40, -1,
- 42, 43, -1, 45, 326, -1, 294, 295, 332, 294,
- 295, -1, 336, 272, 273, 274, 275, 59, 294, 295,
- 294, 295, 64, 272, 273, 274, 275, -1, -1, 294,
- 295, -1, 294, 295, -1, 294, 295, -1, 294, 295,
- -1, 294, 295, 294, 295, 294, 295, 294, 295, 91,
- 294, 295, 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, 123, 294, 295, 126, 289, 290, 291, 292, 293,
- 41, 287, 296, 297, 91, 257, -1, 294, 295, 303,
- 262, -1, -1, 307, -1, 309, 310, -1, 59, 305,
- -1, -1, 308, 294, 295, 311, 312, 313, -1, -1,
- 256, 257, 258, 259, 260, 261, 123, 263, 264, 265,
+ 36, 198, 196, 36, 40, 93, 85, 41, 91, 59,
+ 44, 36, 93, 41, 123, 41, 44, 185, 41, 41,
+ 40, 91, 40, 257, 93, 59, 257, 40, 40, 40,
+ 58, 59, 46, 59, 41, 63, 59, 44, 93, 257,
+ 123, 276, 277, 57, 41, 26, 41, 61, 91, 41,
+ 59, 58, 59, 123, 44, 41, 63, 41, 91, 93,
+ 59, 59, 43, 44, 0, 93, 96, 40, 98, 50,
+ 100, 91, 102, 90, 104, 105, 41, 59, 40, 59,
+ 123, 62, 63, 64, 65, 282, 93, 266, 267, 268,
+ 123, 270, 271, 40, 59, 109, 110, 33, 123, 40,
+ 36, 37, 38, 123, 40, 123, 42, 43, 125, 45,
+ 123, 123, 123, 59, 123, 59, 278, 314, 123, 316,
+ 297, 298, 41, 59, 123, 44, 59, 40, 64, 110,
+ 298, 41, 146, 147, 148, 149, 150, 151, 152, 59,
+ 44, 6, 336, 8, 63, 339, 123, 59, 257, 59,
+ 41, 257, 260, 40, 40, 91, 170, 171, 172, 173,
+ 174, 175, 176, 0, 358, 182, 31, 32, 59, 199,
+ 187, 185, 91, 41, 41, 189, 40, 191, 41, 36,
+ 125, 195, 91, 91, 198, 125, 91, 123, 91, 125,
+ 126, 205, 59, 207, 208, 41, 33, 93, 212, 36,
+ 37, 38, 298, 40, 123, 42, 43, 257, 45, 297,
+ 298, 93, 40, 59, 123, 59, 297, 298, 41, 0,
+ 123, 41, 59, 41, 238, 258, 240, 64, 297, 298,
+ 41, 314, 257, 41, 123, 93, 44, 262, 272, 273,
+ 274, 275, 297, 298, 272, 273, 274, 275, 40, 40,
+ 58, 59, 33, 281, 91, 36, 37, 38, 337, 40,
+ 296, 42, 43, 297, 45, 272, 273, 274, 275, 297,
+ 298, 41, 300, 301, 281, 297, 298, 41, 59, 293,
+ 287, 288, 59, 64, 298, 93, 123, 125, 125, 126,
+ 297, 298, 125, 300, 301, 302, 303, 304, 305, 125,
+ 297, 298, 297, 298, 318, 297, 298, 297, 298, 125,
+ 91, 297, 298, 297, 298, 297, 298, 297, 298, 41,
+ 256, 257, 258, 259, 260, 261, 125, 263, 264, 265,
266, 267, 268, 269, 270, 271, 272, 273, 274, 275,
- -1, -1, 93, 279, 280, -1, 282, 283, 284, 294,
- 295, -1, -1, 289, 290, 291, 292, 293, -1, -1,
- 296, 297, 91, -1, -1, -1, -1, 303, 294, 295,
- -1, 307, 91, 309, 310, 26, 33, -1, -1, 36,
- 37, 38, -1, 40, 41, 42, 43, 44, 45, 48,
- 49, 42, -1, -1, 123, -1, 47, -1, 49, -1,
- -1, 58, 59, -1, 123, 125, 63, 64, -1, -1,
- 61, 62, 63, 64, 256, 257, 258, 259, 260, 261,
- -1, 263, 264, 265, -1, -1, -1, 269, -1, 88,
- 272, 273, 274, 275, 91, -1, 93, 279, 280, -1,
- 282, 283, 284, 63, -1, -1, -1, 289, 290, 291,
- 292, 293, 91, -1, 296, 297, 107, 116, 266, 267,
- 268, 303, 270, 271, 123, 307, 123, 309, 310, 126,
- 33, 91, -1, 36, 37, 38, -1, 40, 41, 42,
- 43, 44, 45, -1, 123, -1, -1, -1, 285, 286,
- 287, 288, -1, -1, -1, 58, 59, -1, -1, -1,
- 63, 64, -1, 123, 301, 302, -1, 304, 305, -1,
- -1, 308, -1, -1, 311, 312, 313, -1, -1, -1,
- 179, 272, 273, 274, 275, 184, -1, -1, -1, 33,
- 93, -1, 36, 37, 38, -1, 40, -1, 42, 43,
- -1, 45, -1, 294, 295, -1, 266, 267, 268, -1,
- 270, 271, -1, -1, -1, 59, 285, 286, 287, 288,
- 64, -1, -1, 126, -1, -1, 285, 286, 287, 288,
- 299, 300, 301, 302, -1, 304, 305, -1, -1, 308,
- -1, -1, 311, 312, 313, 304, 305, 91, -1, 308,
- -1, -1, 311, 312, 313, -1, -1, -1, -1, -1,
- 257, 258, 259, 260, 261, -1, 263, 264, 265, -1,
- -1, -1, 269, -1, -1, 272, 273, 274, 275, 123,
- -1, -1, 126, 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, 91, -1, -1,
- -1, 281, -1, -1, -1, 285, 286, 287, 288, 308,
- -1, -1, 311, 312, 313, -1, -1, -1, 298, 299,
- 300, 301, 302, -1, 304, 305, -1, -1, 308, 123,
- -1, 311, 312, 313, 257, 258, 259, 260, 261, -1,
- 263, 264, 265, -1, -1, -1, 269, -1, -1, 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, 91, 256, 257, 258, 259, 260, 261, -1, 263,
- 264, 265, -1, 41, -1, 269, 44, -1, 272, 273,
- 274, 275, -1, -1, -1, 279, 280, -1, 282, 283,
- 284, 59, -1, 123, -1, 289, 290, 291, 292, 293,
- -1, -1, 296, 297, -1, -1, -1, -1, -1, 303,
- 25, 26, -1, 307, 33, 309, 310, 36, 37, 38,
- -1, 40, 37, 42, 43, 93, 45, 42, 43, -1,
- -1, -1, 47, -1, 49, 272, 273, 274, 275, -1,
- 59, -1, -1, -1, -1, 64, 61, 62, 63, 64,
- -1, -1, -1, -1, -1, -1, -1, 294, 295, -1,
- -1, -1, -1, 287, 288, -1, -1, -1, -1, -1,
- 33, -1, 91, 36, 37, 38, -1, 40, -1, 42,
- 43, 305, 45, -1, 308, -1, -1, 311, 312, 313,
- -1, -1, 107, -1, -1, -1, -1, -1, -1, -1,
- -1, 64, -1, -1, 123, -1, -1, 126, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -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, 167, -1, -1, -1, -1, 64, -1, -1,
- 123, -1, -1, 126, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 305, -1, -1, 308, -1,
- -1, 311, 312, 313, 91, -1, -1, -1, -1, 33,
- -1, -1, 36, 37, 38, -1, 40, -1, 42, 43,
- -1, 45, -1, -1, 272, 273, 274, 275, -1, -1,
- -1, -1, -1, -1, -1, 59, 123, -1, -1, 126,
- 64, -1, -1, -1, -1, -1, 294, -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, -1, -1, -1,
- 289, 290, 291, 292, 293, -1, -1, 296, 297, -1,
- 91, 63, 126, -1, 303, -1, -1, -1, 307, -1,
- 309, 310, -1, -1, 257, 258, 259, 260, 261, 262,
- 263, 264, 265, -1, -1, -1, 269, -1, -1, 91,
- 41, -1, 123, -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, -1, -1,
- 303, 123, -1, -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, 41, 123, -1, 44, -1, 303, -1, -1, -1,
- 307, -1, 309, 310, -1, -1, -1, -1, 58, 59,
- -1, -1, -1, 257, 258, 259, 260, 261, 91, 263,
- 264, 265, -1, 33, -1, 269, 36, 37, 38, -1,
- 40, -1, 42, 43, -1, 45, 280, -1, 282, 283,
- 284, -1, -1, 93, -1, 289, 290, 291, 292, 293,
- 123, -1, 296, 297, 64, -1, -1, -1, -1, 303,
- -1, -1, -1, 307, -1, 309, 310, -1, -1, -1,
- -1, -1, -1, -1, 285, -1, 287, 288, -1, 33,
- -1, 91, 36, 37, 38, -1, 40, 41, 42, 43,
- -1, 45, -1, 304, 305, -1, -1, 308, -1, 281,
- 311, 312, 313, 285, 286, 287, 288, -1, -1, -1,
- 64, -1, -1, 123, -1, -1, 126, 299, 300, 301,
- 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
- 312, 313, -1, -1, -1, 33, -1, 91, 36, 37,
- 38, -1, 40, -1, 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, -1, -1, -1, -1, -1,
- -1, -1, -1, 91, -1, 93, -1, -1, 33, -1,
- -1, 36, 37, 38, -1, 40, -1, 42, 43, -1,
- 45, -1, -1, -1, 287, 288, -1, -1, -1, -1,
- -1, -1, 272, 273, 274, 275, -1, -1, 126, 64,
- -1, 304, 305, -1, -1, 308, -1, -1, 311, 312,
- 313, -1, -1, -1, 294, 295, -1, 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, -1, -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, 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, 41, -1, 93, 44, 303, -1, -1, -1, 307,
- -1, 309, 310, -1, -1, -1, -1, -1, 58, 59,
- -1, 256, 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,
- -1, -1, -1, 93, 289, 290, 291, 292, 293, -1,
- -1, 296, 297, 64, -1, -1, -1, -1, 303, -1,
- -1, -1, 307, -1, 309, 310, -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, -1, -1, -1, -1, -1, 285, 286, 287,
- 288, -1, -1, -1, -1, -1, -1, -1, -1, 64,
- -1, -1, 300, 301, 302, 126, 304, 305, -1, -1,
- 308, -1, -1, 311, 312, 313, -1, -1, 285, 286,
- 287, 288, -1, -1, 33, -1, 91, 36, 37, 38,
- -1, 40, 41, 42, 43, 302, 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, 272, 273, 274, 275, -1, 126, 64, -1,
+ 41, 355, 123, 279, 280, 126, 282, 283, 284, 285,
+ 286, 297, 298, 297, 298, 291, 292, 293, 294, 295,
+ 296, 41, 281, 299, 297, 298, 41, 59, 287, 288,
+ 289, 290, 308, 41, 310, 311, 41, 297, 298, 123,
+ 289, 300, 301, 302, 303, 304, 305, 306, 41, 59,
+ 309, 59, 41, 312, 313, 314, 59, 306, 41, 41,
+ 309, 297, 298, 312, 313, 314, 309, 59, 41, 312,
+ 313, 314, 13, 147, 95, 297, 298, 355, 91, 256,
+ 257, 258, 259, 260, 261, 93, 263, 264, 265, 266,
+ 267, 268, 269, 270, 271, 272, 273, 274, 275, 297,
+ 298, 318, 279, 280, 195, 282, 283, 284, 285, 286,
+ 123, -1, -1, -1, 291, 292, 293, 294, 295, 296,
+ -1, -1, 299, 91, 272, 273, 274, 275, -1, -1,
+ -1, 308, -1, 310, 311, 256, 257, 258, 259, 260,
+ 261, 125, 263, 264, 265, -1, -1, -1, 269, 297,
+ 298, 272, 273, 274, 275, 123, -1, -1, 279, 280,
+ -1, 282, 283, 284, 285, 286, -1, -1, -1, 91,
+ 291, 292, 293, 294, 295, 296, -1, -1, 299, -1,
+ -1, -1, 125, -1, 91, -1, -1, 308, 33, 310,
+ 311, 36, 37, 38, -1, 40, 41, 42, 43, 44,
+ 45, 123, -1, 25, 26, 190, -1, 192, 272, 273,
+ 274, 275, -1, 58, 59, 37, 123, -1, 63, 64,
+ -1, 43, 44, 45, -1, -1, -1, -1, 50, -1,
+ -1, -1, -1, 297, 298, -1, -1, -1, -1, -1,
+ 62, 63, 64, 65, -1, -1, 91, -1, 93, 33,
+ -1, -1, 36, 37, 38, -1, 40, 41, 42, 43,
+ 44, 45, -1, -1, 272, 273, 274, 275, -1, -1,
+ -1, -1, -1, -1, 58, 59, 289, 290, 123, 63,
+ 64, 126, 266, 267, 268, -1, 270, 271, 110, 297,
+ 298, -1, 305, 306, -1, -1, 309, -1, -1, 312,
+ 313, 314, -1, -1, -1, -1, -1, -1, 33, 93,
+ -1, 36, 37, 38, -1, 40, -1, 42, 43, 287,
+ 45, 289, 290, 266, 267, 268, -1, 270, 271, -1,
+ -1, -1, -1, -1, 59, -1, -1, 305, 306, 64,
+ -1, 309, 126, -1, 312, 313, 314, 169, -1, 334,
+ 335, -1, -1, -1, -1, -1, 341, -1, -1, 41,
+ -1, -1, 44, -1, -1, -1, 91, 289, 290, -1,
+ -1, 356, -1, -1, 359, 197, 58, 59, -1, -1,
+ -1, 63, -1, -1, 306, -1, -1, 309, -1, -1,
+ 312, 313, 314, -1, -1, -1, -1, -1, 123, 306,
+ -1, 126, 309, -1, -1, 312, 313, 314, -1, -1,
+ -1, 93, 257, 258, 259, 260, 261, -1, 263, 264,
+ 265, -1, -1, -1, 269, -1, -1, 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, 306, -1, 308, 309, 310, 311, 312, 313, 314,
+ -1, -1, -1, 257, 258, 259, 260, 261, -1, 263,
+ 264, 265, -1, -1, -1, 269, -1, -1, 272, 273,
+ 274, 275, -1, -1, -1, -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, 306, -1, 308, 309, 310, 311, 312, 313,
+ 314, 256, 257, 258, 259, 260, 261, -1, 263, 264,
+ 265, -1, -1, -1, 269, -1, -1, 272, 273, 274,
+ 275, -1, -1, -1, 279, 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, 43, -1, -1,
+ 272, 273, 274, 275, -1, 51, -1, 123, 59, 281,
+ -1, -1, -1, 64, -1, 287, 288, 289, 290, -1,
+ -1, -1, -1, -1, -1, 297, 298, -1, 300, 301,
+ 302, 303, 304, 305, 306, -1, -1, 309, 33, -1,
+ 91, 36, 37, 38, 90, 40, -1, 42, 43, -1,
+ 45, -1, -1, -1, -1, -1, -1, -1, 309, 310,
+ 311, -1, -1, -1, 315, -1, 317, -1, -1, 64,
+ -1, 117, 123, -1, -1, 126, -1, -1, -1, 125,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 294, 295, 257, 258, 259, 260,
+ -1, -1, 343, -1, 33, -1, 91, 36, 37, 38,
+ 351, 40, 353, 42, 43, -1, 45, -1, -1, -1,
+ -1, -1, -1, 364, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 64, -1, -1, 123, -1,
+ -1, 126, -1, -1, -1, -1, 182, -1, -1, -1,
+ -1, 187, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 91, -1, -1, -1, -1, 33, -1, -1,
+ 36, 37, 38, -1, 40, -1, 42, 43, -1, 45,
+ -1, 287, 288, 289, 290, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 123, -1, -1, 126, 64, 305,
+ 306, -1, -1, 309, -1, -1, 312, 313, 314, -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, -1,
- 42, 43, -1, 45, 280, -1, 282, 283, 284, -1,
- -1, -1, -1, 289, 290, 291, 292, 293, -1, -1,
- 296, 297, 64, -1, -1, -1, -1, 303, -1, -1,
- -1, 307, -1, 309, 310, -1, -1, -1, -1, -1,
- 41, -1, -1, 44, -1, -1, -1, -1, -1, 91,
- -1, -1, -1, -1, -1, -1, -1, 58, 59, -1,
- -1, -1, 63, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 126, 272, 273, 274, 275, -1,
- 91, -1, 93, -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, 123, -1, 311, 312, 313, -1, -1, -1,
- -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, 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, -1, -1, 307, -1, 309, 310, -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, -1, -1, -1, -1, -1,
- -1, -1, 58, 59, -1, -1, -1, 63, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -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, -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, 93, -1, -1, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
- 285, 286, 287, 288, -1, -1, -1, 41, -1, 294,
- 295, -1, -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, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 41, -1, -1, -1, -1, -1, 91, -1, 93,
- -1, -1, -1, -1, -1, -1, -1, -1, 58, 59,
- -1, -1, -1, 63, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 123,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, 91, -1, 93, -1, -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, 123, -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,
- -1, -1, -1, 272, 273, 274, 275, 58, 59, -1,
- -1, -1, 63, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 294, 295, -1, 123, 298,
- -1, -1, -1, 41, -1, -1, -1, -1, -1, -1,
- -1, -1, 93, -1, -1, -1, -1, -1, -1, -1,
- 58, 59, -1, -1, -1, 63, -1, -1, -1, -1,
+ -1, 272, 273, 274, 275, -1, -1, -1, 279, 280,
+ -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
+ 291, 292, 293, 294, 295, 296, -1, 123, 299, -1,
+ 126, -1, 91, -1, -1, -1, 41, 308, -1, 310,
+ 311, -1, 257, 258, 259, 260, 261, 262, 263, 264,
+ 265, -1, -1, -1, 269, -1, -1, -1, 63, -1,
+ -1, -1, -1, -1, 123, 280, -1, 282, 283, 284,
+ 285, 286, -1, -1, -1, -1, 291, 292, 293, 294,
+ 295, 296, -1, -1, 299, -1, 91, -1, -1, -1,
+ -1, -1, -1, 308, -1, 310, 311, -1, 257, 258,
+ 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
+ 269, 58, -1, -1, -1, -1, 63, -1, 123, -1,
+ -1, 280, -1, 282, 283, 284, 285, 286, -1, -1,
+ -1, -1, 291, 292, 293, 294, 295, 296, -1, -1,
+ 299, -1, -1, -1, 91, -1, -1, -1, -1, 308,
+ -1, 310, 311, -1, -1, -1, -1, 41, -1, -1,
+ 44, 257, 258, 259, 260, 261, -1, 263, 264, 265,
+ -1, -1, -1, 269, 58, 59, 123, -1, -1, 63,
+ -1, -1, -1, -1, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
+ 296, 33, -1, 299, 36, 37, 38, -1, 40, 93,
+ 42, 43, 308, 45, 310, 311, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 59, 287, 288,
+ 289, 290, 64, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, 301, 302, 303, 304, 305, 306, -1, -1,
+ 309, -1, -1, 312, 313, 314, -1, 33, -1, 91,
+ 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
+ -1, -1, -1, -1, -1, -1, 281, -1, -1, -1,
+ -1, -1, 287, 288, 289, 290, -1, -1, 64, -1,
+ -1, -1, -1, -1, 126, 300, 301, 302, 303, 304,
+ 305, 306, -1, -1, 309, -1, -1, 312, 313, 314,
+ -1, -1, -1, 33, -1, 91, 36, 37, 38, -1,
+ 40, -1, 42, 43, -1, 45, -1, -1, -1, -1,
+ -1, -1, -1, -1, 281, -1, -1, -1, -1, -1,
+ 287, 288, 289, 290, 64, -1, -1, -1, -1, -1,
+ 126, -1, -1, 300, 301, 302, 303, 304, 305, 306,
+ -1, -1, 309, -1, -1, 312, 313, 314, -1, -1,
+ -1, 91, 33, 93, -1, 36, 37, 38, -1, 40,
+ 41, 42, 43, -1, 45, -1, -1, -1, 272, 273,
+ 274, 275, -1, -1, -1, -1, -1, 281, -1, -1,
+ -1, -1, -1, 64, 288, -1, 126, -1, -1, -1,
+ -1, -1, -1, 297, 298, -1, 300, 301, 302, 303,
+ 304, 41, -1, -1, 44, 257, 258, 259, 260, 261,
+ 91, 263, 264, 265, -1, -1, -1, 269, 58, 59,
+ -1, -1, -1, 63, -1, -1, -1, -1, 280, -1,
+ 282, 283, 284, 285, 286, -1, -1, -1, -1, 291,
+ 292, 293, 294, 295, 296, 126, -1, 299, -1, -1,
+ -1, -1, -1, 93, -1, -1, 308, 41, 310, 311,
+ 44, 257, 258, 259, 260, 261, -1, 263, 264, 265,
+ -1, -1, -1, 269, 58, 59, -1, -1, -1, 63,
+ -1, -1, -1, -1, 280, -1, 282, 283, 284, 285,
+ 286, -1, -1, -1, -1, 291, 292, 293, 294, 295,
+ 296, -1, -1, 299, -1, -1, -1, -1, -1, 93,
+ -1, -1, 308, -1, 310, 311, -1, 257, 258, 259,
+ 260, 261, -1, 263, 264, 265, -1, 33, -1, 269,
+ 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
+ 280, -1, 282, 283, 284, 285, 286, -1, -1, -1,
+ -1, 291, 292, 293, 294, 295, 296, -1, 64, 299,
+ -1, -1, -1, -1, -1, -1, -1, -1, 308, -1,
+ 310, 311, -1, -1, -1, -1, 257, 258, 259, 260,
+ 261, -1, 263, 264, 265, 91, 33, -1, 269, 36,
+ 37, 38, -1, 40, -1, 42, 43, -1, 45, 280,
+ -1, 282, 283, 284, 285, 286, -1, -1, -1, -1,
+ 291, 292, 293, 294, 295, 296, -1, 64, 299, -1,
+ 126, -1, -1, -1, -1, -1, -1, 308, -1, 310,
+ 311, -1, 272, 273, 274, 275, -1, -1, -1, -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, 272, 273,
+ 274, 275, -1, -1, -1, -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, -1, 123, -1, -1, -1, -1, -1, 272, 273,
- 274, 275, -1, 91, -1, 93, -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, 308, 123, -1, 311, 312, 313,
+ -1, 257, 258, 259, 260, 261, 91, 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, 126, 64, 299, -1, -1, -1, -1, -1, -1,
+ -1, -1, 308, -1, 310, 311, -1, -1, -1, 256,
+ 257, 258, 259, 260, 261, -1, 263, 264, 265, 91,
+ -1, -1, 269, 41, -1, -1, 44, -1, -1, -1,
+ -1, -1, -1, 280, -1, 282, 283, 284, 285, 286,
+ 58, 59, -1, -1, 291, 292, 293, 294, 295, 296,
+ -1, -1, 299, -1, 126, -1, -1, -1, -1, 41,
+ -1, 308, 44, 310, 311, -1, 257, 258, 259, 260,
+ 261, -1, 263, 264, 265, 93, 58, 59, 269, -1,
+ -1, 63, -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, 91,
+ -1, 93, -1, -1, -1, -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, 123, -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,
+ 93, -1, -1, 308, -1, 310, 311, -1, -1, -1,
+ -1, 41, -1, -1, 44, 257, 258, 259, 260, 261,
+ -1, 263, 264, 265, -1, -1, -1, 269, 58, 59,
+ 123, -1, -1, 63, -1, -1, -1, -1, 280, -1,
+ 282, 283, 284, 285, 286, -1, -1, -1, -1, 291,
+ 292, 293, 294, 295, 296, -1, -1, 299, -1, 41,
+ -1, 91, 44, 93, -1, -1, 308, -1, 310, 311,
+ -1, -1, -1, -1, -1, -1, 58, 59, -1, -1,
+ -1, 63, -1, -1, 272, 273, 274, 275, -1, -1,
+ -1, -1, -1, 123, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 297,
+ 298, 93, 300, -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, -1,
+ -1, 123, 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, 91, -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, -1, -1, 309, -1, -1, 312,
+ 313, 314, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 93, -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, 93, 298, 299,
- 300, 301, 302, -1, 304, 305, -1, -1, 308, -1,
- -1, 311, 312, 313, -1, -1, -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, 41, -1, 308, 44, -1, 311, 312, 313, 93,
- -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, 58,
- -1, -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,
- 308, -1, 91, 311, 312, 313, -1, -1, -1, -1,
- -1, -1, 58, 59, -1, -1, -1, 63, -1, -1,
+ -1, 281, -1, -1, -1, -1, -1, 287, 288, 289,
+ 290, -1, -1, -1, -1, -1, 123, 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, -1, 281,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
+ -1, -1, 58, 59, -1, 297, 298, 63, 300, 301,
+ 302, 303, 304, 305, 306, -1, -1, 309, -1, -1,
+ 312, 313, 314, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 91, -1, 93, -1, -1,
-1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, -1, 123, -1, -1, 41, -1, -1,
- 44, -1, -1, -1, -1, -1, -1, 93, 294, 295,
- -1, -1, -1, -1, 58, 59, -1, -1, -1, 63,
+ -1, -1, -1, -1, -1, 281, -1, -1, -1, -1,
+ -1, 287, 288, 289, 290, -1, -1, 123, -1, -1,
+ 91, 297, 298, -1, 300, 301, 302, 303, 304, 305,
+ 306, -1, -1, 309, -1, -1, 312, 313, 314, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 123, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, 41, 93,
- -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, 41, -1, 308, 44, -1, 311, 312, 313,
- 93, -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, 41, 304, 305, 44, -1, 308, -1,
- -1, 311, 312, 313, 93, -1, -1, -1, -1, -1,
- 58, 59, 281, -1, -1, 63, 285, 286, 287, 288,
- -1, -1, -1, -1, -1, -1, -1, -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, -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, -1, -1, 311, 312, 313, 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, 308, -1, -1, 311, 312, 313,
- -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, 93, -1, -1,
- -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
- -1, 304, 305, -1, -1, 308, -1, -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, -1, 298,
- 299, 300, 301, 302, 41, 304, 305, 44, -1, 308,
- -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, 41, 304, 305, 44, -1,
- 308, -1, -1, -1, -1, -1, 93, -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, 63, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
- 44, -1, -1, -1, -1, -1, 272, 273, 274, 275,
- -1, -1, -1, 93, 58, 59, -1, -1, -1, 63,
- -1, -1, -1, -1, -1, -1, -1, -1, 294, 295,
+ -1, -1, 123, -1, -1, 272, 273, 274, 275, -1,
+ 41, -1, -1, -1, 281, -1, -1, -1, -1, -1,
+ 287, 288, 289, 290, -1, -1, -1, 58, 59, -1,
+ 297, 298, 63, 300, 301, 302, 303, 304, 305, 306,
+ -1, -1, 309, -1, -1, 312, 313, 314, -1, -1,
-1, -1, -1, 41, -1, -1, 44, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, 93,
+ 91, -1, 93, 41, -1, -1, 44, -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, 63, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- -1, 93, -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, 305, 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, 272, 273, 274, 275, -1, -1, 93, -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, 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, 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,
- 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,
+ 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, 93, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 93, 272, 273, 274, 275,
+ -1, 41, -1, -1, 44, 281, -1, -1, -1, -1,
+ -1, 287, 288, 289, 290, 123, -1, -1, 58, 59,
+ -1, 297, 298, 63, 300, 301, 302, 303, 304, 305,
+ 306, -1, -1, 309, -1, -1, 312, 313, 314, -1,
+ -1, -1, -1, -1, 41, -1, 287, 288, 289, 290,
+ -1, -1, -1, 93, -1, -1, -1, -1, -1, -1,
+ -1, 58, 59, 304, 305, 306, 63, -1, 309, -1,
+ -1, 312, 313, 314, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 123, -1, -1, -1, -1, 41, -1,
+ -1, 44, -1, -1, 91, -1, 93, -1, -1, -1,
+ -1, -1, -1, -1, -1, 58, 59, -1, -1, -1,
+ 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 272, 273, 274, 275, -1, 123, -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, 272, 273, 274, 275, -1, 41,
+ 123, -1, 44, 281, 272, 273, 274, 275, -1, 287,
+ 288, 289, 290, -1, -1, -1, 58, 59, -1, 297,
+ 298, 63, 300, 301, 302, 303, 304, 305, 306, 297,
+ 298, 309, 300, -1, 312, 313, 314, -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, -1, 58, 59, 93,
- -1, -1, 63, -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, 93, 298, 299, 300, 301, 302, -1, 304,
- 305, 58, 59, -1, -1, -1, 63, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
+ -1, 93, -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, -1, -1, -1, 58, 59, -1, 297, 298, 63,
+ 300, 301, 302, 303, 304, 305, 306, -1, -1, 309,
+ -1, -1, 312, 313, 314, 272, 273, 274, 275, -1,
+ 41, -1, -1, 44, 281, -1, -1, -1, -1, 93,
+ 287, 288, 289, 290, -1, -1, -1, 58, 59, -1,
+ 297, 298, 63, 300, 301, 302, 303, 304, 305, 306,
+ -1, -1, 309, -1, -1, 312, 313, 314, -1, 272,
+ 273, 274, 275, -1, 41, -1, -1, 44, 281, -1,
+ -1, -1, 93, -1, 287, 288, 289, 290, -1, -1,
+ -1, 58, 59, -1, 297, 298, 63, 300, 301, 302,
+ 303, 304, 305, 306, -1, -1, 309, -1, -1, 312,
+ 313, 314, -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, 41, -1, 63,
44, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, 58, 59, 93, -1, -1, 63,
- -1, -1, -1, -1, -1, -1, -1, -1, 41, -1,
- -1, 44, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 58, 59, -1, -1, 93,
- 63, -1, -1, -1, -1, -1, -1, -1, -1, 41,
- -1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 58, 59, -1, -1,
- 93, 63, -1, -1, -1, -1, -1, -1, -1, -1,
- 41, -1, -1, 44, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 41, 58, 59, 44,
- -1, 93, 63, -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, 93, -1, 298, 299, 300, 301, 302, -1,
- 304, 272, 273, 274, 275, -1, -1, -1, 93, -1,
- 281, -1, -1, -1, 285, 286, -1, 288, 41, -1,
- -1, 44, -1, 294, 295, -1, -1, 298, 299, 300,
- 301, 302, -1, 304, 41, 58, 59, 44, -1, -1,
- 63, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- -1, 58, 59, -1, 281, -1, 63, -1, 285, 286,
- -1, -1, -1, -1, -1, -1, -1, 294, 295, -1,
- 93, 298, 299, 300, 301, 302, -1, 304, 272, 273,
- 274, 275, -1, -1, -1, -1, 93, 281, -1, -1,
- -1, 285, 286, -1, -1, -1, -1, -1, -1, 41,
- 294, 295, 44, -1, 298, 299, 300, 301, 302, 272,
- 273, 274, 275, -1, -1, -1, 58, 59, 281, -1,
- -1, 63, 285, 286, -1, -1, -1, -1, -1, -1,
- -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
- 272, 273, 274, 275, -1, -1, -1, -1, -1, 281,
- -1, 93, -1, 285, 286, -1, -1, -1, -1, -1,
- -1, -1, 294, 295, -1, -1, 298, 299, 300, 301,
- 302, 272, 273, 274, 275, -1, -1, -1, -1, -1,
- 281, -1, -1, -1, -1, 286, -1, 272, 273, 274,
- 275, -1, -1, 294, 295, -1, 281, 298, 299, 300,
- 301, 302, -1, -1, -1, -1, -1, -1, -1, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, -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, 272,
- 273, 274, 275, -1, -1, -1, -1, -1, 281, -1,
+ 272, 273, 274, 275, 58, 59, -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, 41, -1, 309, 44, 93,
+ 312, 313, 314, -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, 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, 272, 273, 274, 275, -1, -1, -1, -1, -1,
+ 281, -1, -1, -1, -1, 93, 287, 288, 289, 290,
+ -1, -1, -1, -1, -1, -1, 297, 298, -1, 300,
+ 301, 302, 303, 304, 305, 306, -1, -1, 309, -1,
+ -1, 312, 313, 314, -1, 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, 272, 273,
+ 274, 275, -1, -1, -1, -1, -1, 281, -1, -1,
+ -1, -1, 93, 287, 288, 289, 290, -1, 272, 273,
+ 274, 275, -1, 297, 298, 30, 300, 301, 302, 303,
+ 304, 305, 306, 38, -1, 309, -1, 42, -1, -1,
+ 45, -1, -1, 297, 298, -1, -1, 52, 53, 54,
+ 55, 56, -1, -1, 59, 60, -1, -1, 91, -1,
+ -1, 66, -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, 92, 58, 59,
+ 123, 297, 298, 63, 300, 301, 302, 303, 304, 305,
+ 306, -1, -1, -1, 272, 273, 274, 275, -1, -1,
+ -1, -1, -1, 281, -1, -1, -1, -1, -1, 287,
+ 288, 289, 290, 93, 41, -1, -1, 44, -1, 297,
+ 298, -1, 300, 301, 302, 303, 304, 305, 306, -1,
+ -1, 58, 59, -1, -1, -1, 63, -1, 153, 154,
+ 155, 156, 157, 158, 159, 160, 161, 162, 163, 164,
+ 165, 166, 41, -1, -1, 44, -1, -1, -1, -1,
+ -1, -1, -1, 178, -1, -1, 93, -1, -1, 58,
+ 59, -1, -1, -1, 63, -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,
+ 41, -1, -1, 44, 93, -1, 297, 298, -1, 300,
+ 301, 302, 303, 304, 305, 306, -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, 258, 287, 288, 289, 290, -1, -1,
+ -1, -1, 93, 58, 59, -1, -1, -1, 63, 302,
+ 303, 304, 305, 306, -1, -1, 309, -1, -1, 312,
+ 313, 314, -1, -1, -1, -1, -1, -1, -1, -1,
+ 295, 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, -1, -1, -1,
+ -1, -1, -1, 93, -1, 41, -1, -1, 44, -1,
-1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
- -1, 294, 295, -1, 281, 298, 299, 300, 301, 302,
- -1, -1, 30, -1, -1, -1, -1, 294, 295, -1,
- 38, 298, 299, 300, 301, 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,
- 272, 273, 274, 275, -1, -1, -1, -1, -1, 281,
- -1, -1, 90, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, 294, 295, -1, -1, 298, 299, 300, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 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, 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, -1, 272, 273, 274, 275, 93, -1, -1,
+ -1, -1, 281, -1, -1, -1, -1, -1, 287, 288,
+ 289, 290, 41, -1, -1, 44, -1, -1, 297, 298,
+ -1, 300, 301, 302, 303, 304, 305, 306, -1, 58,
+ 59, -1, -1, -1, 63, -1, -1, -1, -1, -1,
+ -1, 272, 273, 274, 275, 41, -1, -1, 44, -1,
+ 281, -1, -1, -1, -1, -1, 287, 288, 289, 290,
+ -1, -1, 58, 59, 93, 41, 297, 298, 44, 300,
+ 301, 302, 303, 304, 305, 306, -1, 272, 273, 274,
+ 275, -1, 58, 59, -1, -1, 281, 63, -1, -1,
+ -1, -1, 287, 288, 289, 290, -1, 93, -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, 91, -1, -1, -1, -1, -1, 297, 298, -1,
+ 300, 301, 302, 303, 304, 305, -1, 41, -1, -1,
+ 44, -1, -1, 93, 41, -1, -1, 44, -1, -1,
+ -1, -1, -1, 123, 58, 59, 272, 273, 274, 275,
+ -1, 58, 59, -1, -1, 281, 63, -1, -1, -1,
+ -1, 287, 288, -1, -1, -1, 41, -1, -1, 44,
+ -1, 297, 298, -1, 300, 301, 302, 303, 304, 93,
+ -1, -1, -1, 58, 59, -1, 93, -1, 63, -1,
+ -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 272, 273, 274, 275, -1, 93, 91,
+ -1, -1, 281, -1, -1, 63, -1, -1, 287, 288,
+ -1, -1, -1, -1, -1, -1, -1, -1, 297, 298,
+ -1, 300, 301, 302, 303, 304, 272, 273, 274, 275,
+ -1, 123, -1, 91, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
+ -1, 297, 298, -1, -1, 281, -1, -1, -1, -1,
+ -1, 287, 288, -1, -1, 123, -1, -1, -1, -1,
+ -1, 297, 298, -1, 300, 301, 302, 303, 304, -1,
+ -1, -1, -1, -1, -1, -1, -1, 287, 288, 289,
+ 290, -1, 272, 273, 274, 275, -1, -1, -1, -1,
+ -1, 281, -1, 303, 304, 305, 306, 287, 288, 309,
+ -1, -1, 312, 313, 314, -1, -1, 297, 298, -1,
+ 300, 301, 302, 303, 304, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 272, 273,
+ 274, 275, -1, -1, -1, 272, 273, 274, 275, -1,
+ -1, -1, -1, -1, 281, -1, -1, -1, -1, -1,
+ -1, -1, -1, 297, 298, -1, -1, -1, -1, -1,
+ 297, 298, -1, 300, 301, 302, 303, 272, 273, 274,
+ 275, -1, -1, -1, -1, -1, 281, -1, -1, 281,
+ -1, -1, -1, -1, -1, 287, 288, 289, 290, -1,
+ -1, -1, 297, 298, -1, 300, 301, 302, 300, 301,
+ 302, 303, 304, 305, 306, -1, -1, 309, -1, -1,
+ 312, 313, 314, 281, -1, -1, -1, -1, -1, 287,
+ 288, 289, 290, -1, -1, -1, -1, 13, -1, -1,
+ -1, 17, -1, 301, 302, 303, 304, 305, 306, -1,
+ -1, 309, -1, -1, 312, 313, 314, 33, 34, 35,
+ 36, -1, -1, -1, -1, -1, 42, -1, -1, 45,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, 80, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 94, -1,
+ -1, 97, -1, 99, -1, 101, -1, 103, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 144, -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, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 284,
+ -1, -1, -1, -1, -1, 181, -1, -1, -1, -1,
+ -1, -1, 188,
};
#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,
@@ -1124,9 +1074,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",
};
@@ -1136,6 +1086,8 @@ dEXT char * yyrule[] = {
"prog : $$1 lineseq",
"block : '{' remember lineseq '}'",
"remember :",
+"mblock : '{' mremember lineseq '}'",
+"mremember :",
"lineseq :",
"lineseq : lineseq decl",
"lineseq : lineseq line",
@@ -1148,28 +1100,34 @@ 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",
+"else : ELSE mblock",
+"else : ELSIF '(' mexpr ')' mblock else",
+"cond : IF '(' remember mexpr ')' mblock else",
+"cond : UNLESS '(' remember miexpr ')' mblock else",
"cond : IF block block else",
"cond : UNLESS block block else",
"cont :",
"cont : CONTINUE block",
-"loop : label WHILE '(' texpr ')' block cont",
-"loop : label UNTIL '(' expr ')' block cont",
+"loop : label WHILE '(' remember mtexpr ')' mblock cont",
+"loop : label UNTIL '(' remember miexpr ')' mblock 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 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",
@@ -1225,7 +1183,7 @@ dEXT char * yyrule[] = {
"term : term POSTDEC",
"term : PREINC term",
"term : PREDEC term",
-"term : LOCAL term",
+"term : local term",
"term : '(' expr ')'",
"term : '(' ')'",
"term : '[' expr ']'",
@@ -1281,6 +1239,9 @@ dEXT char * yyrule[] = {
"listexprcom :",
"listexprcom : expr",
"listexprcom : expr ','",
+"local : LOCAL",
+"local : MY",
+"my_scalar : scalar",
"amper : '&' indirob",
"scalar : '$' indirob",
"ary : '@' indirob",
@@ -1313,9 +1274,9 @@ dEXT int yyerrflag;
dEXT int yychar;
dEXT YYSTYPE yyval;
dEXT YYSTYPE yylval;
-#line 571 "perly.y"
+#line 624 "perly.y"
/* PROGRAM */
-#line 1388 "y_tab.c"
+#line 1349 "perly.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
@@ -1336,15 +1297,15 @@ yydestruct(ptr)
void* ptr;
{
struct ysv* ysave = (struct ysv*)ptr;
- if (ysave->yyss) safefree((char *)ysave->yyss);
- if (ysave->yyvs) safefree((char *)ysave->yyvs);
+ if (ysave->yyss) Safefree(ysave->yyss);
+ if (ysave->yyvs) Safefree(ysave->yyvs);
yydebug = ysave->oldyydebug;
yynerrs = ysave->oldyynerrs;
yyerrflag = ysave->oldyyerrflag;
yychar = ysave->oldyychar;
yyval = ysave->oldyyval;
yylval = ysave->oldyylval;
- safefree((char *)ysave);
+ Safefree(ysave);
}
int
@@ -1407,7 +1368,7 @@ yyloop:
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate,
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
#endif
@@ -1417,7 +1378,7 @@ yyloop:
{
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log, "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)
@@ -1472,7 +1433,7 @@ yyinrecovery:
{
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log,
+ PerlIO_printf(Perl_debug_log,
"yydebug: state %d, error recovery shifting to state %d\n",
*yyssp, yytable[yyn]);
#endif
@@ -1502,7 +1463,7 @@ yyinrecovery:
{
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log,
+ PerlIO_printf(Perl_debug_log,
"yydebug: error recovery discarding state %d\n",
*yyssp);
#endif
@@ -1521,7 +1482,7 @@ yyinrecovery:
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(Perl_debug_log,
+ PerlIO_printf(Perl_debug_log,
"yydebug: state %d, error recovery discards token %d (%s)\n",
yystate, yychar, yys);
}
@@ -1532,7 +1493,7 @@ yyinrecovery:
yyreduce:
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log, "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];
@@ -1540,7 +1501,7 @@ yyreduce:
switch (yyn)
{
case 1:
-#line 84 "perly.y"
+#line 85 "perly.y"
{
#if defined(YYDEBUG) && defined(DEBUGGING)
yydebug = (debug & 1);
@@ -1549,38 +1510,50 @@ case 1:
}
break;
case 2:
-#line 91 "perly.y"
+#line 92 "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 96 "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 102 "perly.y"
+{ yyval.ival = block_start(TRUE); }
break;
case 5:
-#line 103 "perly.y"
-{ yyval.opval = Nullop; }
+#line 106 "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 112 "perly.y"
+{ yyval.ival = block_start(FALSE); }
break;
case 7:
-#line 107 "perly.y"
+#line 116 "perly.y"
+{ yyval.opval = Nullop; }
+break;
+case 8:
+#line 118 "perly.y"
+{ yyval.opval = yyvsp[-1].opval; }
+break;
+case 9:
+#line 120 "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 127 "perly.y"
{ yyval.opval = newSTATEOP(0, yyvsp[-1].pval, yyvsp[0].opval); }
break;
-case 10:
-#line 117 "perly.y"
+case 12:
+#line 130 "perly.y"
{ if (yyvsp[-1].pval != Nullch) {
yyval.opval = newSTATEOP(0, yyvsp[-1].pval, newOP(OP_NULL, 0));
}
@@ -1590,467 +1563,501 @@ case 10:
}
expect = XSTATE; }
break;
-case 11:
-#line 126 "perly.y"
+case 13:
+#line 139 "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 144 "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 146 "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 148 "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 150 "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 152 "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 154 "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 158 "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 160 "perly.y"
+{ yyval.opval = scope(yyvsp[0].opval); }
break;
case 22:
-#line 159 "perly.y"
+#line 162 "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"
+#line 169 "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 173 "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 177 "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); }
break;
-case 24:
-#line 167 "perly.y"
+case 26:
+#line 181 "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); }
break;
-case 25:
-#line 174 "perly.y"
-{ yyval.opval = Nullop; }
-break;
-case 26:
-#line 176 "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 188 "perly.y"
+{ yyval.opval = Nullop; }
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 190 "perly.y"
+{ yyval.opval = scope(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 194 "perly.y"
+{ copline = yyvsp[-6].ival;
+ yyval.opval = block_end(yyvsp[-4].ival,
+ newSTATEOP(0, yyvsp[-7].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ 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 200 "perly.y"
+{ copline = yyvsp[-6].ival;
+ yyval.opval = block_end(yyvsp[-4].ival,
+ newSTATEOP(0, yyvsp[-7].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ 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 206 "perly.y"
+{ copline = yyvsp[-3].ival;
+ deprecate("while BLOCK BLOCK");
+ yyval.opval = newSTATEOP(0, yyvsp[-4].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ scope(yyvsp[-2].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 212 "perly.y"
+{ copline = yyvsp[-3].ival;
+ deprecate("until BLOCK BLOCK");
+ yyval.opval = newSTATEOP(0, yyvsp[-4].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ invert(scalar(scope(yyvsp[-2].opval))),
+ yyvsp[-1].opval, yyvsp[0].opval)); }
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 219 "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 34:
-#line 213 "perly.y"
+#line 222 "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 35:
+#line 226 "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 36:
+#line 230 "perly.y"
+{ copline = yyvsp[-9].ival;
+ yyval.opval = block_end(yyvsp[-7].ival,
+ append_elem(OP_LINESEQ, scalar(yyvsp[-6].opval),
+ newSTATEOP(0, yyvsp[-10].pval,
+ newWHILEOP(0, 1, (LOOP*)Nullop,
+ scalar(yyvsp[-4].opval),
+ yyvsp[0].opval, scalar(yyvsp[-2].opval))))); }
+break;
+case 37:
+#line 238 "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"
+case 38:
+#line 244 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 37:
-#line 224 "perly.y"
+case 40:
+#line 249 "perly.y"
{ (void)scan_num("1"); yyval.opval = yylval.opval; }
break;
-case 39:
-#line 229 "perly.y"
+case 42:
+#line 254 "perly.y"
+{ yyval.opval = invert(scalar(yyvsp[0].opval)); }
+break;
+case 43:
+#line 258 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 44:
+#line 262 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 45:
+#line 266 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 46:
+#line 270 "perly.y"
+{ yyval.opval = yyvsp[0].opval; intro_my(); }
+break;
+case 47:
+#line 274 "perly.y"
{ yyval.pval = Nullch; }
break;
-case 41:
-#line 234 "perly.y"
+case 49:
+#line 279 "perly.y"
{ yyval.ival = 0; }
break;
-case 42:
-#line 236 "perly.y"
+case 50:
+#line 281 "perly.y"
{ yyval.ival = 0; }
break;
-case 43:
-#line 238 "perly.y"
+case 51:
+#line 283 "perly.y"
{ yyval.ival = 0; }
break;
-case 44:
-#line 240 "perly.y"
+case 52:
+#line 285 "perly.y"
{ yyval.ival = 0; }
break;
-case 45:
-#line 244 "perly.y"
+case 53:
+#line 289 "perly.y"
{ newFORM(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
-case 46:
-#line 246 "perly.y"
+case 54:
+#line 291 "perly.y"
{ newFORM(yyvsp[-1].ival, Nullop, yyvsp[0].opval); }
break;
-case 47:
-#line 250 "perly.y"
+case 55:
+#line 295 "perly.y"
{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, yyvsp[0].opval); }
break;
-case 48:
-#line 252 "perly.y"
+case 56:
+#line 297 "perly.y"
{ newSUB(yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval, Nullop); expect = XSTATE; }
break;
-case 49:
-#line 256 "perly.y"
+case 57:
+#line 301 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 51:
-#line 261 "perly.y"
+case 59:
+#line 306 "perly.y"
{ yyval.ival = start_subparse(); }
break;
-case 52:
-#line 265 "perly.y"
+case 60:
+#line 310 "perly.y"
{ package(yyvsp[-1].opval); }
break;
-case 53:
-#line 267 "perly.y"
+case 61:
+#line 312 "perly.y"
{ package(Nullop); }
break;
-case 54:
-#line 271 "perly.y"
+case 62:
+#line 316 "perly.y"
{ utilize(yyvsp[-5].ival, yyvsp[-4].ival, yyvsp[-3].opval, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
-case 55:
-#line 275 "perly.y"
+case 63:
+#line 320 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 56:
-#line 277 "perly.y"
+case 64:
+#line 322 "perly.y"
{ yyval.opval = newLOGOP(yyvsp[-1].ival, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 58:
-#line 282 "perly.y"
+case 66:
+#line 327 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
-case 59:
-#line 284 "perly.y"
+case 67:
+#line 329 "perly.y"
{ yyval.opval = append_elem(OP_LIST, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 61:
-#line 289 "perly.y"
+case 69:
+#line 334 "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 70:
+#line 337 "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 71:
+#line 340 "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 72:
+#line 345 "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 73:
+#line 350 "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 74:
+#line 355 "perly.y"
{ yyval.opval = convert(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 67:
-#line 312 "perly.y"
+case 75:
+#line 357 "perly.y"
{ yyval.opval = convert(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
-case 68:
-#line 314 "perly.y"
+case 76:
+#line 359 "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)); }
break;
-case 71:
-#line 325 "perly.y"
+case 79:
+#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 80:
+#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 81:
+#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 82:
+#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 83:
+#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 84:
+#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 85:
+#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 86:
+#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 87:
+#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 88:
+#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 89:
+#line 392 "perly.y"
{ yyval.opval = newLOGOP(OP_AND, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 82:
-#line 349 "perly.y"
+case 90:
+#line 394 "perly.y"
{ yyval.opval = newLOGOP(OP_OR, 0, yyvsp[-2].opval, yyvsp[0].opval); }
break;
-case 83:
-#line 351 "perly.y"
+case 91:
+#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 92:
+#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 93:
+#line 401 "perly.y"
{ yyval.opval = newUNOP(OP_NEGATE, 0, scalar(yyvsp[0].opval)); }
break;
-case 86:
-#line 358 "perly.y"
+case 94:
+#line 403 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 87:
-#line 360 "perly.y"
+case 95:
+#line 405 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
-case 88:
-#line 362 "perly.y"
+case 96:
+#line 407 "perly.y"
{ yyval.opval = newUNOP(OP_COMPLEMENT, 0, scalar(yyvsp[0].opval));}
break;
-case 89:
-#line 364 "perly.y"
+case 97:
+#line 409 "perly.y"
{ yyval.opval = newUNOP(OP_REFGEN, 0, mod(yyvsp[0].opval,OP_REFGEN)); }
break;
-case 90:
-#line 366 "perly.y"
+case 98:
+#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 99:
+#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 100:
+#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 101:
+#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 102:
+#line 423 "perly.y"
{ yyval.opval = localize(yyvsp[0].opval,yyvsp[-1].ival); }
break;
-case 95:
-#line 380 "perly.y"
+case 103:
+#line 425 "perly.y"
{ yyval.opval = sawparens(yyvsp[-1].opval); }
break;
-case 96:
-#line 382 "perly.y"
+case 104:
+#line 427 "perly.y"
{ yyval.opval = sawparens(newNULLLIST()); }
break;
-case 97:
-#line 384 "perly.y"
+case 105:
+#line 429 "perly.y"
{ yyval.opval = newANONLIST(yyvsp[-1].opval); }
break;
-case 98:
-#line 386 "perly.y"
+case 106:
+#line 431 "perly.y"
{ yyval.opval = newANONLIST(Nullop); }
break;
-case 99:
-#line 388 "perly.y"
+case 107:
+#line 433 "perly.y"
{ yyval.opval = newANONHASH(yyvsp[-2].opval); }
break;
-case 100:
-#line 390 "perly.y"
+case 108:
+#line 435 "perly.y"
{ yyval.opval = newANONHASH(Nullop); }
break;
-case 101:
-#line 392 "perly.y"
+case 109:
+#line 437 "perly.y"
{ yyval.opval = newANONSUB(yyvsp[-2].ival, yyvsp[-1].opval, yyvsp[0].opval); }
break;
-case 102:
-#line 394 "perly.y"
+case 110:
+#line 439 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 103:
-#line 396 "perly.y"
+case 111:
+#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 112:
+#line 443 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 105:
-#line 400 "perly.y"
+case 113:
+#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 114:
+#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 115:
+#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 116:
+#line 455 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 109:
-#line 412 "perly.y"
+case 117:
+#line 457 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 110:
-#line 414 "perly.y"
+case 118:
+#line 459 "perly.y"
{ yyval.opval = newUNOP(OP_AV2ARYLEN, 0, ref(yyvsp[0].opval, OP_AV2ARYLEN));}
break;
-case 111:
-#line 416 "perly.y"
+case 119:
+#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 120:
+#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 121:
+#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 122:
+#line 474 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, yyvsp[-4].opval); }
break;
-case 115:
-#line 431 "perly.y"
+case 123:
+#line 476 "perly.y"
{ yyval.opval = newSLICEOP(0, yyvsp[-1].opval, Nullop); }
break;
-case 116:
-#line 433 "perly.y"
+case 124:
+#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 125:
+#line 484 "perly.y"
{ yyval.opval = prepend_elem(OP_HSLICE,
newOP(OP_PUSHMARK, 0),
newLISTOP(OP_HSLICE, 0,
@@ -2058,38 +2065,38 @@ case 117:
ref(oopsHV(yyvsp[-4].opval), OP_HSLICE)));
expect = XOPERATOR; }
break;
-case 118:
-#line 446 "perly.y"
+case 126:
+#line 491 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 119:
-#line 448 "perly.y"
+case 127:
+#line 493 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0, scalar(yyvsp[0].opval)); }
break;
-case 120:
-#line 450 "perly.y"
+case 128:
+#line 495 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, OPf_STACKED, scalar(yyvsp[-2].opval)); }
break;
-case 121:
-#line 452 "perly.y"
+case 129:
+#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 130:
+#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 131:
+#line 503 "perly.y"
{ yyval.opval = newUNOP(OP_DOFILE, 0, scalar(yyvsp[0].opval)); }
break;
-case 124:
-#line 460 "perly.y"
+case 132:
+#line 505 "perly.y"
{ yyval.opval = newUNOP(OP_NULL, OPf_SPECIAL, scope(yyvsp[0].opval)); }
break;
-case 125:
-#line 462 "perly.y"
+case 133:
+#line 507 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
prepend_elem(OP_LIST,
@@ -2098,8 +2105,8 @@ case 125:
scalar(yyvsp[-2].opval)
)),Nullop)); dep();}
break;
-case 126:
-#line 470 "perly.y"
+case 134:
+#line 515 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB,
OPf_SPECIAL|OPf_STACKED,
append_elem(OP_LIST,
@@ -2109,139 +2116,151 @@ case 126:
scalar(yyvsp[-3].opval)
)))); dep();}
break;
-case 127:
-#line 479 "perly.y"
+case 135:
+#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 136:
+#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 137:
+#line 533 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, OPf_SPECIAL);
hints |= HINT_BLOCK_SCOPE; }
break;
-case 130:
-#line 491 "perly.y"
+case 138:
+#line 536 "perly.y"
{ yyval.opval = newLOOPEX(yyvsp[-1].ival,yyvsp[0].opval); }
break;
-case 131:
-#line 493 "perly.y"
+case 139:
+#line 538 "perly.y"
{ yyval.opval = newUNOP(OP_NOT, 0, scalar(yyvsp[0].opval)); }
break;
-case 132:
-#line 495 "perly.y"
+case 140:
+#line 540 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
-case 133:
-#line 497 "perly.y"
+case 141:
+#line 542 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 134:
-#line 499 "perly.y"
+case 142:
+#line 544 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-1].ival, 0, yyvsp[0].opval); }
break;
-case 135:
-#line 501 "perly.y"
+case 143:
+#line 546 "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 144:
+#line 549 "perly.y"
{ yyval.opval = newOP(yyvsp[0].ival, 0); }
break;
-case 137:
-#line 506 "perly.y"
+case 145:
+#line 551 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, 0); }
break;
-case 138:
-#line 508 "perly.y"
+case 146:
+#line 553 "perly.y"
{ yyval.opval = newUNOP(OP_ENTERSUB, 0,
scalar(yyvsp[0].opval)); }
break;
-case 139:
-#line 511 "perly.y"
+case 147:
+#line 556 "perly.y"
{ yyval.opval = newOP(yyvsp[-2].ival, OPf_SPECIAL); }
break;
-case 140:
-#line 513 "perly.y"
+case 148:
+#line 558 "perly.y"
{ yyval.opval = newUNOP(yyvsp[-3].ival, 0, yyvsp[-1].opval); }
break;
-case 141:
-#line 515 "perly.y"
+case 149:
+#line 560 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-3].opval, yyvsp[-1].opval, Nullop); }
break;
-case 142:
-#line 517 "perly.y"
+case 150:
+#line 562 "perly.y"
{ yyval.opval = pmruntime(yyvsp[-5].opval, yyvsp[-3].opval, yyvsp[-1].opval); }
break;
-case 145:
-#line 523 "perly.y"
+case 153:
+#line 568 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 146:
-#line 525 "perly.y"
+case 154:
+#line 570 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 147:
-#line 529 "perly.y"
+case 155:
+#line 574 "perly.y"
{ yyval.opval = Nullop; }
break;
-case 148:
-#line 531 "perly.y"
+case 156:
+#line 576 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-case 149:
-#line 533 "perly.y"
+case 157:
+#line 578 "perly.y"
{ yyval.opval = yyvsp[-1].opval; }
break;
-case 150:
-#line 537 "perly.y"
+case 158:
+#line 581 "perly.y"
+{ yyval.ival = 0; }
+break;
+case 159:
+#line 582 "perly.y"
+{ yyval.ival = 1; }
+break;
+case 160:
+#line 586 "perly.y"
+{ in_my = 0; yyval.opval = my(yyvsp[0].opval); }
+break;
+case 161:
+#line 590 "perly.y"
{ yyval.opval = newCVREF(yyvsp[-1].ival,yyvsp[0].opval); }
break;
-case 151:
-#line 541 "perly.y"
+case 162:
+#line 594 "perly.y"
{ yyval.opval = newSVREF(yyvsp[0].opval); }
break;
-case 152:
-#line 545 "perly.y"
+case 163:
+#line 598 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
-case 153:
-#line 549 "perly.y"
+case 164:
+#line 602 "perly.y"
{ yyval.opval = newHVREF(yyvsp[0].opval); }
break;
-case 154:
-#line 553 "perly.y"
+case 165:
+#line 606 "perly.y"
{ yyval.opval = newAVREF(yyvsp[0].opval); }
break;
-case 155:
-#line 557 "perly.y"
+case 166:
+#line 610 "perly.y"
{ yyval.opval = newGVREF(0,yyvsp[0].opval); }
break;
-case 156:
-#line 561 "perly.y"
+case 167:
+#line 614 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
-case 157:
-#line 563 "perly.y"
+case 168:
+#line 616 "perly.y"
{ yyval.opval = scalar(yyvsp[0].opval); }
break;
-case 158:
-#line 565 "perly.y"
+case 169:
+#line 618 "perly.y"
{ yyval.opval = scope(yyvsp[0].opval); }
break;
-case 159:
-#line 568 "perly.y"
+case 170:
+#line 621 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
-#line 2230 "y_tab.c"
+#line 2249 "perly.c"
}
yyssp -= yym;
yystate = *yyssp;
@@ -2251,7 +2270,7 @@ break;
{
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log,
+ PerlIO_printf(Perl_debug_log,
"yydebug: after reduction, shifting from state 0 to state %d\n",
YYFINAL);
#endif
@@ -2267,7 +2286,7 @@ break;
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
- fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
+ PerlIO_printf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
#endif
@@ -2282,7 +2301,7 @@ break;
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
- fprintf(Perl_debug_log,
+ PerlIO_printf(Perl_debug_log,
"yydebug: after reduction, shifting from state %d to state %d\n",
*yyssp, yystate);
#endif
diff --git a/vms/perly_h.vms b/vms/perly_h.vms
index c6ec3a41ad..dd927648bf 100644
--- a/vms/perly_h.vms
+++ b/vms/perly_h.vms
@@ -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/vms/test.com b/vms/test.com
index 156b2dca81..2afe93cd60 100644
--- a/vms/test.com
+++ b/vms/test.com
@@ -137,6 +137,8 @@ while ($test = shift) {
close(script);
if (/#!..perl(.*)/) {
$switch = $1;
+ # Add "" to protect uppercase switches on command line
+ $switch =~ s/-([A-Z]\S*)/"-$1"/g;
} else {
$switch = '';
}
diff --git a/vms/vms.c b/vms/vms.c
index 9c8fd1f2d1..e13747a06a 100644
--- a/vms/vms.c
+++ b/vms/vms.c
@@ -2,8 +2,8 @@
*
* VMS-specific routines for perl5
*
- * Last revised: 18-Jul-1996 by Charles Bailey bailey@genetics.upenn.edu
- * Version: 5.3.1
+ * Last revised: 14-Oct-1996 by Charles Bailey bailey@genetics.upenn.edu
+ * Version: 5.3.7
*/
#include <acedef.h>
@@ -33,7 +33,11 @@
#include <uaidef.h>
#include <uicdef.h>
-#ifndef SS$_NOSUCHOBJECT /* Older versions of ssdef.h don't have this */
+/* 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
@@ -95,7 +99,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 */
@@ -115,8 +119,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';
@@ -129,9 +134,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},
@@ -147,7 +153,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;
@@ -155,6 +161,68 @@ my_getenv(char *lnm)
} /* end of my_getenv() */
/*}}}*/
+/*{{{ 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 = my_popen("$ Show Logical *","r")) == Nullfp)
+ _ckvmssts(vaxc$errno);
+ /* We use Perl's sv_gets to read from the pipe, since my_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)
@@ -254,6 +322,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);
@@ -285,7 +354,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};
@@ -306,20 +375,42 @@ 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$_FNM:
+ 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;
}
@@ -349,7 +440,7 @@ kill_file(char *name)
* 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 (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
if (aclsts & 1) aclsts = fndsts;
if (!(aclsts & 1)) {
set_errno(EVMSERR);
@@ -545,7 +636,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 */
@@ -625,7 +716,7 @@ my_popen(char *cmd, char *mode)
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));
@@ -673,7 +764,29 @@ I32 my_pclose(FILE *fp)
/* get here => no such pipe open */
croak("No such pipe open");
- 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);
@@ -759,6 +872,108 @@ 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_rmsexpand(char *filespec, char *outbuf, int ts, char *defspec, unsigned opts)
+{
+ static char __rmsexpand_retbuf[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;
+
+ if (!filespec || !*filespec) {
+ set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
+ return NULL;
+ }
+ if (!outbuf) {
+ if (ts) out = New(7019,outbuf,NAM$C_MAXRSS+1,char);
+ else outbuf = __rmsexpand_retbuf;
+ }
+
+ myfab.fab$l_fna = filespec;
+ myfab.fab$b_fns = strlen(filespec);
+ myfab.fab$l_nam = &mynam;
+
+ if (defspec && *defspec) {
+ 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? */
+ if (!mynam.nam$b_rsl) strcpy(outbuf,esa);
+ 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.
@@ -1659,7 +1874,7 @@ getredirection(int *ac, char ***av)
{
if (j+1 >= argc)
{
- fprintf(Perl_debug_log,"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];
@@ -1674,7 +1889,7 @@ getredirection(int *ac, char ***av)
{
if (j+1 >= argc)
{
- fprintf(Perl_debug_log,"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];
@@ -1694,7 +1909,7 @@ getredirection(int *ac, char ***av)
out = 1 + ap;
if (j >= argc)
{
- fprintf(Perl_debug_log,"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;
@@ -1716,7 +1931,7 @@ getredirection(int *ac, char ***av)
err = 2 + ap;
if (j >= argc)
{
- fprintf(Perl_debug_log,"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;
@@ -1725,7 +1940,7 @@ getredirection(int *ac, char ***av)
{
if (j+1 >= argc)
{
- fprintf(Perl_debug_log,"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);
@@ -1756,7 +1971,7 @@ getredirection(int *ac, char ***av)
{
if (out != NULL)
{
- fprintf(Perl_debug_log,"'|' 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);
@@ -1775,7 +1990,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);
@@ -1789,25 +2004,25 @@ getredirection(int *ac, char ***av)
freopen(mbxname, "rb", stdin);
if (errno != 0)
{
- fprintf(Perl_debug_log,"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(Perl_debug_log,"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(Perl_debug_log,"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(Perl_debug_log,"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);
@@ -1817,9 +2032,9 @@ getredirection(int *ac, char ***av)
}
}
#ifdef ARGPROC_DEBUG
- fprintf(Perl_debug_log, "Arglist:\n");
+ PerlIO_printf(Perl_debug_log, "Arglist:\n");
for (j = 0; j < *ac; ++j)
- fprintf(Perl_debug_log, "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 */
@@ -1950,7 +2165,7 @@ short iosb[4];
if (0 == child_st[0])
{
#ifdef ARGPROC_DEBUG
- fprintf(Perl_debug_log, "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> */
@@ -1965,7 +2180,7 @@ short iosb[4];
static void sig_child(int chan)
{
#ifdef ARGPROC_DEBUG
- fprintf(Perl_debug_log, "Child Completion AST\n");
+ PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
#endif
if (child_st[0] == 0)
child_st[0] = 1;
@@ -2001,19 +2216,19 @@ static void pipe_and_fork(char **cmargv)
create_mbx(&child_chan,&mbxdsc);
#ifdef ARGPROC_DEBUG
- fprintf(Perl_debug_log, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
- fprintf(Perl_debug_log, "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_noperl(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
0, &pid, child_st, &zero, sig_child,
&child_chan));
#ifdef ARGPROC_DEBUG
- fprintf(Perl_debug_log, "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(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
+ PerlIO_printf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
}
}
@@ -2047,10 +2262,10 @@ unsigned long int flags = 17, one = 1, retsts;
_ckvmssts_noperl(retsts);
}
#ifdef ARGPROC_DEBUG
- fprintf(Perl_debug_log, "%s\n", command);
+ PerlIO_printf(Perl_debug_log, "%s\n", command);
#endif
sprintf(pidstring, "%08X", pid);
- fprintf(Perl_debug_log, "%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);
@@ -2935,7 +3150,7 @@ struct tm *
my_gmtime(const time_t *time)
{
static int gmtime_emulation_type;
- static time_t utc_offset_secs;
+ static long int utc_offset_secs;
char *p;
time_t when;
@@ -2947,7 +3162,7 @@ my_gmtime(const time_t *time)
if ((p = my_getenv("SYS$TIMEZONE_DIFFERENTIAL")) == NULL)
gmtime_emulation_type++;
else
- utc_offset_secs = (time_t) atol(p);
+ utc_offset_secs = atol(p);
}
}
@@ -3173,10 +3388,13 @@ cando_by_name(I32 bit, I32 effective, char *fname)
}
retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
- 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) {
@@ -3224,10 +3442,8 @@ 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 (is_null_device(fspec)) { /* Fake a stat() for the null device */
memset(statbufp,0,sizeof *statbufp);
@@ -3240,22 +3456,19 @@ 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;
- strcpy(namecache,fileified);
- }
+ /* 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 == &statcache) strcpy(namecache,fileified);
}
+ if (retval) retval = stat(fspec,(stat_t *) statbufp);
if (!retval) statbufp->st_dev = encode_dev(statbufp->st_devnam);
return retval;
@@ -3498,63 +3711,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;
-
- if (items > 2) croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
+ char *fspec, *defspec = NULL, *rslt;
- myfab.fab$l_fna = SvPV(ST(0),speclen);
- myfab.fab$b_fns = speclen;
- myfab.fab$l_nam = &mynam;
-
- if (items == 2) {
- myfab.fab$l_dna = SvPV(ST(1),speclen);
- myfab.fab$b_dns = speclen;
- }
+ 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);
- mynam.nam$l_esa = esa;
- mynam.nam$b_ess = sizeof esa;
- mynam.nam$l_rsa = rsa;
- mynam.nam$b_rss = sizeof rsa;
-
- retsts = sys$parse(&myfab,0,0);
- if (!(retsts & 1)) {
- if (retsts == RMS$_DNF) {
- mynam.nam$b_nop |= NAM$M_SYNCHK;
- retsts = sys$parse(&myfab,0,0);
- if (retsts & 1) goto expanded;
- }
- 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. */
- expanded:
- 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);
-
- 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
@@ -3724,7 +3892,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/vms/vmsish.h b/vms/vmsish.h
index 36bfaff580..b2814ade8b 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -15,12 +15,12 @@
#include <ssdef.h> /* explicitly set in the perl source code */
/* 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() */
@@ -51,17 +51,24 @@
#include <unixio.h>
#include <unixlib.h>
#include <file.h> /* it's not <sys/file.h>, so don't use I_SYS_FILE */
+#ifdef __DECC
+# include <unistd.h> /* DECC has this; VAXC and gcc don't */
+#endif
/* 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_gconvert Perl_my_gconvert
# define do_rmdir Perl_do_rmdir
# define kill_file Perl_kill_file
# 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
@@ -230,6 +237,11 @@
/* 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 {
@@ -251,6 +263,9 @@ struct utimbuf {
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
@@ -397,6 +412,10 @@ typedef unsigned myino_t;
* __VMS_PROTOTYPES__ and __VMS_SEPYTOTORP__ lines, and must be in the form
* <data type><TAB>name<WHITESPACE>_((<prototype args>));
*/
+
+void prime_env_iter _((void));
+void getredirection _((int *, char ***));
+void init_os_extras _(());
/* prototype section start marker; `typedef' passes through cpp */
typedef char __VMS_PROTOTYPES__;
int my_trnlnm _((char *, char *, unsigned long int));
@@ -407,6 +426,8 @@ char * my_gconvert _((double, int, int, char *));
int do_rmdir _((char *));
int kill_file _((char *));
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 *));
@@ -426,7 +447,6 @@ 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 *));
I32 cando_by_name _((I32, I32, char *));
int flex_fstat _((int, struct stat *));
@@ -445,7 +465,6 @@ 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 */
diff --git a/writemain.SH b/writemain.SH
index 66d14a16ce..f07c682faf 100755
--- a/writemain.SH
+++ b/writemain.SH
@@ -84,7 +84,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
@@ -92,7 +91,6 @@ if test X"$args" != "X" ; then
else
echo " newXS(\"${mname}::bootstrap\", boot_${cname}, file);"
fi
- echo " }"
done
fi
diff --git a/x2p/Makefile.SH b/x2p/Makefile.SH
index e12a2de73f..27345f0e8a 100644..100755
--- a/x2p/Makefile.SH
+++ b/x2p/Makefile.SH
@@ -14,33 +14,38 @@ 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
-: ${bin_sh=/bin/sh}
-
echo "Extracting x2p/Makefile (with variable substitutions)"
rm -f Makefile
cat >Makefile <<!GROK!THIS!
-# $RCSfile: Makefile.SH,v $$Revision: 4.1 $$Date: 1996/07/05 23:49:56 $
+# $RCSfile: Makefile.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:07 $
#
# $Log: Makefile.SH,v $
-# Revision 1.2 1996/07/05 23:49:56 gerti
-# OPENSTEP 4.0 patches
-#
CC = $cc
BYACC = $byacc
LDFLAGS = $ldflags
SMALL = $small
LARGE = $large $split
-MAB = $mab
mallocsrc = $mallocsrc
mallocobj = $mallocobj
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
@@ -53,9 +58,6 @@ FIRSTMAKEFILE = $firstmakefile
.SUFFIXES: .c \$(OBJ_EXT)
-# grrr
-SHELL = $bin_sh
-
!GROK!THIS!
cat >>Makefile <<'!NO!SUBS!'
@@ -78,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
@@ -86,14 +88,15 @@ obj = hash$(OBJ_EXT) $(mallocobj) str$(OBJ_EXT) util$(OBJ_EXT) walk$(OBJ_EXT)
lintflags = -phbvxac
+
.c$(OBJ_EXT):
- $(CCCMD) $(MAB) $*.c
+ $(CCCMD) -DPERL_FOR_X2P $*.c
all: $(public) $(private) $(util)
touch all
a2p: $(obj) a2p$(OBJ_EXT)
- $(CC) $(MAB) $(LDFLAGS) $(obj) a2p$(OBJ_EXT) $(libs) -o a2p
+ $(CC) $(LDFLAGS) $(obj) a2p$(OBJ_EXT) $(libs) -o a2p
# I now supply a2p.c with the kits, so the following section is
# used only if you force byacc to run by saying
@@ -109,8 +112,9 @@ 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
- $(CCCMD) $(LARGE) $(MAB) 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
+ $(CCCMD) $(LARGE) a2p.c
clean:
rm -f a2p *$(OBJ_EXT)
diff --git a/x2p/a2p.c b/x2p/a2p.c
index c6d21e3e4d..22b75a0734 100644
--- a/x2p/a2p.c
+++ b/x2p/a2p.c
@@ -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,
- 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, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 257, 258, 259, 260, 261, 262, -1,
+ -1, 265, -1, -1, -1, -1, -1, -1, -1, -1,
+ 274, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, 285, -1, -1, 288, 289, 290, -1, -1, -1,
+ -1, 295, 296, -1, -1, -1, 300, -1, -1, -1,
+ -1, 257, 258, 259, 260, 261, 262, -1, 7, 265,
+ -1, -1, -1, -1, -1, 14, -1, -1, 274, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, 285,
+ 29, -1, 288, 289, 290, -1, 35, -1, -1, -1,
+ -1, -1, -1, -1, 300, -1, -1, -1, -1, -1,
+ 49, 50, 51, -1, -1, -1, 55, 56, -1, 58,
+ 59, 60, -1, 62, 63, 64, 65, 66, -1, -1,
+ -1, -1, -1, -1, -1, 40, -1, -1, 43, -1,
+ 45, -1, -1, 82, -1, -1, 85, 86, 87, 88,
+ 89, 90, -1, -1, 59, -1, -1, -1, -1, -1,
+ -1, 100, -1, -1, -1, -1, -1, -1, -1, 108,
+ -1, -1, -1, -1, -1, -1, 115, -1, -1, -1,
+ 40, -1, 121, 43, -1, 45, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 136, 137, 59,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 123, -1,
+ 159, 160, -1, -1, 163, 164, 165, 166, 167, -1,
+ -1, -1, -1, 172, 173, 40, 175, 176, 43, -1,
+ 45, 180, -1, -1, -1, 184, -1, -1, -1, -1,
+ -1, -1, -1, -1, 59, -1, 195, -1, -1, 198,
+ -1, -1, -1, 123, -1, 125, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, 217, 218,
+ 219, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, -1, -1, 236, -1, 238,
+ -1, 240, -1, 242, -1, 244, -1, -1, -1, 40,
+ 249, -1, 43, -1, 45, 254, 255, -1, 123, -1,
+ 125, -1, -1, 262, -1, -1, -1, -1, 59, -1,
+ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, 282, -1, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 260, 261, 262, 263, 264,
+ 299, 266, 267, 268, 269, 270, -1, 272, 273, -1,
+ 275, 276, 277, 278, 279, 280, 281, 282, 283, 284,
+ -1, 286, 287, -1, -1, -1, 291, 292, 293, 294,
+ -1, -1, 123, 298, 125, -1, 301, 302, 303, 304,
+ 260, -1, -1, 263, 264, -1, 266, 267, 268, 269,
+ 270, 271, 272, 273, -1, 275, 276, 277, 278, 279,
+ 280, 281, 282, 283, 284, -1, 286, 287, -1, -1,
+ -1, 291, 292, 293, 294, -1, -1, -1, 298, -1,
+ -1, 301, 302, 303, 304, -1, -1, -1, -1, -1,
+ -1, -1, -1, -1, -1, 260, -1, -1, 263, 264,
-1, 266, 267, 268, 269, 270, 271, 272, 273, -1,
275, 276, 277, 278, 279, 280, 281, 282, 283, 284,
-1, 286, 287, -1, -1, -1, 291, 292, 293, 294,
- 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",
@@ -1941,7 +2001,7 @@ YYSTYPE yyvs[YYSTACKSIZE];
#define yystacksize YYSTACKSIZE
#line 396 "a2p.y"
#include "a2py.c"
-#line 1945 "y.tab.c"
+#line 2005 "y.tab.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
@@ -2196,6 +2256,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 +2267,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 +2667,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 2671 "y.tab.c"
}
yyssp -= yym;
yystate = *yyssp;
diff --git a/x2p/a2p.h b/x2p/a2p.h
index f145e72bf6..a6dfd1d2ad 100644
--- a/x2p/a2p.h
+++ b/x2p/a2p.h
@@ -1,4 +1,4 @@
-/* $RCSfile: a2p.h,v $$Revision: 4.1 $$Date: 1996/07/05 23:49:58 $
+/* $RCSfile: a2p.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:09 $
*
* Copyright (c) 1991, Larry Wall
*
@@ -6,12 +6,8 @@
* License or the Artistic License, as specified in the README file.
*
* $Log: a2p.h,v $
- * Revision 1.2 1996/07/05 23:49:58 gerti
- * OPENSTEP 4.0 patches
- *
*/
-#include "../embed.h"
#define VOIDUSED 1
#include "../config.h"
@@ -34,7 +30,6 @@
# include <sys/types.h>
#endif
-
#ifdef USE_NEXT_CTYPE
#if NX_CURRENT_COMPILER_RELEASE >= 400
@@ -49,6 +44,15 @@
#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
@@ -108,7 +112,11 @@ char *strchr(), *strrchr();
char *strcpy(), *strcat();
#endif /* ! STANDARD_C */
-#include "handy.h"
+#include "../handy.h"
+
+#undef Nullfp
+#define Nullfp Null(FILE*)
+
#define Nullop 0
#define OPROG 1
diff --git a/x2p/a2p.man b/x2p/a2p.man
deleted file mode 100644
index f74e596ed2..0000000000
--- a/x2p/a2p.man
+++ /dev/null
@@ -1,183 +0,0 @@
-.rn '' }`
-''' $RCSfile: a2p.man,v $$Revision: 4.1 $$Date: 92/08/07 18:29:10 $
-'''
-''' $Log: a2p.man,v $
-.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/x2p/a2p.pod b/x2p/a2p.pod
new file mode 100644
index 0000000000..4e61fd6ab9
--- /dev/null
+++ b/x2p/a2p.pod
@@ -0,0 +1,156 @@
+=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.
+
+=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. 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.
+
+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/x2p/a2p.y b/x2p/a2p.y
index 961e2f280f..6dd340c1df 100644
--- a/x2p/a2p.y
+++ b/x2p/a2p.y
@@ -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
diff --git a/x2p/a2py.c b/x2p/a2py.c
index 454e2dc860..0c37b6bbf9 100644
--- a/x2p/a2py.c
+++ b/x2p/a2py.c
@@ -154,7 +154,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");
diff --git a/x2p/cflags.SH b/x2p/cflags.SH
index a781a7302e..62bd11c9d9 100644..100755
--- a/x2p/cflags.SH
+++ b/x2p/cflags.SH
@@ -14,7 +14,14 @@ 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.
@@ -75,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/x2p/find2perl.PL b/x2p/find2perl.PL
index 32f78fe23f..c024faf9fd 100644
--- a/x2p/find2perl.PL
+++ b/x2p/find2perl.PL
@@ -25,10 +25,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 +242,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/x2p/handy.h b/x2p/handy.h
deleted file mode 100644
index 0049a1108b..0000000000
--- a/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/x2p/proto.h b/x2p/proto.h
new file mode 100644
index 0000000000..eb5fb15b37
--- /dev/null
+++ b/x2p/proto.h
@@ -0,0 +1,8 @@
+/* proto.h
+ *
+ * Copyright (c) 1991-1996, 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/x2p/s2p.PL b/x2p/s2p.PL
index 29864b418a..e5c5bd6f01 100644
--- a/x2p/s2p.PL
+++ b/x2p/s2p.PL
@@ -25,10 +25,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 +40,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 +367,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/x2p/s2p.man b/x2p/s2p.man
deleted file mode 100644
index ae4611613f..0000000000
--- a/x2p/s2p.man
+++ /dev/null
@@ -1,92 +0,0 @@
-.rn '' }`
-''' $RCSfile: s2p.man,v $$Revision: 4.1 $$Date: 92/08/07 18:29:24 $
-'''
-''' $Log: s2p.man,v $
-.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/x2p/str.c b/x2p/str.c
index 64304a70de..953a811f50 100644
--- a/x2p/str.c
+++ b/x2p/str.c
@@ -317,11 +317,7 @@ register FILE *fp;
FILE_cnt(fp) = cnt; /* deregisterize cnt and ptr */
FILE_ptr(fp) = ptr;
-#if defined(__Lynx__)
- i = _fillbuf(fp); /* get more characters */
-#else
- i = _filbuf(fp); /* get more characters */
-#endif
+ i = FILE_filbuf(fp); /* get more characters */
cnt = FILE_cnt(fp);
ptr = FILE_ptr(fp); /* reregisterize cnt and ptr */
diff --git a/x2p/util.c b/x2p/util.c
index 5c3554b7e3..519fae5a8a 100644
--- a/x2p/util.c
+++ b/x2p/util.c
@@ -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,10 +27,10 @@ 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);
@@ -45,14 +48,13 @@ 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++);
@@ -70,9 +72,9 @@ MEM_SIZE size;
/* safe version of free */
-void
+Free_t
safefree(where)
-char *where;
+Malloc_t where;
{
#ifdef DEBUGGING
if (debug & 128)
@@ -189,32 +191,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/x2p/util.h b/x2p/util.h
index 35f796121c..bdd85c199d 100644
--- a/x2p/util.h
+++ b/x2p/util.h
@@ -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));