#!/bin/sh
#
# This is my patch _01 to perl5.003.
#
# This patch contains the last few months' worth of bugfixes and
# additions, since the patch to version 5.003 was deliberately kept
# small. A summary of major revisions and additions can be found
# in the diff of the Changes file from the standard distribution,
# which is the first diff in the patch below.
#
# The detailed changes to each file are described at the head of the diff
# for that file, on lines beginning with #~, so you can extract the
# comments by saying perl -ne 'print if /^(?:#~|diff)/'.
#
# This patch is a series of context diffs, since some people have
# mentioned that their copy of patch can't handle unidiffs.
# Please apply it to a clean copy of perl5.003 using patch -p1 -N.
# Before applying the patch, please execute the following commands,
# or their moral equivalent; you may feed this patch to /bin/sh in
# order to do so.
#
# Enjoy.
#
# Charles Bailey <bailey@genetics.upenn.edu>
# July 31, 1996
# The code for the Safe extension has been subsumed into the Opcode extension,
# though the calling sequence hasn't changed
rm -rf ext/Safe
rm -f t/lib/safe.t
# Removed due to copyright notice. Text documentation is supplied.
rm -f ext/SDBM_File/sdbm/readme.ps
# Changes subsumed into new version of DB_File
rm -f os2/diff.db_file
# Moved to main source directory as README.os2
rm -f os2/README
exit 0
## Start of patch ##
#~ Note major changes for releases 5.002_01 through 5.003_01
diff -Pcr perl5_003/Changes perl5_003_01/Changes
*** perl5_003/Changes Mon Mar 25 01:04:00 1996
--- perl5_003_01/Changes Tue Jul 30 17:03:35 1996
***************
*** 1,3 ****
--- 1,280 ----
+ 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,
+ 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_01
+ ----------------
+
+ Version 5.003_01 contains bugfixes and additions accumulated since
+ version 5.002_01, since the patch to version 5.003 was deliberately
+ kept simple. In addition to numerous small bugfixes in the core,
+ library files, and documentation, this patch contains several
+ significant revisions, summarized below:
+
+ o Visible Changes to Core Functionality
+
+ - A port to Plan9 has been started, and changes are integrated into
+ the standard distribution. As of this release, the Perl core
+ and several common extensions are working.
+
+ - A set of basic methods in the UNIVERSAL class have been added to
+ the Perl core. Since UNIVERSAL is an implicit member of every
+ class's @ISA, the methods can be called via any object.
+
+ - A mandatory warning has been added for 'declarations' of lexical
+ variables using the "my" operator which mask an existing lexical
+ variable declared in the same scope, making the previous variable
+ inaccessible by its name.
+
+ - The "use" and "require" operators have been extended to allow
+ checking of the required module's version. The "use" operator
+ can now be used for an immediate version check of Perl itself.
+
+ - A new "strict" pragma, "strict untie", has been added, which
+ produces an error if a tied value is untied when other references
+ exist to the internal object implementing the tie.
+
+ - Barewords used as associative array keys (i.e. when specifying
+ an associative array element like $foo{__BAR} or on the left
+ side of the => operator) may now begin with an underscore as
+ well as an alphabetic character.
+
+ - Some of the configuration information previously produced by the
+ -v switch has been moved to the -V switch, in order to keep -v
+ output concise.
+
+ o Changes in Core Internals
+
+ - Symbol table and method lookups have been made faster.
+
+ - Perl subroutines which just return a constant value are now
+ optimized at compile time into inline constants.
+
+ - Management of keys for associative arrays has been improved to
+ conserve space when the same keys are reused frequently, and
+ to pass true Perl values to tie functions, instead of stringified
+ representations.
+
+ - Messages normally output to stderr may be directed to another
+ stream when Perl is built. This allows some platforms to
+ present diagnostic output in a separate window from normal
+ program results.
+
+ - A bug which caused suiperl to fail silently, albeit securely,
+ in version 5.003 on some systems has been fixed.
+
+ - Management of Unix-style signal handlers via the %SIG associative
+ array has been made safer.
+
+ - Several global C symbols have been renamed to eliminate collisions
+ with system C header files or libraries on some platforms.
+ Unfortunately, this means that dynamic extensions compiled under
+ previous versions of Perl will need to be rebuilt for Perl
+ 5.003_01. We're in the process of cleaning up Perl's C
+ namespace to make it easier to link Perl with other binaries,
+ so this will probably happen again between now and version 5.004.
+ After that, we'll do our best to maintain binary compatibility
+ between versions.
+
+ - An alternate allocation strategy has been added to Perl's
+ optional private memory management routines. This strategy,
+ which may be selected when Perl is built, is designed to
+ conserve memory in programs which allocate many small
+ chunks of memory with sizes near a power of 2, as is often
+ the case in Perl programs.
+
+ - Several memory leaks in the creation and destruction of
+ multiple interpreters have been fixed.
+
+ o Changes in the Standard Library and Utilities
+
+ - The Opcode extension, which allows you to control a program's
+ access to Perl operations, has been added to the standard
+ distribution. This extends the work begun in the original
+ Safe extension, and subsumes it. The Safe interface is still
+ available.
+
+ - The IO extension, which provides a set of classes for object-
+ oriented handling of common I/O tasks, has been added to the
+ standard distribution. The IO classes will form the basis
+ for future development of Perl's I/O interface, and will
+ subsume the FileHandle class in the near future. The default
+ class to which all Perl I/O handles belong is now IO::Handle,
+ rather than FileHandle.
+
+ - The ExtUtils::Embed library module, which provides a set
+ of utility function to help in embedding Perl in other
+ applications, has been added to the standard distribution.
+
+ - The Fatal library module, which provides a simple interface
+ for creating "do-or-die" equivalents of existing functions,
+ has been added to the standard distribution.
+
+ - The FindBin library module, which determines the full path
+ to the currently executing program, has been added to the
+ standard distribution.
+
+ - The DB_File extension, and the Getopt::Long, Test::Harness,
+ Text::Tabs, Text::Wrap, Time::Local and sigtrap library modules
+ have been updated to the authors' latest versions.
+
+ - The Carp library module now considers the @ISA chain when
+ determining the caller's package for inclusion in error messages.
+
+ - The h2xs, perlbug, and xsubpp utilities have been updated.
+
+ - The standard Perl debugger has been updated, and the information
+ provided to the debugger when an XSUB is called has been improved,
+ making it possible for alternate debuggers (such as Devel::DProf)
+ to do a better job of tracking XSUB calls.
+
+ - The pod documentation formatting tools in the standard distribution
+ can now handle characters in the input stream whose high bit is set.
+
+ - The cperl-mode EMACS editing mode has been updated.
+
+ o Changes in Documentation
+
+ - Typographic and formatting errors have been corrected in the pod
+ documentation for the core and standard library files
+
+ - Explanations of several core operators have been improved
+
+ - The perldebug, perlembed, perlipc, perlsec, and perltrap documents
+ extensively revised.
+
+ o Changes in OS-specific and Build-time Support
+
+ - Support for the NeXT platform has been extended through
+ NeXTSTEP/OPENSTEP 4.0, and now includes the ability to create MABs.
+
+ - Support for OS/2 has been extended as well, and now includes
+ options for building a.out binaries.
+
+ - Support for VMS has also been extended, incorporating improved
+ processing of file specification strings, optional suppression of
+ carriage control interpretation for record-structured files,
+ improved support for the -S command line switch, a number of
+ VMS-specific bugfixes, and significantly improved performance
+ in line-oriented reading of files.
+
+ - Several hints files have been added or updated: aux.sh (updated),
+ convexos.sh (updated), irix_4.sh (updated), irix_5.sh (updated),
+ irix_6_2.sh (updated), next_3.sh (updated), next_3_2.sh (new),
+ next_3_3.sh (new), next_4.sh (new), os2/sh (updated),
+ sco.sh (updated), and solaris_2.sh (updated).
+
+ - The test driver for the regression tests now reports when a set
+ of tests have been skipped (presumable because the operation
+ they're designed to test isn't supported on the current system).
+
+ -------------
+ 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
-------------
#~ Added MAB support for Next
#~ Correct recognition of irix 6
#~ Use C locale when obtaining Perl version for arch-dependent dir names
#~ Insure that config.sh is writeable
#~ Improve test for broken gconvert()
#~ Set cc and ld switches properly for shared libraries under linux and irix
#~ Correct dynamic loading test so that $dlext=o doesn't break it
diff -Pcr perl5_003/Configure perl5_003_01/Configure
*** perl5_003/Configure Mon Mar 25 01:04:01 1996
--- perl5_003_01/Configure Thu Jul 18 16:01:50 1996
***************
*** 231,236 ****
--- 231,237 ----
gccversion=''
ccflags=''
cppflags=''
+ mab=''
ldflags=''
lkflags=''
locincpth=''
***************
*** 1638,1644 ****
*) osvers="$3" ;;
esac
;;
! irix) osname=irix
case "$3" in
4*) osvers=4 ;;
5*) osvers=5 ;;
--- 1639,1645 ----
*) osvers="$3" ;;
esac
;;
! irix*) osname=irix
case "$3" in
4*) osvers=4 ;;
5*) osvers=5 ;;
***************
*** 1857,1862 ****
--- 1858,1864 ----
tmp_c="$c"
cd ..
cp $config_sh config.sh 2>/dev/null
+ chmod +w config.sh
. ./config.sh
cd UU
cp ../config.sh .
***************
*** 2331,2337 ****
set dflt
eval $prefixup
;;
! *) version=`echo $baserev $patchlevel $subversion | \
$awk '{print $1 + $2/1000.0 + $3/100000.0}'`
dflt="$privlib/$archname/$version"
;;
--- 2333,2340 ----
set dflt
eval $prefixup
;;
! *) version=`LC_ALL=C;export LC_ALL;\
! echo $baserev $patchlevel $subversion | \
$awk '{print $1 + $2/1000.0 + $3/100000.0}'`
dflt="$privlib/$archname/$version"
;;
***************
*** 4621,4626 ****
--- 4624,4633 ----
#endif
main() {
char buf[64];
+ /* This test must come first. <AlanBurlison@unn.unisys.com> */
+ Gconvert(0.1, 8, 0, buf);
+ if (buf[0] != '.' || buf[1] != '1' || buf[2] != '\0')
+ exit(1);
Gconvert(1.0, 8, 0, buf);
if (buf[0] != '1' || buf[1] != '\0')
exit(1);
***************
*** 5388,5393 ****
--- 5395,5401 ----
hpux) dflt='+z' ;;
next) dflt='none' ;;
solaris|svr4*|esix*) dflt='-Kpic' ;;
+ irix*) dflt='-KPIC' ;;
sunos) dflt='-pic' ;;
*) dflt='none' ;;
esac ;;
***************
*** 5455,5461 ****
case "$lddlflags" in
'') case "$osname" in
hpux) dflt='-b' ;;
! linux) dflt='-shared' ;;
next) dflt='none' ;;
solaris) dflt='-G' ;;
sunos) dflt='-assert nodefinitions' ;;
--- 5463,5469 ----
case "$lddlflags" in
'') case "$osname" in
hpux) dflt='-b' ;;
! linux|irix*) dflt='-shared' ;;
next) dflt='none' ;;
solaris) dflt='-G' ;;
sunos) dflt='-assert nodefinitions' ;;
***************
*** 5646,5652 ****
}
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
--- 5654,5661 ----
}
EOM
if $cc $ccflags $cccdlflags -c dyna.c > /dev/null 2>&1 &&
! mv dyna.o tmp-dyna.o > /dev/null 2>&1 &&
! $ld $lddlflags -o dyna.$dlext tmp-dyna.o > /dev/null 2>&1 &&
$cc $ccflags $ldflags $cccdlflags $ccdlflags fred.c -o fred $libs > /dev/null 2>&1; then
xxx=`./fred`
case $xxx in
***************
*** 5664,5670 ****
;;
esac
! $rm -f fred fred.? dyna.$dlext dyna.?
set d_dlsymun
eval $setvar
--- 5673,5679 ----
;;
esac
! $rm -f fred fred.? dyna.$dlext dyna.? tmp-dyna.?
set d_dlsymun
eval $setvar
***************
*** 9262,9267 ****
--- 9271,9277 ----
lpr='$lpr'
ls='$ls'
lseektype='$lseektype'
+ mab='$mab'
mail='$mail'
mailx='$mailx'
make='$make'
#~ Point non-Unix users to OS-specific READMEs
#~ Use correct -B values for gcc under Solaris
#~ Include minor pod format fixes
#~ Mention h2ph
#~ Revise notes about multiple versions coexisting
diff -Pcr perl5_003/INSTALL perl5_003_01/INSTALL
*** perl5_003/INSTALL Mon Jun 24 16:07:53 1996
--- perl5_003_01/INSTALL Wed Jul 10 11:51:42 1996
***************
*** 18,24 ****
proceeding. Special notes specific to this release are identified
by B<NOTE>.
! =head1 BUILDING PERL5
=head1 Start with a Fresh Distribution.
--- 18,31 ----
proceeding. Special notes specific to this release are identified
by B<NOTE>.
! 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
!
! The following is the procedures you need to follow in order to successfully
! build perl.
=head1 Start with a Fresh Distribution.
***************
*** 351,357 ****
All the installation questions have been moved to the top, so you don't
have to wait for them. Once you've handled them (and your C compiler &
! flags) you can type '&-d' at the next Configure prompt and Configure
will use the defaults from then on.
If you find yourself trying obscure command line incantations and
--- 358,364 ----
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
will use the defaults from then on.
If you find yourself trying obscure command line incantations and
***************
*** 539,545 ****
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.
--- 546,552 ----
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.
***************
*** 583,588 ****
--- 590,596 ----
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
=head1 make install
***************
*** 662,673 ****
to generate the LaTeX versions.
=head1 Coexistence with earlier versions of perl5.
! You can safely install the current version of perl5 and still run
! scripts under the old binaries. Instead of starting your script with
! #!/usr/local/bin/perl, just start it with #!/usr/local/bin/perl5.001
! (or whatever version you want to run.)
The architecture-dependent files are stored in a version-specific
directory (such as F</usr/local/lib/perl5/sun4-sunos/5.002>) so that
--- 670,701 ----
to generate the LaTeX versions.
+ =head1 cd /usr/include; h2ph *.h sys/*.h
+
+ Some of the perl library files need to be able to obtain information from
+ the system header files. This command will convert the most commonly used
+ header files in F</usr/include> into files that can be easily interpreted
+ by perl. These files will be placed in architectural library directory
+ you specified to B<Configure>; by default this is
+ F</usr/local/lib/perl5/ARCH/VERSION>, where B<ARCH> is your architecture
+ (such as C<sun4-solaris>) and B<VERSION> is the version of perl you are
+ 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
+ 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
! 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
! need to install the current version in a separate directory tree,
! since some of the architecture-independent library files have changed
! in incompatible ways.
The architecture-dependent files are stored in a version-specific
directory (such as F</usr/local/lib/perl5/sun4-sunos/5.002>) so that
***************
*** 678,684 ****
files.
The standard library files in F</usr/local/lib/perl5>
! should be useable 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
--- 706,712 ----
files.
The standard library files in F</usr/local/lib/perl5>
! should be useable by all versions of perl5 since perl5.002.
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
***************
*** 740,743 ****
=head1 LAST MODIFIED
! 19 March 1996
--- 768,771 ----
=head1 LAST MODIFIED
! 07 July 1996
#~ Update to reflect current contents of kit
diff -Pcr perl5_003/MANIFEST perl5_003_01/MANIFEST
*** perl5_003/MANIFEST Mon Mar 25 01:04:56 1996
--- perl5_003_01/MANIFEST Mon Jul 29 19:41:20 1996
***************
*** 10,16 ****
MANIFEST This list of files
Makefile.SH A script that generates Makefile
README The Instructions
! README.vms Notes about VMS
Todo The Wishlist
XSUB.h Include file for extension subroutines
av.c Array value code
--- 10,18 ----
MANIFEST This list of files
Makefile.SH A script that generates Makefile
README The Instructions
! README.os2 Notes about OS/2 port
! README.plan9 Notes about Plan9 port
! README.vms Notes about VMS port
Todo The Wishlist
XSUB.h Include file for extension subroutines
av.c Array value code
***************
*** 87,93 ****
ext/DynaLoader/dl_hpux.xs HP-UX implementation
ext/DynaLoader/dl_next.xs Next implementation
ext/DynaLoader/dl_none.xs Stub implementation
! ext/DynaLoader/dl_os2.xs OS/2 implementation
ext/DynaLoader/dl_vms.xs VMS implementation
ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files
ext/Fcntl/Fcntl.pm Fcntl extension Perl module
--- 89,95 ----
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_vms.xs VMS implementation
ext/DynaLoader/dlutils.c Dynamic loader utilities for dl_*.xs files
ext/Fcntl/Fcntl.pm Fcntl extension Perl module
***************
*** 100,105 ****
--- 102,116 ----
ext/GDBM_File/GDBM_File.xs GDBM extension external subroutines
ext/GDBM_File/Makefile.PL GDBM extension makefile writer
ext/GDBM_File/typemap GDBM extension interface types
+ ext/IO/IO.pm Top-level interface to IO::* classes
+ ext/IO/IO.xs IO extension external subroutines
+ ext/IO/Makefile.PL IO extension makefile writer
+ ext/IO/lib/IO/File.pm IO::File extension Perl module
+ ext/IO/lib/IO/Handle.pm IO::Handle extension Perl module
+ ext/IO/lib/IO/Pipe.pm IO::Pipe extension Perl module
+ ext/IO/lib/IO/Seekable.pm IO::Seekable extension Perl module
+ ext/IO/lib/IO/Select.pm IO::Select extension Perl module
+ ext/IO/lib/IO/Socket.pm IO::Socket extension Perl module
ext/NDBM_File/Makefile.PL NDBM extension makefile writer
ext/NDBM_File/NDBM_File.pm NDBM extension Perl module
ext/NDBM_File/NDBM_File.xs NDBM extension external subroutines
***************
*** 114,119 ****
--- 125,135 ----
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/typemap ODBM extension interface types
+ 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
***************
*** 142,157 ****
ext/SDBM_File/sdbm/pair.c SDBM kit
ext/SDBM_File/sdbm/pair.h SDBM kit
ext/SDBM_File/sdbm/readme.ms SDBM kit
- ext/SDBM_File/sdbm/readme.ps SDBM kit
ext/SDBM_File/sdbm/sdbm.3 SDBM kit
ext/SDBM_File/sdbm/sdbm.c SDBM kit
ext/SDBM_File/sdbm/sdbm.h SDBM kit
ext/SDBM_File/sdbm/tune.h SDBM kit
ext/SDBM_File/sdbm/util.c SDBM kit
ext/SDBM_File/typemap SDBM extension interface types
- ext/Safe/Makefile.PL Safe extension makefile writer
- ext/Safe/Safe.pm Safe extension Perl module
- ext/Safe/Safe.xs Safe extension external subroutines
ext/Socket/Makefile.PL Socket extension makefile writer
ext/Socket/Socket.pm Socket extension Perl module
ext/Socket/Socket.xs Socket extension external subroutines
--- 158,169 ----
***************
*** 215,220 ****
--- 227,235 ----
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
***************
*** 254,259 ****
--- 269,275 ----
lib/English.pm Readable aliases for short variables
lib/Env.pm Map environment into ordinary variables
lib/Exporter.pm Exporter base class
+ lib/ExtUtils/Embed.pm Utilities for embedding Perl in C programs
lib/ExtUtils/Install.pm Handles 'make install' on extensions
lib/ExtUtils/Liblist.pm Locates libraries
lib/ExtUtils/MM_OS2.pm MakeMaker methods for OS/2
***************
*** 266,277 ****
--- 282,295 ----
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/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/FileCache.pm Keep more files open than the system permits
+ 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)
lib/I18N/Collate.pm Routines to do strxfrm-based collation
***************
*** 364,373 ****
opcode.h Automatically generated opcode header
opcode.pl Opcode header generatore
os2/diff.configure Patches to Configure
! os2/diff.db_file patch to DB_File
os2/Makefile.SHs Shared library generation for OS/2
os2/POSIX.mkfifo POSIX.xs patch.
- os2/README OS/2 port info.
os2/README.old previous OS/2 port info, partially relevant.
os2/notes Notes for perl maintainer
os2/os2.c Additional code for OS/2
--- 382,391 ----
opcode.h Automatically generated opcode header
opcode.pl Opcode header generatore
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
***************
*** 383,388 ****
--- 401,420 ----
perly.fixer A program to remove yacc stack limitations
perly.h The header file for perly.c
perly.y Yacc grammar for perl
+ plan9/aperl Shell to make Perl error messages Acme-friendly
+ plan9/arpa/inet.h Plan9 port: replacement C header file
+ plan9/buildinfo Plan9 port: configuration information
+ plan9/config.plan9 Plan9 port: config.h template
+ plan9/exclude Plan9 port: tests to skip
+ plan9/fndvers Plan9 port: update Perl version in config.plan9
+ plan9/genconfig.pl Plan9 port: generate config.sh
+ plan9/mkfile Plan9 port: Mk driver for build
+ plan9/myconfig.plan9 Plan9 port: script to print config summary
+ plan9/perlplan9.doc Plan9 port: Plan9-specific formatted documentation
+ plan9/perlplan9.pod Plan9 port: Plan9-specific pod documentation
+ plan9/plan9.c Plan9 port: Plan9-specific C routines
+ plan9/plan9ish.h Plan9 port: Plan9-specific C header file
+ plan9/setup.rc Plan9 port: script for easy build+install
pod/Makefile Make pods into something else
pod/buildtoc generate perltoc.pod
pod/perl.pod Top level perl man page
***************
*** 477,487 ****
t/lib/dirhand.t See if DirHandle works
t/lib/english.t See if English works
t/lib/filehand.t See if FileHandle works
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/posix.t See if POSIX works
! t/lib/safe.t See if Safe works
t/lib/sdbm.t See if SDBM_File works
t/lib/socket.t See if Socket works
t/lib/soundex.t See if Soundex works
--- 509,528 ----
t/lib/dirhand.t See if DirHandle works
t/lib/english.t See if English works
t/lib/filehand.t See if FileHandle 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_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/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/socket.t See if Socket works
t/lib/soundex.t See if Soundex works
***************
*** 533,538 ****
--- 574,580 ----
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/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
***************
*** 541,546 ****
--- 583,589 ----
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
***************
*** 560,565 ****
--- 603,609 ----
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/gen_shrfls.pl generate options files and glue for shareable image
vms/genconfig.pl retcon config.sh from config.h
#~ Set shared library version number correctly on NeXT
#~ Updates to OS/2 support
#~ Correct typo in perl.exp
#~ Add universal.c
#~ Add configpm dependency to Config.pm
#~ Remove chmod from test target -- last modification of source tree
diff -Pcr perl5_003/Makefile.SH perl5_003_01/Makefile.SH
*** perl5_003/Makefile.SH Mon Mar 25 01:04:55 1996
--- perl5_003_01/Makefile.SH Thu Jul 11 12:28:50 1996
***************
*** 25,43 ****
shrpenv=""
case "$d_shrplib" in
*define*)
patchlevel=`egrep '^#define[ ]+PATCHLEVEL' patchlevel.h \
| awk '{print $3}'`
! case "$patchlevel" in
! *[0-9]) plibsuf=.$so.$patchlevel;;
! *) plibsuf=.$so;;
! esac
! if test "x$plibext" != "x" ; then plibsuf=$plibext d_shrplib=custom ; fi
! case "$shrpdir" in
! /usr/lib) ;;
! "") ;;
! *) shrpenv="env LD_RUN_PATH=$shrpdir";;
! esac
! pldlflags="$cccdlflags";;
*) plibsuf=$lib_ext
pldlflags="";;
esac
--- 25,49 ----
shrpenv=""
case "$d_shrplib" in
*define*)
+ 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;;
! 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="";;
esac
***************
*** 51,80 ****
done
static_list=' '
- static_ai_list=' '
for f in $static_ext; do
base=`echo "$f" | sed 's/.*\///'`
static_list="$static_list lib/auto/$f/$base\$(LIB_EXT)"
- if test -f ext/$f/AutoInit.c; then
- static_ai_list="$static_ai_list ext/$f/AutoInit.c"
- fi
- if test -f ext/$f/AutoInit.pl; then
- static_ai_list="$static_ai_list ext/$f/AutoInit.pl"
- fi
done
echo "Extracting Makefile (with variable substitutions)"
! $spitshell >Makefile <<'!NO!SUBS!'
# Makefile.SH
# This file is derived from Makefile.SH. Any changes made here will
# be lost the next time you run Configure.
! # Makefile is used to generate makefile. The only difference
! # is that makefile has the dependencies filled in at the end.
#
#
- !NO!SUBS!
-
- $spitshell >>Makefile <<!GROK!THIS!
# I now supply perly.c with the kits, so don't remake perly.c without byacc
BYACC = $byacc
CC = $cc
--- 57,79 ----
done
static_list=' '
for f in $static_ext; do
base=`echo "$f" | sed 's/.*\///'`
static_list="$static_list lib/auto/$f/$base\$(LIB_EXT)"
done
+ : ${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
# be lost the next time you run Configure.
! # Makefile is used to generate $firstmakefile. The only difference
! # is that $firstmakefile has the dependencies filled in at the end.
#
#
# I now supply perly.c with the kits, so don't remake perly.c without byacc
BYACC = $byacc
CC = $cc
***************
*** 85,90 ****
--- 84,90 ----
SMALL = $small
LARGE = $large $split
+ MAB = $mab
mallocsrc = $mallocsrc
mallocobj = $mallocobj
LNS = $lns
***************
*** 97,102 ****
--- 97,103 ----
# installman commandline.
bin = $installbin
scriptdir = $scriptdir
+ shrpdir = $shrpdir
privlib = $installprivlib
man1dir = $man1dir
man1ext = $man1ext
***************
*** 115,121 ****
dynamic_ext = $dynamic_list
static_ext = $static_list
ext = \$(dynamic_ext) \$(static_ext)
- static_ext_autoinit = $static_ai_list
DYNALOADER = lib/auto/DynaLoader/DynaLoader\$(LIB_EXT)
libs = $libs $cryptlib
--- 116,121 ----
***************
*** 142,147 ****
--- 142,149 ----
.SUFFIXES: .c \$(OBJ_EXT)
+ SHELL = $bin_sh
+
!GROK!THIS!
## In the following dollars and backticks do not need the extra backslash.
***************
*** 157,163 ****
makedir.SH perl_exp.SH writemain.SH
shextract = Makefile cflags config.h makeaperl makedepend \
! makedir perl_exp writemain
# Files to be built with variable substitution after miniperl is
# available. Dependencies handled manually below (for now).
--- 159,165 ----
makedir.SH perl_exp.SH writemain.SH
shextract = Makefile cflags config.h makeaperl makedepend \
! makedir perl.exp writemain
# Files to be built with variable substitution after miniperl is
# available. Dependencies handled manually below (for now).
***************
*** 176,189 ****
c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c
c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c
! c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c globals.c
c = $(c1) $(c2) $(c3) miniperlmain.c perlmain.c
obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT)
obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT)
! obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) globals$(OBJ_EXT)
!
obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
# Once perl has been Configure'd and built ok you build different
--- 178,191 ----
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
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)
!
obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS)
# Once perl has been Configure'd and built ok you build different
***************
*** 199,211 ****
lintflags = -hbvxac
- # grrr
- SHELL = /bin/sh
-
.c$(OBJ_EXT):
! $(CCCMD) $(PLDLFLAGS) $*.c
! all: makefile miniperl $(private) $(plextract) $(public) $(dynamic_ext)
@echo " "; echo " Everything is up to date."
translators: miniperl lib/Config.pm FORCE
--- 201,210 ----
lintflags = -hbvxac
.c$(OBJ_EXT):
! $(CCCMD) $(MAB) $(PLDLFLAGS) $*.c
! all: $(FIRSTMAKEFILE) miniperl $(private) $(plextract) $(public) $(dynamic_ext)
@echo " "; echo " Everything is up to date."
translators: miniperl lib/Config.pm FORCE
***************
*** 232,249 ****
# The Module used here must not depend on Config or any extensions.
miniperl: $& miniperlmain$(OBJ_EXT) $(perllib)
! $(CC) $(LARGE) $(CLDFLAGS) -o miniperl miniperlmain$(OBJ_EXT) $(perllib) $(libs)
@./miniperl -w -Ilib -MExporter -e 0 || $(MAKE) minitest
miniperlmain$(OBJ_EXT): miniperlmain.c
! $(CCCMD) $(PLDLFLAGS) $*.c
! perlmain.c: miniperlmain.c config.sh makefile $(static_ext_autoinit)
sh writemain $(DYNALOADER) $(static_ext) > tmp
sh mv-if-diff tmp perlmain.c
perlmain$(OBJ_EXT): perlmain.c
! $(CCCMD) $(PLDLFLAGS) $*.c
# The file ext.libs is a list of libraries that must be linked in
# for static extensions, e.g. -lm -lgdbm, etc. The individual
--- 231,248 ----
# 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
! 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
# The file ext.libs is a list of libraries that must be linked in
# for static extensions, e.g. -lm -lgdbm, etc. The individual
***************
*** 252,273 ****
-@test -f ext.libs || touch ext.libs
perl: $& perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) ext.libs
! $(SHRPENV) $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o perl perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs)
pureperl: $& perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) ext.libs
! purify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o pureperl perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs)
quantperl: $& perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) ext.libs
! quantify $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o quantperl perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs)
$(perllib): $& perl$(OBJ_EXT) $(obj)
!NO!SUBS!
case "$d_shrplib" in
*define*)
$spitshell >>Makefile <<'!NO!SUBS!'
$(LD) $(LDDLFLAGS) -o $@ perl$(OBJ_EXT) $(obj)
!NO!SUBS!
;;
custom)
if test -r $osname/Makefile.SHs ; then
--- 251,285 ----
-@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
***************
*** 282,292 ****
--- 294,311 ----
fi
;;
*)
+ if test -z "$isnext_4"
+ then
$spitshell >>Makefile <<'!NO!SUBS!'
rm -f $(perllib)
$(AR) rcu $(perllib) perl$(OBJ_EXT) $(obj)
@$(ranlib) $(perllib)
!NO!SUBS!
+ else
+ $spitshell >>Makefile <<'!NO!SUBS!'
+ libtool -static -o $(perllib) perl.o $(obj)
+ !NO!SUBS!
+ fi
;;
esac
***************
*** 298,309 ****
# has been invoked correctly.
suidperl: $& sperl$(OBJ_EXT) perlmain$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) ext.libs
! $(CC) $(LARGE) $(CLDFLAGS) $(CCDLFLAGS) -o suidperl perlmain$(OBJ_EXT) sperl$(OBJ_EXT) $(perllib) $(DYNALOADER) $(static_ext) `cat ext.libs` $(libs)
sperl$(OBJ_EXT): perl.c perly.h patchlevel.h $(h)
$(RMS) sperl.c
$(LNS) perl.c sperl.c
! $(CCCMD) -DIAMSUID sperl.c
$(RMS) sperl.c
# We have to call our ./makedir because Ultrix 4.3 make can't handle the line
--- 317,328 ----
# 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)
sperl$(OBJ_EXT): perl.c perly.h patchlevel.h $(h)
$(RMS) sperl.c
$(LNS) perl.c sperl.c
! $(CCCMD) $(MAB) -DIAMSUID sperl.c
$(RMS) sperl.c
# We have to call our ./makedir because Ultrix 4.3 make can't handle the line
***************
*** 316,322 ****
autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm
# Take care to avoid modifying lib/Config.pm without reason
! lib/Config.pm: config.sh miniperl
./miniperl configpm tmp
sh mv-if-diff tmp lib/Config.pm
--- 335,341 ----
autosplit_lib_modules(@ARGV)' lib/*.pm lib/*/*.pm
# Take care to avoid modifying lib/Config.pm without reason
! lib/Config.pm: config.sh miniperl configpm
./miniperl configpm tmp
sh mv-if-diff tmp lib/Config.pm
***************
*** 349,354 ****
--- 368,374 ----
@ 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
- perl vms/vms_yfix.pl perly.c perly.h vms/perly_c.vms vms/perly_h.vms
***************
*** 445,451 ****
$(MAKE) depend MAKEDEPEND=
config.h: config.sh
! /bin/sh config_h.SH
# When done, touch perlmain.c so that it doesn't get remade each time.
depend: makedepend
--- 465,474 ----
$(MAKE) depend MAKEDEPEND=
config.h: config.sh
! $(SHELL) config_h.SH
!
! perl.exp: perl_exp.SH config.sh
! $(SHELL) perl_exp.SH
# When done, touch perlmain.c so that it doesn't get remade each time.
depend: makedepend
***************
*** 458,468 ****
sh ./makedepend.SH
test: miniperl perl preplibrary $(dynamic_ext)
- - cd t && chmod +x TEST */*.t
- cd t && (rm -f perl$(EXE_EXT); $(LNS) ../perl$(EXE_EXT) perl$(EXE_EXT)) && ./perl TEST </dev/tty
minitest: miniperl
- - cd t && chmod +x TEST */*.t
- 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
--- 481,489 ----
#~ Moved up from OS/2 subdirectory to be with other OS-specific readmes
#~ Content revised extensively
diff -Pcr perl5_003/README.os2 perl5_003_01/README.os2
*** perl5_003/README.os2 Wed Dec 31 19:00:00 1969
--- perl5_003_01/README.os2 Mon Jul 29 19:36:08 1996
***************
*** 0 ****
--- 1,652 ----
+ Current state of the patches here is with respect to perl5.002b1d ;-).
+
+ ========================================================
+
+ The OS/2 patchkit was submitted by ilya@math.ohio-state.edu. I have
+ applied some parts that I suspect won't cause any problems.
+ Others do things that I haven't had time to fully consider.
+
+ Still other patches included here should perhaps be integrated with the
+ metaconfig package that generates Configure.
+
+ Andy Dougherty <doughera@lafcol.lafayette.edu>
+
+ ========================================================
+
+ Notes on the patch:
+ ~~~~~~~~~~~~~~~~~~~
+ patches should be applied as
+ patch -p0 <.....
+ All the diff.* files and POSIX.mkfifo should be applied.
+
+ Additional files are available on
+ ftp://ftp.math.ohio-state.edu/pub/users/ilya/os2
+ including patched pdksh and gnumake, needed for build.
+
+
+ Target:
+ ~~~~~~~
+
+ This is not supposed to make a perfect Perl on OS/2. This patch is
+ concerned only with perfect _build_ of Perl on OS/2. 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.
+
+ 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.
+
+ ===================================================
+
+ 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
+
+ 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.
+
+ 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;
+
+ 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.
+
+ ==================================================================
+ == ==
+ == User report [my comments in brackets, IZ] ==
+ == ==
+ ==================================================================
+
+ 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.
+
+ >>> 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.
+
+ 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.
+
+ >>> Pre-load some common utilities:
+
+ 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.
+
+ 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.
+
+ >>> Unpack the perl 5_002_01 archive onto an HPFS partition.
+
+ tar vxzf perl5_002_01.tar-gz
+ cd perl5.002_01
+
+ [Do not forget to extract Configure as described above.]
+
+ >>> Read the README, keeping a copy open in another session for reference.
+
+ start /c /fg less os2/README
+
+ >>> Apply the OS/2 patches included with 5.002_01, as per the README.
+
+ for %m in (os2\diff.*) patch -p0 < %m
+ patch -p0 < os2\POSIX.mkfifo
+
+ [The patch below is already applied.]
+
+ >>> 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.
+
+ *** 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
+
+ >>> Apply the patches from Ilya's perl5.002_01 binary distribution:
+
+ 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".
+
+ Configure warnings and errors, and possible work-arounds:
+
+ I don't know where 'ln' is....
+ (ignored; OS/2 doesn't have a ln command)
+
+ 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.
+
+ 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.
+
+ [Apparently this setting is never used, so it is safe to ignore it.]
+
+ Hmm... F:/USR/BIN/sed: Unterminated `s' command
+ Perl built fine even with this error, so it seems safe to
+ ignore.
+
+ 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.
+
+ [I add the options to put it on command line of Configure, see below.]
+
+ 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]
+
+ >>> Advanced users may want to edit config.sh when prompted by Configure.
+ Most (all?) of these changes aren't really necessary:
+
+ 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.
+
+ >>> Allow Configure to run `make depend`. Ignore the following warning:
+
+ 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
+
+ >>> 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:
+
+ 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".
+
+ op/fork........The Unsupported function fork function is \
+ unimplemented at op/fork.t line 8.
+ FAILED on test 1
+
+ The dynamically-loaded version of perl currently doesn't
+ support fork(). This is a known behavior of EMX.
+
+ op/magic.......
+ Process terminated by SIGINT
+ ok
+
+ The test passed even with the SIGINT message. I don't
+ know why, but I won't argue.
+
+ 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
+
+ "OS/2 is not unix". We don't have the ln command.
+
+ 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
+
+ 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.
+
+ 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
+
+ Another file permissions test fails.
+
+ 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
+
+ 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
+
+ Another file permissions test fails.
+
+ lib/gdbm.......FAILED on test 2
+
+ Another file permissions test fails.
+
+ lib/sdbm.......FAILED on test 2
+
+ Another file permissions test fails.
+
+ Failed 11/94 tests, 88.30% okay.
+
+ 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
+ ]
+
+ (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...]
+
+ >>> Cross your fingers and install it:
+
+ make install
+
+ Warnings encountered and workarounds presented.:
+
+ WARNING: You've never run 'make test'!!! (Installing anyway.)
+ (Lies! All lies! At least it still installs.)
+
+ 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.)
+
+ 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
+
+ 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.)
+
+ >>> 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.
+
+ -----------------------------------------------------------------------------
+
+ Development tools and versions:
+
+ EMX 0.9b with emxfix04 applied.
+
+ `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'
+
+ `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)
+
+ `sort --version` reports: 'sort - GNU textutils 1.14'
+ `uniq --version` reports: 'uniq - GNU textutils 1.14'
+ `find --version` reports: 'GNU find version 4.1'
+
+ KSH_VERSION='@(#)PD KSH v5.2.4 96/01/17'
+ (Ilya's patched version.)
+
+ `make --version` reports: 'GNU Make version 3.74'
+ (Ilya's patched version.)
+
+ `emxrev` reports:
+ EMX : revision = 42
+ EMXIO : revision = 40
+ EMXLIBC : revision = 40
+ EMXLIBCM : revision = 43
+ EMXLIBCS : revision = 43
+ EMXWRAP : revision = 40
+
+ -----------------------------------------------------------------------------
+
+ Rocco
+ <troc@shadow.net>
+
#~ New for Plan9 support
diff -Pcr perl5_003/README.plan9 perl5_003_01/README.plan9
*** perl5_003/README.plan9 Wed Dec 31 19:00:00 1969
--- perl5_003_01/README.plan9 Wed Jul 17 19:05:02 1996
***************
*** 0 ****
--- 1,27 ----
+ WELCOME to Plan 9 Perl, brave soul!
+ This is a preliminary alpha version of Plan 9 Perl. Still to be implemented are MakeMaker and DynaLoader. Many perl commands are missing or currently behave in an inscrutable manner. These gaps will, with perserverance and a modicum of luck, be remedied in the near future.To install this software:
+
+ 1. Create the source directories and libraries for perl by running the plan9/setup.rc command (i.e., located in the plan9 subdirectory). Note: the setup routine assumes that you haven't dearchived these files into /sys/src/cmd/perl. After running setup.rc you may delete the copy of the source you originally detarred, as source code has now been installed in /sys/src/cmd/perl. If you plan on installing perl binaries for all architectures, run "setup.rc -a".
+ After
+ 2. Making sure that you have adequate privileges to build system software, from /sys/src/cmd/perl/5.00301 run:
+ mk install
+ If you wish to install perl versions for all architectures (68020, mips, sparc and 386) run:
+ mk installall
+
+ 3. Wait. The build process will take a *long* time because perl bootstraps itself. A 75MHz Pentium, 16MB RAM machine takes roughly 30 minutes to build the distribution from scratch.
+
+ INSTALLING DOCUMENTATION
+ This perl distribution comes with a tremendous amount of documentation. To add these to the built-in manuals that come with Plan 9, from /sys/src/cmd/perl/5.00301 run:
+ mk man
+ To begin your reading, start with:
+ man perl
+ This is a good introduction and will direct you towards other man pages that may interest you. For information specific to Plan 9 Perl, try:
+ man perlplan9
+
+ (Note: "mk man" may produce some extraneous noise. Fear not.)
+
+ Direct questions, comments, and the unlikely bug report (ahem) direct comments toward:
+ lutherh@stratcom.com
+
+ Luther Huffman
+ Strategic Computer Solutions, Inc.
#~ Change global symbol 'stack' to avoid collision with other code
#~ Add warning for multiple attampts to delete an AV.
diff -Pcr perl5_003/av.c perl5_003_01/av.c
*** perl5_003/av.c Tue Jan 30 20:33:11 1996
--- perl5_003_01/av.c Fri Jul 5 18:01:23 1996
***************
*** 94,100 ****
#endif
ary = AvALLOC(av) + AvMAX(av) + 1;
tmp = newmax - AvMAX(av);
! if (av == stack) { /* Oops, grew stack (via av_store()?) */
stack_sp = AvALLOC(av) + (stack_sp - stack_base);
stack_base = AvALLOC(av);
stack_max = stack_base + newmax;
--- 94,100 ----
#endif
ary = AvALLOC(av) + AvMAX(av) + 1;
tmp = newmax - AvMAX(av);
! if (av == curstack) { /* Oops, grew stack (via av_store()?) */
stack_sp = AvALLOC(av) + (stack_sp - stack_base);
stack_base = AvALLOC(av);
stack_max = stack_base + newmax;
***************
*** 196,202 ****
ary = AvARRAY(av);
if (AvFILL(av) < key) {
if (!AvREAL(av)) {
! if (av == stack && key > stack_sp - stack_base)
stack_sp = stack_base + key; /* XPUSH in disguise */
do
ary[++AvFILL(av)] = &sv_undef;
--- 196,202 ----
ary = AvARRAY(av);
if (AvFILL(av) < key) {
if (!AvREAL(av)) {
! if (av == curstack && key > stack_sp - stack_base)
stack_sp = stack_base + key; /* XPUSH in disguise */
do
ary[++AvFILL(av)] = &sv_undef;
***************
*** 289,294 ****
--- 289,299 ----
register I32 key;
SV** ary;
+ #ifdef DEBUGGING
+ if (SvREFCNT(av) <= 0) {
+ warn("Attempt to clear deleted array");
+ }
+ #endif
if (!av || AvMAX(av) < 0)
return;
/*SUPPRESS 560*/
#~ Remove old version of target before creating new one
diff -Pcr perl5_003/cflags.SH perl5_003_01/cflags.SH
*** perl5_003/cflags.SH Sat Jan 20 00:53:39 1996
--- perl5_003_01/cflags.SH Thu Jul 11 12:25:13 1996
***************
*** 21,26 ****
--- 21,27 ----
: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
: Protect any dollar signs and backticks that you do not want interpreted
: by putting a backslash in front. You may delete these comments.
+ rm -f cflags
$spitshell >cflags <<!GROK!THIS!
$startsh
!GROK!THIS!
#~ Add BIN_SH as part of OS/2 support
diff -Pcr perl5_003/config_H perl5_003_01/config_H
*** perl5_003/config_H Mon Mar 25 01:04:02 1996
--- perl5_003_01/config_H Tue May 14 21:02:11 1996
***************
*** 1554,1559 ****
--- 1554,1564 ----
*/
#define STARTPERL "#!/usr/local/bin/perl" /**/
+ /* BIN_SH:
+ * This variable contains the path to the shell.
+ */
+ #define BIN_SH "/bin/sh" /**/
+
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
* compiler. What various bits mean:
#~ Insure execution by /bin/sh
#~ Add BIN_SH macro (defaults to /bin/sh)
#~ Remove old copy of config.h before creating new one
#~ Ascertain BYTEORDER at compile time on NeXT, so it's correct for MABs
diff -Pcr perl5_003/config_h.SH perl5_003_01/config_h.SH
*** perl5_003/config_h.SH Mon Mar 25 01:04:03 1996
--- perl5_003_01/config_h.SH Thu Jul 11 12:29:53 1996
***************
*** 1,3 ****
--- 1,4 ----
+ #! /bin/sh
case $CONFIG in
'')
if test -f config.sh; then TOP=.;
***************
*** 11,20 ****
--- 12,29 ----
. $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!'
/*
* This file was produced by running the config_h.SH script, which
***************
*** 25,31 ****
* that running config_h.SH again will wipe out any changes you've made.
* For a more permanent change edit config.sh and rerun config_h.SH.
*
! * \$Id: Config_h.U,v 3.0.1.4 1995/09/25 09:10:49 ram Exp $
*/
/* Configuration time: $cf_time
--- 34,40 ----
* 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 $
*/
/* Configuration time: $cf_time
***************
*** 1342,1348 ****
--- 1351,1367 ----
* This symbol hold the hexadecimal constant defined in byteorder,
* i.e. 0x1234 or 0x4321, etc...
*/
+ #ifndef NeXT
#define BYTEORDER 0x$byteorder /* large digits for MSB */
+ #else /* NeXT */
+
+ #ifdef __BIG_ENDIAN__
+ #define BYTEORDER 0x4321
+ #else /* __LITTLE_ENDIAN__ */
+ #define BYTEORDER 0x1234
+ #endif /* ENDIAN CHECK */
+
+ #endif /* !NeXT */
/* CSH:
* This symbol, if defined, indicates that the C-shell exists.
***************
*** 1567,1572 ****
--- 1586,1596 ----
* some shell.
*/
#define STARTPERL "$startperl" /**/
+
+ /* BIN_SH:
+ * This variable contains the path to the shell.
+ */
+ #define BIN_SH "$bin_sh" /**/
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
#~ Output line number in die message for version mismatch
#~ Add config_re subroutine
#~ Preload aout-specific values in OS/2 aout Perl
#~ Change end-of-block token
diff -Pcr perl5_003/configpm perl5_003_01/configpm
*** perl5_003/configpm Tue Feb 27 15:47:38 1996
--- perl5_003_01/configpm Mon Jul 15 13:38:04 1996
***************
*** 26,32 ****
\@EXPORT_OK = qw(myconfig config_sh config_vars);
\$] == $myver
! or die "Perl lib version ($myver) doesn't match executable version (\$])\\n";
# This file was created by configpm when Perl was built. Any changes
# made to this file will be lost the next time perl is built.
--- 26,32 ----
\@EXPORT_OK = qw(myconfig config_sh config_vars);
\$] == $myver
! or die "Perl lib version ($myver) doesn't match executable version (\$])";
# This file was created by configpm when Perl was built. Any changes
# made to this file will be lost the next time perl is built.
***************
*** 85,92 ****
print CONFIG <<'ENDOFEND';
- tie %Config, Config;
- sub TIEHASH { bless {} }
sub FETCH {
# check for cached value (which maybe undef so we use exists not defined)
return $_[0]->{$_[1]} if (exists $_[0]->{$_[1]});
--- 85,90 ----
***************
*** 126,139 ****
--- 124,169 ----
sub config_sh {
$config_sh
}
+
+ sub config_re {
+ my $re = shift;
+ my @matches = ($config_sh =~ /^$re=.*\n/mg);
+ @matches ? (print @matches) : print "$re: not found\n";
+ }
+
sub config_vars {
foreach(@_){
+ config_re($_), next if /\W/;
my $v=(exists $Config{$_}) ? $Config{$_} : 'UNKNOWN';
$v='undef' unless defined $v;
print "$_='$v';\n";
}
}
+ ENDOFEND
+
+ if ($^O eq 'os2') {
+ print CONFIG <<'ENDOFSET';
+ my %preconfig;
+ if ($OS2::is_aout) {
+ my ($value, $v) = $config_sh =~ m/^used_aout='(.*)'\s*$/m;
+ for (split ' ', $value) {
+ ($v) = $config_sh =~ m/^aout_$_='(.*)'\s*$/m;
+ $preconfig{$_} = $v eq 'undef' ? undef : $v;
+ }
+ }
+ sub TIEHASH { bless {%preconfig} }
+ ENDOFSET
+ } else {
+ print CONFIG <<'ENDOFSET';
+ sub TIEHASH { bless {} }
+ ENDOFSET
+ }
+
+ print CONFIG <<'ENDOFTAIL';
+
+ tie %Config, 'Config';
+
1;
__END__
***************
*** 229,235 ****
=cut
! ENDOFEND
close(CONFIG);
--- 259,265 ----
=cut
! ENDOFTAIL
close(CONFIG);
#~ Increment refcount on @_ when passed through to another sub,
#~ so it's not freed twiceon return.
diff -Pcr perl5_003/cop.h perl5_003_01/cop.h
*** perl5_003/cop.h Sun Jan 28 01:19:07 1996
--- perl5_003_01/cop.h Fri Jul 5 18:01:26 1996
***************
*** 52,57 ****
--- 52,60 ----
} \
if (cx->blk_sub.cv) { \
if (!(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth)) { \
+ if (cx->blk_sub.hasargs) { \
+ SvREFCNT_inc((SV*)cx->blk_sub.argarray); \
+ } \
SvREFCNT_dec((SV*)cx->blk_sub.cv); \
} \
}
#~ Add configurable destination for debug messages
diff -Pcr perl5_003/deb.c perl5_003_01/deb.c
*** perl5_003/deb.c Thu Jan 19 19:06:23 1995
--- perl5_003_01/deb.c Thu Jul 4 14:47:45 1996
***************
*** 30,41 ****
register I32 i;
GV* gv = curcop->cop_filegv;
! fprintf(stderr,"(%s:%ld)\t",
SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
(long)curcop->cop_line);
for (i=0; i<dlevel; i++)
! fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
! fprintf(stderr,pat,a1,a2,a3,a4,a5,a6,a7,a8);
}
#else /* !defined(I_STDARG) && !defined(I_VARARGS) */
--- 30,41 ----
register I32 i;
GV* gv = curcop->cop_filegv;
! fprintf(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);
}
#else /* !defined(I_STDARG) && !defined(I_VARARGS) */
***************
*** 55,72 ****
register I32 i;
GV* gv = curcop->cop_filegv;
! fprintf(stderr,"(%s:%ld)\t",
SvTYPE(gv) == SVt_PVGV ? SvPVX(GvSV(gv)) : "<free>",
(long)curcop->cop_line);
for (i=0; i<dlevel; i++)
! fprintf(stderr,"%c%c ",debname[i],debdelim[i]);
# ifdef I_STDARG
va_start(args, pat);
# else
va_start(args);
# endif
! (void) vfprintf(stderr,pat,args);
va_end( args );
}
#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
--- 55,72 ----
register I32 i;
GV* gv = curcop->cop_filegv;
! fprintf(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]);
# ifdef I_STDARG
va_start(args, pat);
# else
va_start(args);
# endif
! (void) vfprintf(Perl_debug_log,pat,args);
va_end( args );
}
#endif /* !defined(I_STDARG) && !defined(I_VARARGS) */
***************
*** 82,94 ****
I32
debstackptrs()
{
! fprintf(stderr, "%8lx %8lx %8ld %8ld %8ld\n",
! (unsigned long)stack, (unsigned long)stack_base,
(long)*markstack_ptr, (long)(stack_sp-stack_base),
(long)(stack_max-stack_base));
! fprintf(stderr, "%8lx %8lx %8ld %8ld %8ld\n",
! (unsigned long)mainstack, (unsigned long)AvARRAY(stack),
! (long)mainstack, (long)AvFILL(stack), (long)AvMAX(stack));
return 0;
}
--- 82,94 ----
I32
debstackptrs()
{
! fprintf(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",
! (unsigned long)mainstack, (unsigned long)AvARRAY(curstack),
! (long)mainstack, (long)AvFILL(curstack), (long)AvMAX(curstack));
return 0;
}
***************
*** 106,130 ****
if (*markscan >= i)
break;
! fprintf(stderr, i ? " => ... " : " => ");
if (stack_base[0] != &sv_undef || stack_sp < stack_base)
! fprintf(stderr, " [STACK UNDERFLOW!!!]\n");
do {
++i;
if (markscan <= markstack_ptr && *markscan < i) {
do {
++markscan;
! putc('*', stderr);
}
while (markscan <= markstack_ptr && *markscan < i);
! fprintf(stderr, " ");
}
if (i > top)
break;
! fprintf(stderr, "%-4s ", SvPEEK(stack_base[i]));
}
while (1);
! fprintf(stderr, "\n");
return 0;
}
#else
--- 106,130 ----
if (*markscan >= i)
break;
! fprintf(Perl_debug_log, i ? " => ... " : " => ");
if (stack_base[0] != &sv_undef || stack_sp < stack_base)
! fprintf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
do {
++i;
if (markscan <= markstack_ptr && *markscan < i) {
do {
++markscan;
! putc('*', Perl_debug_log);
}
while (markscan <= markstack_ptr && *markscan < i);
! fprintf(Perl_debug_log, " ");
}
if (i > top)
break;
! fprintf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
}
while (1);
! fprintf(Perl_debug_log, "\n");
return 0;
}
#else
#~ Add curlies to nested expression for clarity
#~ Rename keyword 'explicit' to eliminate C++ collision
#~ Rename chsize() function to avoid collision with libc on some systems
#~ Use macro for shell name as part of OS/2 support
#~ Support 64-bit times
diff -Pcr perl5_003/doio.c perl5_003_01/doio.c
*** perl5_003/doio.c Tue Feb 27 16:29:23 1996
--- perl5_003_01/doio.c Sat Jul 20 19:56:18 1996
***************
*** 192,200 ****
}
if (dodup)
fd = dup(fd);
! if (!(fp = fdopen(fd,mode)))
if (dodup)
close(fd);
}
}
else {
--- 192,201 ----
}
if (dodup)
fd = dup(fd);
! if (!(fp = fdopen(fd,mode))) {
if (dodup)
close(fd);
+ }
}
}
else {
***************
*** 520,532 ****
}
#endif
bool
#ifndef CAN_PROTOTYPE
! do_close(gv,explicit)
GV *gv;
! bool explicit;
#else
! do_close(GV *gv, bool explicit)
#endif /* CAN_PROTOTYPE */
{
bool retval;
--- 521,534 ----
}
#endif
+ /* explicit renamed to avoid C++ conflict -- kja */
bool
#ifndef CAN_PROTOTYPE
! do_close(gv,not_implicit)
GV *gv;
! bool not_implicit;
#else
! do_close(GV *gv, bool not_implicit)
#endif /* CAN_PROTOTYPE */
{
bool retval;
***************
*** 540,551 ****
}
io = GvIO(gv);
if (!io) { /* never opened */
! if (dowarn && explicit)
warn("Close on unopened file <%s>",GvENAME(gv));
return FALSE;
}
retval = io_close(io);
! if (explicit) {
IoLINES(io) = 0;
IoPAGE(io) = 0;
IoLINES_LEFT(io) = IoPAGE_LEN(io);
--- 542,553 ----
}
io = GvIO(gv);
if (!io) { /* never opened */
! if (dowarn && not_implicit)
warn("Close on unopened file <%s>",GvENAME(gv));
return FALSE;
}
retval = io_close(io);
! if (not_implicit) {
IoLINES(io) = 0;
IoPAGE(io) = 0;
IoLINES_LEFT(io) = IoPAGE_LEN(io);
***************
*** 681,687 ****
/* code courtesy of William Kucharski */
#define HAS_CHSIZE
! I32 chsize(fd, length)
I32 fd; /* file descriptor */
Off_t length; /* length to set file to */
{
--- 683,689 ----
/* code courtesy of William Kucharski */
#define HAS_CHSIZE
! I32 my_chsize(fd, length)
I32 fd; /* file descriptor */
Off_t length; /* length to set file to */
{
***************
*** 1012,1018 ****
break;
}
doshell:
! execl("/bin/sh","sh","-c",cmd,(char*)0);
return FALSE;
}
}
--- 1014,1020 ----
break;
}
doshell:
! execl(SH_PATH, "sh", "-c", cmd, (char*)0);
return FALSE;
}
}
***************
*** 1188,1195 ****
--- 1190,1202 ----
#endif
Zero(&utbuf, sizeof utbuf, char);
+ #ifdef BIG_TIME
+ utbuf.actime = (Time_t)SvNVx(*++mark); /* time accessed */
+ utbuf.modtime = (Time_t)SvNVx(*++mark); /* time modified */
+ #else
utbuf.actime = SvIVx(*++mark); /* time accessed */
utbuf.modtime = SvIVx(*++mark); /* time modified */
+ #endif
tot = sp - mark;
while (++mark <= sp) {
if (utime(SvPVx(*mark, na),&utbuf))
#~ Fix length test so chomp won't clip strings shorter than $/
#~ Incorporate shared hash key support
diff -Pcr perl5_003/doop.c perl5_003_01/doop.c
*** perl5_003/doop.c Fri Jan 26 18:58:10 1996
--- perl5_003_01/doop.c Tue Jun 18 21:52:39 1996
***************
*** 494,500 ****
++count;
}
else {
! if (len < rslen)
goto nope;
len -= rslen - 1;
s -= rslen - 1;
--- 494,500 ----
++count;
}
else {
! if (len < rslen - 1)
goto nope;
len -= rslen - 1;
s -= rslen - 1;
***************
*** 622,630 ****
{
dSP;
HV *hv = (HV*)POPs;
- I32 i;
register HE *entry;
- char *tmps;
SV *tmpstr;
I32 dokeys = (op->op_type == OP_KEYS);
I32 dovalues = (op->op_type == OP_VALUES);
--- 622,628 ----
***************
*** 638,643 ****
--- 636,642 ----
(void)hv_iterinit(hv); /* always reset iterator regardless */
if (GIMME != G_ARRAY) {
+ I32 i;
dTARGET;
if (!SvRMAGICAL(hv) || !mg_find((SV*)hv,'P'))
***************
*** 659,679 ****
PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
while (entry = hv_iternext(hv)) {
SPAGAIN;
! if (dokeys) {
! tmps = hv_iterkey(entry,&i); /* won't clobber stack_sp */
! if (!i)
! tmps = "";
! XPUSHs(sv_2mortal(newSVpv(tmps,i)));
! }
if (dovalues) {
tmpstr = NEWSV(45,0);
PUTBACK;
sv_setsv(tmpstr,hv_iterval(hv,entry));
SPAGAIN;
DEBUG_H( {
! sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
! HvMAX(hv)+1,entry->hent_hash & HvMAX(hv));
! sv_setpv(tmpstr,buf);
} )
XPUSHs(sv_2mortal(tmpstr));
}
--- 658,674 ----
PUTBACK; /* hv_iternext and hv_iterval might clobber stack_sp */
while (entry = hv_iternext(hv)) {
SPAGAIN;
! if (dokeys)
! XPUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
if (dovalues) {
tmpstr = NEWSV(45,0);
PUTBACK;
sv_setsv(tmpstr,hv_iterval(hv,entry));
SPAGAIN;
DEBUG_H( {
! sprintf(buf,"%d%%%d=%d\n", HeHASH(entry),
! HvMAX(hv)+1, HeHASH(entry) & HvMAX(hv));
! sv_setpv(tmpstr,buf);
} )
XPUSHs(sv_2mortal(tmpstr));
}
#~ Supply OS-specific values for macros added as part of Plan9 and VMS support
diff -Pcr perl5_003/dosish.h perl5_003_01/dosish.h
*** perl5_003/dosish.h Mon Mar 25 01:04:03 1996
--- perl5_003_01/dosish.h Thu Jul 25 16:12:47 1996
***************
*** 6,11 ****
--- 6,32 ----
#define dXSUB_SYS int dummy
#define TMPPATH "plXXXXXX"
+ /* USEMYBINMODE
+ * This symbol, if defined, indicates that the program should
+ * use the routine my_binmode(FILE *fp, char iotype) to insure
+ * that a file is in "binary" mode -- that is, that no translation
+ * of bytes occurs on read or write operations.
+ */
+ #undef USEMYBINMODE
+
+ /* USE_STAT_RDEV:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_rdev
+ */
+ #define USE_STAT_RDEV /**/
+
+ /* ACME_MESS:
+ * This symbol, if defined, indicates that error messages should be
+ * should be generated in a format that allows the use of the Acme
+ * GUI/editor's autofind feature.
+ */
+ #undef ACME_MESS /**/
+
/*
* fwrite1() should be a routine with the same calling sequence as fwrite(),
* but which outputs all of the bytes requested as a single stream (unlike
#~ Use varargs prototype for dump()
#~ Use configurable destination for "error" output
#~ Incorporate shared hash key support
diff -Pcr perl5_003/dump.c perl5_003_01/dump.c
*** perl5_003/dump.c Sun Jan 28 00:15:09 1996
--- perl5_003_01/dump.c Fri Jun 21 11:22:14 1996
***************
*** 22,36 ****
}
#else /* Rest of file is for DEBUGGING */
static void dump();
void
dump_all()
{
#ifdef HAS_SETLINEBUF
! setlinebuf(stderr);
#else
! setvbuf(stderr, Nullch, _IOLBF, 0);
#endif
if (main_root)
dump_op(main_root);
--- 22,48 ----
}
#else /* Rest of file is for DEBUGGING */
+ #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
if (main_root)
dump_op(main_root);
***************
*** 47,60 ****
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
! for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
! GV *gv = (GV*)entry->hent_val;
HV *hv;
if (GvCV(gv))
dump_sub(gv);
if (GvFORM(gv))
dump_form(gv);
! if (entry->hent_key[entry->hent_klen-1] == ':' &&
(hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
dump_packsubs(hv); /* nested package */
}
--- 59,72 ----
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
! for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
! GV *gv = (GV*)HeVAL(entry);
HV *hv;
if (GvCV(gv))
dump_sub(gv);
if (GvFORM(gv))
dump_form(gv);
! if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
(hv = GvHV(gv)) && HvNAME(hv) && hv != defstash)
dump_packsubs(hv); /* nested package */
}
***************
*** 107,124 ****
dump("{\n");
if (op->op_seq)
! fprintf(stderr, "%-4d", op->op_seq);
else
! fprintf(stderr, " ");
dump("TYPE = %s ===> ", op_name[op->op_type]);
if (op->op_next) {
if (op->op_seq)
! fprintf(stderr, "%d\n", op->op_next->op_seq);
else
! fprintf(stderr, "(%d)\n", op->op_next->op_seq);
}
else
! fprintf(stderr, "DONE\n");
dumplvl++;
if (op->op_targ) {
if (op->op_type == OP_NULL)
--- 119,136 ----
dump("{\n");
if (op->op_seq)
! fprintf(Perl_debug_log, "%-4d", op->op_seq);
else
! fprintf(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);
else
! fprintf(Perl_debug_log, "(%d)\n", op->op_next->op_seq);
}
else
! fprintf(Perl_debug_log, "DONE\n");
dumplvl++;
if (op->op_targ) {
if (op->op_type == OP_NULL)
***************
*** 243,273 ****
case OP_ENTERLOOP:
dump("REDO ===> ");
if (cLOOP->op_redoop)
! fprintf(stderr, "%d\n", cLOOP->op_redoop->op_seq);
else
! fprintf(stderr, "DONE\n");
dump("NEXT ===> ");
if (cLOOP->op_nextop)
! fprintf(stderr, "%d\n", cLOOP->op_nextop->op_seq);
else
! fprintf(stderr, "DONE\n");
dump("LAST ===> ");
if (cLOOP->op_lastop)
! fprintf(stderr, "%d\n", cLOOP->op_lastop->op_seq);
else
! fprintf(stderr, "DONE\n");
break;
case OP_COND_EXPR:
dump("TRUE ===> ");
if (cCONDOP->op_true)
! fprintf(stderr, "%d\n", cCONDOP->op_true->op_seq);
else
! fprintf(stderr, "DONE\n");
dump("FALSE ===> ");
if (cCONDOP->op_false)
! fprintf(stderr, "%d\n", cCONDOP->op_false->op_seq);
else
! fprintf(stderr, "DONE\n");
break;
case OP_MAPWHILE:
case OP_GREPWHILE:
--- 255,285 ----
case OP_ENTERLOOP:
dump("REDO ===> ");
if (cLOOP->op_redoop)
! fprintf(Perl_debug_log, "%d\n", cLOOP->op_redoop->op_seq);
else
! fprintf(Perl_debug_log, "DONE\n");
dump("NEXT ===> ");
if (cLOOP->op_nextop)
! fprintf(Perl_debug_log, "%d\n", cLOOP->op_nextop->op_seq);
else
! fprintf(Perl_debug_log, "DONE\n");
dump("LAST ===> ");
if (cLOOP->op_lastop)
! fprintf(Perl_debug_log, "%d\n", cLOOP->op_lastop->op_seq);
else
! fprintf(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);
else
! fprintf(Perl_debug_log, "DONE\n");
dump("FALSE ===> ");
if (cCONDOP->op_false)
! fprintf(Perl_debug_log, "%d\n", cCONDOP->op_false->op_seq);
else
! fprintf(Perl_debug_log, "DONE\n");
break;
case OP_MAPWHILE:
case OP_GREPWHILE:
***************
*** 275,283 ****
case OP_AND:
dump("OTHER ===> ");
if (cLOGOP->op_other)
! fprintf(stderr, "%d\n", cLOGOP->op_other->op_seq);
else
! fprintf(stderr, "DONE\n");
break;
case OP_PUSHRE:
case OP_MATCH:
--- 287,295 ----
case OP_AND:
dump("OTHER ===> ");
if (cLOGOP->op_other)
! fprintf(Perl_debug_log, "%d\n", cLOGOP->op_other->op_seq);
else
! fprintf(Perl_debug_log, "DONE\n");
break;
case OP_PUSHRE:
case OP_MATCH:
***************
*** 303,314 ****
SV *sv;
if (!gv) {
! fprintf(stderr,"{}\n");
return;
}
sv = sv_newmortal();
dumplvl++;
! fprintf(stderr,"{\n");
gv_fullname(sv,gv);
dump("GV_NAME = %s", SvPVX(sv));
if (gv != GvEGV(gv)) {
--- 315,326 ----
SV *sv;
if (!gv) {
! fprintf(Perl_debug_log,"{}\n");
return;
}
sv = sv_newmortal();
dumplvl++;
! fprintf(Perl_debug_log,"{\n");
gv_fullname(sv,gv);
dump("GV_NAME = %s", SvPVX(sv));
if (gv != GvEGV(gv)) {
***************
*** 378,383 ****
--- 390,397 ----
dump("}\n");
}
+
+ #if !defined(I_STDARG) && !defined(I_VARARGS)
/* VARARGS1 */
static void dump(arg1,arg2,arg3,arg4,arg5)
char *arg1;
***************
*** 386,392 ****
I32 i;
for (i = dumplvl*4; i; i--)
(void)putc(' ',stderr);
! fprintf(stderr,arg1, arg2, arg3, arg4, arg5);
}
#endif
--- 400,438 ----
I32 i;
for (i = dumplvl*4; i; i--)
+ (void)putc(' ',Perl_debug_log);
+ fprintf(Perl_debug_log,arg1, arg2, arg3, arg4, arg5);
+ }
+
+ #else
+
+ #ifdef I_STDARG
+ static void
+ dump(char *pat,...)
+ #else
+ /*VARARGS0*/
+ static void
+ dump(pat,va_alist)
+ char *pat;
+ va_dcl
+ #endif
+ {
+ I32 i;
+ va_list args;
+ #ifndef HAS_VPRINTF
+ int vfprintf();
+ #endif
+
+ #ifdef I_STDARG
+ va_start(args, pat);
+ #else
+ va_start(args);
+ #endif
+ for (i = dumplvl*4; i; i--)
(void)putc(' ',stderr);
! vfprintf(Perl_debug_log,pat,args);
! va_end(args);
}
+ #endif
+
#endif
#~ Update to v1.24
diff -Pcr perl5_003/emacs/cperl-mode.el perl5_003_01/emacs/cperl-mode.el
*** perl5_003/emacs/cperl-mode.el Mon Feb 12 14:49:43 1996
--- perl5_003_01/emacs/cperl-mode.el Fri Jul 5 13:47:35 1996
***************
*** 27,33 ****
;;; Corrections made by Ilya Zakharevich ilya@math.mps.ohio-state.edu
;;; XEmacs changes by Peter Arius arius@informatik.uni-erlangen.de
! ;; $Id: cperl-mode.el,v 1.20 1996/02/09 03:40:01 ilya Exp ilya $
;;; To use this mode put the following into your .emacs file:
--- 27,33 ----
;;; 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 $
;;; To use this mode put the following into your .emacs file:
***************
*** 245,250 ****
--- 245,286 ----
;;; pod sections which are broken because of whitespace before =blah
;;; - just observe the fontification.
+ ;;;; After 1.20
+ ;;; Anonymous subs are indented with respect to the level of
+ ;;; indentation of `sub' now.
+ ;;; {} is recognized as hash after `bless' and `return'.
+ ;;; Anonymous subs are split by `cperl-linefeed' as well.
+ ;;; Electric parens embrace a region if present.
+ ;;; To make `cperl-auto-newline' useful,
+ ;;; `cperl-auto-newline-after-colon' is introduced.
+ ;;; `cperl-electric-parens' is now t or nul. The old meaning is moved to
+ ;;; `cperl-electric-parens-string'.
+ ;;; `cperl-toggle-auto-newline' introduced, put on C-c C-a.
+ ;;; `cperl-toggle-abbrev' introduced, put on C-c C-k.
+ ;;; `cperl-toggle-electric' introduced, put on C-c C-e.
+ ;;; Beginning-of-defun-regexp was not anchored.
+
+ ;;;; After 1.21
+ ;;; Auto-newline grants `cperl-extra-newline-before-brace' if "{" is typed
+ ;;; after ")".
+ ;;; {} is recognized as expression after `tr' and friends.
+
+ ;;;; After 1.22
+ ;;; Entry Hierarchy added to imenu. Very primitive so far.
+ ;;; One needs newer `imenu-go'.el. A patch to `imenu' is needed as well.
+ ;;; Writes its own TAGS files.
+ ;;; Class viewer based on TAGS files. Does not trace @ISA so far.
+ ;;; 19.31: Problems with scan for PODs corrected.
+ ;;; First POD header correctly fontified.
+ ;;; I needed (setq imenu-use-keymap-menu t) to get good imenu in 19.31.
+ ;;; Apparently it makes a lot of hierarchy code obsolete...
+
+ ;;;; After 1.23
+ ;;; Tags filler now scans *.xs as well.
+ ;;; The info from *.xs scan is used by the hierarchy viewer.
+ ;;; Hierarchy viewer documented.
+ ;;; Bug in 19.31 imenu documented.
+
(defvar cperl-extra-newline-before-brace nil
"*Non-nil means that if, elsif, while, until, else, for, foreach
and do constructs look like:
***************
*** 284,290 ****
(defvar cperl-auto-newline nil
"*Non-nil means automatically newline before and after braces,
! and after colons and semicolons, inserted in CPerl code.")
(defvar cperl-tab-always-indent t
"*Non-nil means TAB in CPerl mode should always reindent the current line,
--- 320,333 ----
(defvar cperl-auto-newline nil
"*Non-nil means automatically newline before and after braces,
! and after colons and semicolons, inserted in CPerl code. The following
! \\[cperl-electric-backspace] will remove the inserted whitespace.
! Insertion after colons requires both this variable and
! `cperl-auto-newline-after-colon' set.")
!
! (defvar cperl-auto-newline-after-colon nil
! "*Non-nil means automatically newline even after colons.
! Subject to `cperl-auto-newline' setting.")
(defvar cperl-tab-always-indent t
"*Non-nil means TAB in CPerl mode should always reindent the current line,
***************
*** 298,306 ****
"*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 ""
! "*List of parentheses that should be electric in CPerl, or null.
! Can be overwritten by `cperl-hairy' to \"({[<\" if not 'null.")
(defvar cperl-electric-linefeed nil
"*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy.
--- 341,364 ----
"*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 "({[<"
! "*String of parentheses that should be electric in CPerl.")
!
! (defvar cperl-electric-parens nil
! "*Non-nil (and non-null) means parentheses should be electric in CPerl.
! Can be overwritten by `cperl-hairy' if nil.")
! (defvar cperl-electric-parens-mark
! (and window-system
! (or (and (boundp 'transient-mark-mode) ; For Emacs
! transient-mark-mode)
! (and (boundp 'zmacs-regions) ; For XEmacs
! zmacs-regions)))
! "*Not-nil means that electric parens look for active mark.
! Default is yes if there is visual feedback on mark.")
!
! (defvar cperl-electric-parens-mark (and window-system transient-mark-mode)
! "*Not-nil means that electric parens look for active mark.
! Default is yes if there is visual feedback on mark.")
(defvar cperl-electric-linefeed nil
"*If true, LFD should be hairy in CPerl, otherwise C-c LFD is hairy.
***************
*** 343,348 ****
--- 401,410 ----
"*Not-nil means look for pod and here-docs sections during startup.
You can always make lookup from menu or using \\[cperl-find-pods-heres].")
+ (defvar cperl-imenu-addback nil
+ "*Not-nil means add backreferences to generated `imenu's.
+ May require patched `imenu' and `imenu-go'.")
+
;;; Short extra-docs.
***************
*** 353,362 ****
and/or
ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
! Get support packages font-lock-extra.el, imenu-go.el from the same place.
! \(Look for other files there too... ;-) Get a patch for imenu.el in 19.29.
! Note that for 19.30 you should use choose-color.el *instead* of
! font-lock-extra.el (and you will not get smart highlighting in C :-().
Note that to enable Compile choices in the menu you need to install
mode-compile.el.
--- 415,425 ----
and/or
ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
! Get support packages choose-color.el (or font-lock-extra.el before
! 19.30), imenu-go.el from the same place. \(Look for other files there
! too... ;-) Get a patch for imenu.el in 19.29. Note that for 19.30 and
! later you should use choose-color.el *instead* of font-lock-extra.el
! \(and you will not get smart highlighting in C :-().
Note that to enable Compile choices in the menu you need to install
mode-compile.el.
***************
*** 365,372 ****
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).
Before reporting (non-)problems look in the problem section on what I
know about them.")
--- 428,441 ----
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
! CPerl/Tools/Tags menu beforehand.
Before reporting (non-)problems look in the problem section on what I
know about them.")
***************
*** 374,381 ****
(defvar cperl-problems 'please-ignore-this-line
"Emacs has a _very_ restricted syntax parsing engine.
! It may be corrected on the level of C ocde, please look in the
! `non-problems' section if you want to volonteer.
CPerl mode tries to corrects some Emacs misunderstandings, however,
for effeciency reasons the degree of correction is different for
--- 443,450 ----
(defvar cperl-problems 'please-ignore-this-line
"Emacs has a _very_ restricted syntax parsing engine.
! 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
***************
*** 435,440 ****
--- 504,513 ----
a) sub in $mypackage::sub may be highlighted.
b) -z in [a-z] may be highlighted.
c) if your regexp contains a keyword (like \"s\"), it may be highlighted.
+
+
+ Imenu in 19.31 is broken. Set `imenu-use-keymap-menu' to t, and remove
+ `car' before `imenu-choose-buffer-index' in `imenu'.
")
***************
*** 452,463 ****
(setq del-back-ch (aref del-back-ch 0)))
(if (cperl-xemacs-p)
! ;; "Active regions" are on: use region only if active
! ;; "Active regions" are off: use region unconditionally
! (defun cperl-use-region-p ()
! (if zmacs-regions (mark) t))
(defun cperl-use-region-p ()
! (if transient-mark-mode mark-active t)))
(defsubst cperl-enable-font-lock ()
(or (cperl-xemacs-p) window-system))
--- 525,539 ----
(setq del-back-ch (aref del-back-ch 0)))
(if (cperl-xemacs-p)
! (progn
! ;; "Active regions" are on: use region only if active
! ;; "Active regions" are off: use region unconditionally
! (defun cperl-use-region-p ()
! (if zmacs-regions (mark) t))
! (defun cperl-mark-active () (mark)))
(defun cperl-use-region-p ()
! (if transient-mark-mode mark-active t))
! (defun cperl-mark-active () mark-active))
(defsubst cperl-enable-font-lock ()
(or (cperl-xemacs-p) window-system))
***************
*** 482,487 ****
--- 558,567 ----
'lazy-lock)
"Text property which inhibits refontification.")
+ (defsubst cperl-put-do-not-fontify (from to)
+ (put-text-property (max (point-min) (1- from))
+ to cperl-do-not-fontify t))
+
;;; Probably it is too late to set these guys already, but it can help later:
***************
*** 525,534 ****
(define-key cperl-mode-map ":" 'cperl-electric-terminator)
(define-key cperl-mode-map "\C-j" 'newline-and-indent)
(define-key cperl-mode-map "\C-c\C-j" 'cperl-linefeed)
(define-key cperl-mode-map "\e\C-q" 'cperl-indent-exp) ; Usually not bound
;;(define-key cperl-mode-map "\M-q" 'cperl-fill-paragraph)
;;(define-key cperl-mode-map "\e;" 'cperl-indent-for-comment)
! (define-key cperl-mode-map "\177" 'backward-delete-char-untabify)
(define-key cperl-mode-map "\t" 'cperl-indent-command)
(if (cperl-xemacs-p)
;; don't clobber the backspace binding:
--- 605,617 ----
(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:
***************
*** 585,605 ****
"----"
("Tools"
["Imenu" imenu (fboundp 'imenu)]
["Imenu on info" cperl-imenu-on-info (featurep 'imenu)]
("Tags"
! ["Create tags for current file" cperl-etags t]
! ["Add tags for current file" (cperl-etags t) t]
! ["Create tags for Perl files in directory" (cperl-etags nil t) t]
! ["Add tags for Perl files in directory" (cperl-etags t t) t]
["Create tags for Perl files in (sub)directories"
! (cperl-etags nil 'recursive) t]
["Add tags for Perl files in (sub)directories"
! (cperl-etags t 'recursive) t])
! ["Recalculate PODs" cperl-find-pods-heres t]
["Define word at point" imenu-go-find-at-position
(fboundp 'imenu-go-find-at-position)]
["Help on function" cperl-info-on-command t]
["Help on function at point" cperl-info-on-current-command t])
("Indent styles..."
["GNU" (cperl-set-style "GNU") t]
["C++" (cperl-set-style "C++") t]
--- 668,706 ----
"----"
("Tools"
["Imenu" imenu (fboundp 'imenu)]
+ ["Class Hierarchy from TAGS" cperl-tags-hier-init t]
+ ;;["Update classes" (cperl-tags-hier-init t) tags-table-list]
["Imenu on info" cperl-imenu-on-info (featurep 'imenu)]
("Tags"
! ;;; ["Create tags for current file" cperl-etags t]
! ;;; ["Add tags for current file" (cperl-etags t) t]
! ;;; ["Create tags for Perl files in directory" (cperl-etags nil t) t]
! ;;; ["Add tags for Perl files in directory" (cperl-etags t t) t]
! ;;; ["Create tags for Perl files in (sub)directories"
! ;;; (cperl-etags nil 'recursive) t]
! ;;; ["Add tags for Perl files in (sub)directories"
! ;;; (cperl-etags t 'recursive) t])
! ;;;; cperl-write-tags (&optional file erase recurse dir inbuffer)
! ["Create tags for current file" (cperl-write-tags nil t) t]
! ["Add tags for current file" (cperl-write-tags) t]
! ["Create tags for Perl files in directory"
! (cperl-write-tags nil t nil t) t]
! ["Add tags for Perl files in directory"
! (cperl-write-tags nil nil nil t) t]
["Create tags for Perl files in (sub)directories"
! (cperl-write-tags nil t t t) t]
["Add tags for Perl files in (sub)directories"
! (cperl-write-tags nil nil t t) t])
! ["Recalculate PODs and HEREs" cperl-find-pods-heres t]
["Define word at point" imenu-go-find-at-position
(fboundp 'imenu-go-find-at-position)]
["Help on function" cperl-info-on-command t]
["Help on function at point" cperl-info-on-current-command t])
+ ("Toggle..."
+ ["Auto newline" cperl-toggle-auto-newline t]
+ ["Electric parens" cperl-toggle-electric t]
+ ["Electric keywords" cperl-toggle-abbrev t]
+ )
("Indent styles..."
["GNU" (cperl-set-style "GNU") t]
["C++" (cperl-set-style "C++") t]
***************
*** 669,676 ****
\"paren\" to avoid the expansion. The processing of < is special,
since most the time you mean \"less\". Cperl mode tries to guess
whether you want to type pair <>, and inserts is if it
! appropriate. You can set `cperl-electric-parens' to the string that
contains the parenths from the above list you want to be electrical.
CPerl mode provides expansion of the Perl control constructs:
if, else, elsif, unless, while, until, for, and foreach.
--- 770,780 ----
\"paren\" to avoid the expansion. The processing of < is special,
since most the time you mean \"less\". Cperl mode tries to guess
whether you want to type pair <>, and inserts is if it
! appropriate. You can set `cperl-electric-parens-string' to the string that
contains the parenths from the above list you want to be electrical.
+ Electricity of parenths is controlled by `cperl-electric-parens'.
+ You may also set `cperl-electric-parens-mark' to have electric parens
+ look for active mark and \"embrace\" a region if possible.'
CPerl mode provides expansion of the Perl control constructs:
if, else, elsif, unless, while, until, for, and foreach.
***************
*** 706,719 ****
Setting the variable `cperl-font-lock' to t switches on
font-lock-mode, `cperl-electric-lbrace-space' to t switches on
! electric space between $ and {, `cperl-electric-parens' is the string
! that contains parentheses that should be electric in CPerl, setting
! `cperl-electric-keywords' enables electric expansion of control
! structures in CPerl. `cperl-electric-linefeed' governs which one of
! two linefeed behavior is preferable. You can enable all these options
! simultaneously (recommended mode of use) by setting `cperl-hairy' to
! t. In this case you can switch separate options off by setting them
! to `null'.
If your site has perl5 documentation in info format, you can use commands
\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it.
--- 810,826 ----
Setting the variable `cperl-font-lock' to t switches on
font-lock-mode, `cperl-electric-lbrace-space' to t switches on
! electric space between $ and {, `cperl-electric-parens-string' is the
! string that contains parentheses that should be electric in CPerl (see
! also `cperl-electric-parens-mark' and `cperl-electric-parens'),
! setting `cperl-electric-keywords' enables electric expansion of
! control structures in CPerl. `cperl-electric-linefeed' governs which
! one of two linefeed behavior is preferable. You can enable all these
! options simultaneously (recommended mode of use) by setting
! `cperl-hairy' to t. In this case you can switch separate options off
! by setting them to `null'. Note that one may undo the extra whitespace
! inserted by semis and braces in `auto-newline'-mode by consequent
! \\[cperl-electric-backspace].
If your site has perl5 documentation in info format, you can use commands
\\[cperl-info-on-current-command] and \\[cperl-info-on-command] to access it.
***************
*** 732,738 ****
regardless of where in the line point is when the TAB command is used.
`cperl-auto-newline'
Non-nil means automatically newline before and after braces,
! and after colons and semicolons, inserted in Perl code.
`cperl-indent-level'
Indentation of Perl statements within surrounding block.
The surrounding block's indentation is the indentation
--- 839,851 ----
regardless of where in the line point is when the TAB command is used.
`cperl-auto-newline'
Non-nil means automatically newline before and after braces,
! and after colons and semicolons, inserted in Perl code. The following
! \\[cperl-electric-backspace] will remove the inserted whitespace.
! Insertion after colons requires both this variable and
! `cperl-auto-newline-after-colon' set.
! `cperl-auto-newline-after-colon'
! Non-nil means automatically newline even after colons.
! Subject to `cperl-auto-newline' setting.
`cperl-indent-level'
Indentation of Perl statements within surrounding block.
The surrounding block's indentation is the indentation
***************
*** 825,831 ****
(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 *")
(make-local-variable 'comment-indent-function)
(setq comment-indent-function 'cperl-comment-indent)
(make-local-variable 'parse-sexp-ignore-comments)
--- 938,944 ----
(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 *")
(make-local-variable 'comment-indent-function)
(setq comment-indent-function 'cperl-comment-indent)
(make-local-variable 'parse-sexp-ignore-comments)
***************
*** 938,944 ****
(defun cperl-electric-brace (arg &optional only-before)
"Insert character and correct line's indentation.
If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the
! place (even in empty line), but not after."
(interactive "P")
(let (insertpos)
(if (and (not arg) ; No args, end (of empty line or auto)
--- 1051,1059 ----
(defun cperl-electric-brace (arg &optional only-before)
"Insert character and correct line's indentation.
If ONLY-BEFORE and `cperl-auto-newline', will insert newline before the
! place (even in empty line), but not after. 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)
***************
*** 947,952 ****
--- 1062,1074 ----
(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
***************
*** 973,990 ****
(defun cperl-electric-lbrace (arg)
"Insert character, correct line's indentation, correct quoting by space."
(interactive "P")
! (let (pos after (cperl-auto-newline cperl-auto-newline))
(and (cperl-val 'cperl-electric-lbrace-space)
(eq (preceding-char) ?$)
(save-excursion
(skip-chars-backward "$")
(looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)"))
(insert ? ))
! (if (cperl-after-expr-p) nil (setq cperl-auto-newline nil))
(cperl-electric-brace arg)
! (and (eq last-command-char ?{)
(memq last-command-char
! (append (cperl-val 'cperl-electric-parens "" "([{<") nil))
(setq last-command-char ?} pos (point))
(progn (cperl-electric-brace arg t)
(goto-char pos)))))
--- 1095,1123 ----
(defun cperl-electric-lbrace (arg)
"Insert character, correct line's indentation, correct quoting by space."
(interactive "P")
! (let (pos after
! (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)))
(and (cperl-val 'cperl-electric-lbrace-space)
(eq (preceding-char) ?$)
(save-excursion
(skip-chars-backward "$")
(looking-at "\\(\\$\\$\\)*\\$\\([^\\$]\\|$\\)"))
(insert ? ))
! (if (cperl-after-expr-p nil "{};)") nil (setq cperl-auto-newline nil))
(cperl-electric-brace arg)
! (and (cperl-val 'cperl-electric-parens)
! (eq last-command-char ?{)
(memq last-command-char
! (append cperl-electric-parens-string nil))
! (or (if other-end (goto-char (marker-position other-end)))
! t)
(setq last-command-char ?} pos (point))
(progn (cperl-electric-brace arg t)
(goto-char pos)))))
***************
*** 992,1000 ****
(defun cperl-electric-paren (arg)
"Insert a matching pair of parentheses."
(interactive "P")
! (let ((beg (save-excursion (beginning-of-line) (point))))
! (if (and (memq last-command-char
! (append (cperl-val 'cperl-electric-parens "" "([{<") nil))
(>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))
;;(not (save-excursion (search-backward "#" beg t)))
(if (eq last-command-char ?<)
--- 1125,1141 ----
(defun cperl-electric-paren (arg)
"Insert a matching pair of parentheses."
(interactive "P")
! (let ((beg (save-excursion (beginning-of-line) (point)))
! (other-end (if (and cperl-electric-parens-mark
! (cperl-mark-active)
! (> (mark) (point)))
! (save-excursion
! (goto-char (mark))
! (point-marker))
! nil)))
! (if (and (cperl-val 'cperl-electric-parens)
! (memq last-command-char
! (append cperl-electric-parens-string nil))
(>= (save-excursion (cperl-to-comment-or-eol) (point)) (point))
;;(not (save-excursion (search-backward "#" beg t)))
(if (eq last-command-char ?<)
***************
*** 1002,1007 ****
--- 1143,1149 ----
1))
(progn
(insert last-command-char)
+ (if other-end (goto-char (marker-position other-end)))
(insert (cdr (assoc last-command-char '((?{ .?})
(?[ . ?])
(?( . ?))
***************
*** 1012,1018 ****
(defun cperl-electric-keyword ()
"Insert a construction appropriate after a keyword."
! (let ((beg (save-excursion (beginning-of-line) (point))))
(and (save-excursion
(backward-sexp 1)
(cperl-after-expr-p nil "{};:"))
--- 1154,1161 ----
(defun cperl-electric-keyword ()
"Insert a construction appropriate after a keyword."
! (let ((beg (save-excursion (beginning-of-line) (point)))
! (dollar (eq (preceding-char) ?$)))
(and (save-excursion
(backward-sexp 1)
(cperl-after-expr-p nil "{};:"))
***************
*** 1024,1029 ****
--- 1167,1173 ----
(save-excursion (or (not (re-search-backward "^=" nil t))
(looking-at "=cut")))
(progn
+ (and dollar (insert " $"))
(cperl-indent-line)
;;(insert " () {\n}")
(cond
***************
*** 1039,1045 ****
)
(or (looking-at "[ \t]\\|$") (insert " "))
(cperl-indent-line)
! (search-backward ")")
(cperl-putback-char del-back-ch)))))
(defun cperl-electric-else ()
--- 1183,1191 ----
)
(or (looking-at "[ \t]\\|$") (insert " "))
(cperl-indent-line)
! (if dollar (progn (search-backward "$")
! (forward-char 1))
! (search-backward ")"))
(cperl-putback-char del-back-ch)))))
(defun cperl-electric-else ()
***************
*** 1081,1087 ****
(pos (point)) start)
(if (and ; Check if we need to split:
; i.e., on a boundary and inside "{...}"
- ;;(not (search-backward "\\(^\\|[^$\\\\]\\)#" beg t))
(save-excursion (cperl-to-comment-or-eol)
(>= (point) pos))
(or (save-excursion
--- 1227,1232 ----
***************
*** 1093,1113 ****
(save-excursion
(and
(eq (car (parse-partial-sexp pos end -1)) -1)
! (looking-at "[ \t]*\\($\\|#\\)")
! ;;(setq finish (point-marker))
(progn
(backward-sexp 1)
(setq start (point-marker))
! (<= start pos))
! ;;(looking-at "[^{}\n]*}[ \t]*$") ; Will fail if there are intervening {}'s
! ;;(search-backward "{" beg t)
! ;;(looking-at "{[^{}\n]*}[ \t]*$")
! )))
! ;;(or (looking-at "[ \t]*}") ; and on a boundary of statements
! ;; (save-excursion
! ;; (skip-chars-backward " \t")
! ;; (forward-char -1)
! ;; (looking-at "[{;]"))))
(progn
(skip-chars-backward " \t")
(or (memq (preceding-char) (append ";{" nil))
--- 1238,1248 ----
(save-excursion
(and
(eq (car (parse-partial-sexp pos end -1)) -1)
! (looking-at "[,; \t]*\\($\\|#\\)") ; Comma to allow anon subr
(progn
(backward-sexp 1)
(setq start (point-marker))
! (<= start pos)))))
(progn
(skip-chars-backward " \t")
(or (memq (preceding-char) (append ";{" nil))
***************
*** 1115,1122 ****
(insert "\n")
(forward-line -1)
(cperl-indent-line)
- ;;(end-of-line)
- ;;(search-backward "{" beg)
(goto-char start)
(or (looking-at "{[ \t]*$") ; If there is a statement
; before, move it to separate line
--- 1250,1255 ----
***************
*** 1127,1133 ****
(forward-line 1) ; We are on the target line
(cperl-indent-line)
(beginning-of-line)
! (or (looking-at "[ \t]*}[ \t]*$") ; If there is a statement
; after, move it to separate line
(progn
(end-of-line)
--- 1260,1266 ----
(forward-line 1) ; We are on the target line
(cperl-indent-line)
(beginning-of-line)
! (or (looking-at "[ \t]*}[,; \t]*$") ; If there is a statement
; after, move it to separate line
(progn
(end-of-line)
***************
*** 1157,1163 ****
(defun cperl-electric-terminator (arg)
"Insert character and correct line's indentation."
(interactive "P")
! (let (insertpos (end (point)))
(if (and (not arg) (eolp)
(not (save-excursion
(beginning-of-line)
--- 1290,1299 ----
(defun cperl-electric-terminator (arg)
"Insert character and correct line's indentation."
(interactive "P")
! (let (insertpos (end (point))
! (auto (and cperl-auto-newline
! (or (not (eq last-command-char ?:))
! cperl-auto-newline-after-colon))))
(if (and (not arg) (eolp)
(not (save-excursion
(beginning-of-line)
***************
*** 1180,1205 ****
(let ((pps (parse-partial-sexp (point) end)))
(or (nth 3 pps) (nth 4 pps) (nth 5 pps))))))))
(progn
- (if cperl-auto-newline
- (setq insertpos (point)))
(insert last-command-char)
(cperl-indent-line)
! (if cperl-auto-newline
(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-inside-parens-p ()
(condition-case ()
(save-excursion
--- 1316,1362 ----
(let ((pps (parse-partial-sexp (point) end)))
(or (nth 3 pps) (nth 4 pps) (nth 5 pps))))))))
(progn
(insert last-command-char)
+ (forward-char -1)
+ (if auto (setq insertpos (point-marker)))
+ (forward-char 1)
(cperl-indent-line)
! (if auto
(progn
(newline)
(cperl-indent-line)))
+ ;; (save-excursion
+ ;; (if insertpos (progn (goto-char (marker-position insertpos))
+ ;; (search-forward (make-string
+ ;; 1 last-command-char))
+ ;; (setq insertpos (1- (point)))))
+ ;; (delete-char -1))))
(save-excursion
! (if insertpos (goto-char (marker-position insertpos))
! (forward-char -1))
! (delete-char 1))))
(if insertpos
(save-excursion
(goto-char insertpos)
(self-insert-command (prefix-numeric-value arg)))
(self-insert-command (prefix-numeric-value arg)))))
+ (defun cperl-electric-backspace (arg)
+ "Backspace-untabify, or remove the whitespace inserted by an electric key."
+ (interactive "p")
+ (if (and cperl-auto-newline
+ (memq last-command '(cperl-electric-semi
+ cperl-electric-terminator
+ cperl-electric-lbrace))
+ (memq (preceding-char) '(? ?\t ?\n)))
+ (let (p)
+ (if (eq last-command 'cperl-electric-lbrace)
+ (skip-chars-forward " \t\n"))
+ (setq p (point))
+ (skip-chars-backward " \t\n")
+ (delete-region (point) p))
+ (backward-delete-char-untabify arg)))
+
(defun cperl-inside-parens-p ()
(condition-case ()
(save-excursion
***************
*** 1211,1217 ****
(error nil)))
(defun cperl-indent-command (&optional whole-exp)
- (interactive "P")
"Indent current line as Perl code, or in some cases insert a tab character.
If `cperl-tab-always-indent' is non-nil (the default), always indent current line.
Otherwise, indent the current line only if point is at the left margin
--- 1368,1373 ----
***************
*** 1221,1226 ****
--- 1377,1383 ----
means indent rigidly all the lines of the expression starting after point
so that this line becomes properly indented.
The relative indentation among the lines of the expression are preserved."
+ (interactive "P")
(if whole-exp
;; If arg, always indent this line as Perl
;; and shift remaining lines of expression the same amount.
***************
*** 1334,1340 ****
(and (eq (char-syntax (preceding-char)) ?w)
(progn
(backward-sexp)
! (or (looking-at "\\sw+[ \t\n\f]*[{#]") ; Method call syntax
(progn
(skip-chars-backward " \t\n\f")
(and (eq (char-syntax (preceding-char)) ?w)
--- 1491,1499 ----
(and (eq (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
! (not (looking-at "\\(bless\\|return\\|qw\\|tr\\|[smy]\\)\\>")))
(progn
(skip-chars-backward " \t\n\f")
(and (eq (char-syntax (preceding-char)) ?w)
***************
*** 1535,1551 ****
(progn
(if (eq (preceding-char) ?\))
(forward-sexp -1))
! ;; Get initial indentation of the line we are on.
! ;; If line starts with label, calculate label indentation
! (if (save-excursion
! (beginning-of-line)
! (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]"))
! (if (> (current-indentation) cperl-min-label-indent)
! (- (current-indentation) cperl-label-offset)
! (cperl-calculate-indent
! (if (and parse-start (<= parse-start (point)))
! parse-start)))
! (current-indentation))))))))))))
(defvar cperl-indent-alist
'((string nil)
--- 1694,1728 ----
(progn
(if (eq (preceding-char) ?\))
(forward-sexp -1))
! ;; In the case it starts a subroutine, indent with
! ;; respect to `sub', not with respect to the the
! ;; first thing on the line, say in the case of
! ;; anonymous sub in a hash.
! ;;
! (skip-chars-backward " \t")
! (if (and (eq (preceding-char) ?b)
! (progn
! (forward-word -1)
! (looking-at "sub\\>"))
! (setq old-indent
! (nth 1
! (parse-partial-sexp
! (save-excursion (beginning-of-line) (point))
! (point)))))
! (progn (goto-char (1+ old-indent))
! (skip-chars-forward " \t")
! (current-column))
! ;; Get initial indentation of the line we are on.
! ;; If line starts with label, calculate label indentation
! (if (save-excursion
! (beginning-of-line)
! (looking-at "[ \t]*[a-zA-Z_][a-zA-Z_]*:[^:]"))
! (if (> (current-indentation) cperl-min-label-indent)
! (- (current-indentation) cperl-label-offset)
! (cperl-calculate-indent
! (if (and parse-start (<= parse-start (point)))
! parse-start)))
! (current-indentation)))))))))))))
(defvar cperl-indent-alist
'((string nil)
***************
*** 1782,1788 ****
(let (face head-face here-face b e bb tag err
(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)))
(unwind-protect
(progn
(save-excursion
--- 1959,1966 ----
(let (face head-face here-face b e bb tag err
(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))
(unwind-protect
(progn
(save-excursion
***************
*** 1800,1827 ****
(message "=cut is not preceeded by a pod section")
(setq err (point)))
(beginning-of-line)
(setq b (point) bb b)
(or (re-search-forward "\n\n=cut\\>" max 'toend)
(message "Cannot find the end of a pod section"))
! (beginning-of-line 4)
(setq e (point))
(put-text-property b e 'in-pod t)
(goto-char b)
(while (re-search-forward "\n\n[ \t]" e t)
(beginning-of-line)
(put-text-property b (point) 'syntax-type 'pod)
! (put-text-property (max (point-min) (1- b))
! (point) cperl-do-not-fontify t)
(if cperl-pod-here-fontify (put-text-property b (point) 'face face))
(re-search-forward "\n\n[^ \t\f]" e 'toend)
(beginning-of-line)
(setq b (point)))
(put-text-property (point) e 'syntax-type 'pod)
! (put-text-property (max (point-min) (1- (point)))
! e cperl-do-not-fontify t)
(if cperl-pod-here-fontify
(progn (put-text-property (point) e 'face face)
(goto-char bb)
(while (re-search-forward
;; One paragraph
"\n\n=[a-zA-Z0-9]+\\>[ \t]*\\(\\(\n?[^\n]\\)+\\)$"
--- 1978,2013 ----
(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]" 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]\\)+\\)$"
***************
*** 1847,1856 ****
(progn
(put-text-property (match-beginning 0) (match-end 0)
'face font-lock-reference-face)
! (put-text-property (max (point-min) (1- b))
! (min (point-mox)
! (1+ (match-end 0)))
! cperl-do-not-fontify t)
(put-text-property b (match-beginning 0)
'face here-face)))
(put-text-property b (match-beginning 0)
--- 2033,2043 ----
(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)
***************
*** 2104,2119 ****
(defvar imenu-example--function-name-regexp-perl
"^\\([ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\|=head\\([12]\\)[ \t]+\\([^\n]+\\)$\\)")
(defun imenu-example--create-perl-index (&optional regexp)
(require 'cl)
(let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '())
(index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function))
packages ends-ranges p
(prev-pos 0) char fchar index index1 name (end-range 0) package)
(goto-char (point-min))
(imenu-progress-message prev-pos 0)
;; Search for the function
! (save-match-data
(while (re-search-forward
(or regexp imenu-example--function-name-regexp-perl)
nil t)
--- 2291,2327 ----
(defvar imenu-example--function-name-regexp-perl
"^\\([ \t]*\\(sub\\|package\\)[ \t\n]+\\([a-zA-Z_0-9:']+\\)[ \t]*\\|=head\\([12]\\)[ \t]+\\([^\n]+\\)$\\)")
+ (defun cperl-imenu-addback (lst &optional isback name)
+ ;; We suppose that the lst is a DAG, unless the first element only
+ ;; loops back, and ISBACK is set. Thus this function cannot be
+ ;; applied twice without ISBACK set.
+ (cond ((not cperl-imenu-addback) lst)
+ (t
+ (or name
+ (setq name "+++BACK+++"))
+ (mapcar (function (lambda (elt)
+ (if (and (listp elt) (listp (cdr elt)))
+ (progn
+ ;; In the other order it goes up
+ ;; one level only ;-(
+ (setcdr elt (cons (cons name lst)
+ (cdr elt)))
+ (cperl-imenu-addback (cdr elt) t name)
+ ))))
+ (if isback (cdr lst) lst))
+ lst)))
+
(defun imenu-example--create-perl-index (&optional regexp)
(require 'cl)
(let ((index-alist '()) (index-pack-alist '()) (index-pod-alist '())
(index-unsorted-alist '()) (i-s-f (default-value 'imenu-sort-function))
+ (index-meth-alist '()) meth
packages ends-ranges p
(prev-pos 0) char fchar index index1 name (end-range 0) package)
(goto-char (point-min))
(imenu-progress-message prev-pos 0)
;; Search for the function
! (progn ;;save-match-data
(while (re-search-forward
(or regexp imenu-example--function-name-regexp-perl)
nil t)
***************
*** 2125,2131 ****
(goto-char (match-beginning 2))
(setq fchar (following-char))
)
! (setq char (following-char))
(setq p (point))
(while (and ends-ranges (>= p (car ends-ranges)))
;; delete obsolete entries
--- 2333,2339 ----
(goto-char (match-beginning 2))
(setq fchar (following-char))
)
! (setq char (following-char) meth nil)
(setq p (point))
(while (and ends-ranges (>= p (car ends-ranges)))
;; delete obsolete entries
***************
*** 2133,2159 ****
(setq package (or (car packages) "")
end-range (or (car ends-ranges) 0))
(if (eq fchar ?p)
! (progn
! (setq name (buffer-substring (match-beginning 3) (match-end 3))
! package (concat name "::")
! name (concat "package " name)
! end-range
! (save-excursion
! (parse-partial-sexp (point) (point-max) -1) (point))
! ends-ranges (cons end-range ends-ranges)
! packages (cons package packages))))
;; )
;; Skip this function name if it is a prototype declaration.
(if (and (eq fchar ?s) (eq char ?\;)) nil
(if (eq fchar ?p) nil
(setq name (buffer-substring (match-beginning 3) (match-end 3)))
! (if (or (> p end-range) (string-match "[:']" name)) nil
! (setq name (concat package name))))
! (setq index (imenu-example--name-and-position))
(setcar index name)
(if (eq fchar ?p)
(push index index-pack-alist)
(push index index-alist))
(push index index-unsorted-alist)))
(t ; Pod section
;; (beginning-of-line)
--- 2341,2370 ----
(setq package (or (car packages) "")
end-range (or (car ends-ranges) 0))
(if (eq fchar ?p)
! (setq name (buffer-substring (match-beginning 3) (match-end 3))
! package (concat name "::")
! name (concat "package " name)
! end-range
! (save-excursion
! (parse-partial-sexp (point) (point-max) -1) (point))
! ends-ranges (cons end-range ends-ranges)
! packages (cons package packages)))
;; )
;; Skip this function name if it is a prototype declaration.
(if (and (eq fchar ?s) (eq char ?\;)) nil
+ (setq index (imenu-example--name-and-position))
(if (eq fchar ?p) nil
(setq name (buffer-substring (match-beginning 3) (match-end 3)))
! (cond ((string-match "[:']" name)
! (setq meth t))
! ((> p end-range) nil)
! (t
! (setq name (concat package name) meth t))))
(setcar index name)
(if (eq fchar ?p)
(push index index-pack-alist)
(push index index-alist))
+ (if meth (push index index-meth-alist))
(push index index-unsorted-alist)))
(t ; Pod section
;; (beginning-of-line)
***************
*** 2171,2190 ****
(sort index-alist (default-value 'imenu-sort-function))
(nreverse index-alist)))
(and index-pod-alist
! (push (cons (imenu-create-submenu-name "+POD headers+")
(nreverse index-pod-alist))
index-alist))
(and index-pack-alist
! (push (cons (imenu-create-submenu-name "+Packages+")
(nreverse index-pack-alist))
index-alist))
(and (or index-pack-alist index-pod-alist
(default-value 'imenu-sort-function))
index-unsorted-alist
! (push (cons (imenu-create-submenu-name "+Unsorted List+")
(nreverse index-unsorted-alist))
index-alist))
! index-alist))
(defvar cperl-compilation-error-regexp-alist
;; This look like a paranoiac regexp: could anybody find a better one? (which WORK).
--- 2382,2434 ----
(sort index-alist (default-value 'imenu-sort-function))
(nreverse index-alist)))
(and index-pod-alist
! (push (cons "+POD headers+..."
(nreverse index-pod-alist))
index-alist))
+ (and (or index-pack-alist index-meth-alist)
+ (let ((lst index-pack-alist) hier-list pack elt group name)
+ ;; Remove "package ", reverse and uniquify.
+ (while lst
+ (setq elt (car lst) lst (cdr lst) name (substring (car elt) 8))
+ (if (assoc name hier-list) nil
+ (setq hier-list (cons (cons name (cdr elt)) hier-list))))
+ (setq lst index-meth-alist)
+ (while lst
+ (setq elt (car lst) lst (cdr lst))
+ (string-match "\\(::\\|'\\)[_a-zA-Z0-9]+$" (car elt))
+ (setq pack (substring (car elt) 0 (match-beginning 0)))
+ (if (setq group (assoc pack hier-list))
+ (if (listp (cdr group))
+ ;; Have some functions already
+ (setcdr group (cons (cons (substring
+ (car elt)
+ (+ 2 (match-beginning 0)))
+ (cdr elt))
+ (cdr group)))
+ (setcdr group (list (cons (substring
+ (car elt)
+ (+ 2 (match-beginning 0)))
+ (cdr elt)))))
+ (setq hier-list
+ (cons (cons pack (list (cons (substring
+ (car elt)
+ (+ 2 (match-beginning 0)))
+ (cdr elt))))
+ hier-list))))
+ (push (cons "+Hierarchy+..."
+ hier-list)
+ index-alist)))
(and index-pack-alist
! (push (cons "+Packages+..."
(nreverse index-pack-alist))
index-alist))
(and (or index-pack-alist index-pod-alist
(default-value 'imenu-sort-function))
index-unsorted-alist
! (push (cons "+Unsorted List+..."
(nreverse index-unsorted-alist))
index-alist))
! (cperl-imenu-addback index-alist)))
(defvar cperl-compilation-error-regexp-alist
;; This look like a paranoiac regexp: could anybody find a better one? (which WORK).
***************
*** 2881,2883 ****
--- 3125,3514 ----
(setq res (apply 'call-process cmd nil nil nil args))
(or (eq res 0)
(message "etags returned \"%s\"" res))))
+
+ (defun cperl-toggle-auto-newline ()
+ "Toggle the state of `cperl-auto-newline'."
+ (interactive)
+ (setq cperl-auto-newline (not cperl-auto-newline))
+ (message "Newlines will %sbe auto-inserted now."
+ (if cperl-auto-newline "" "not ")))
+
+ (defun cperl-toggle-abbrev ()
+ "Toggle the state of automatic keyword expansion in CPerl mode."
+ (interactive)
+ (abbrev-mode (if abbrev-mode 0 1))
+ (message "Perl control structure will %sbe auto-inserted now."
+ (if abbrev-mode "" "not ")))
+
+
+ (defun cperl-toggle-electric ()
+ "Toggle the state of parentheses doubling in CPerl mode."
+ (interactive)
+ (setq cperl-electric-parens (if (cperl-val 'cperl-electric-parens) 'null t))
+ (message "Parentheses will %sbe auto-doubled now."
+ (if (cperl-val 'cperl-electric-parens) "" "not ")))
+
+ ;;;; Tags file creation.
+
+ (defvar cperl-tmp-buffer " *cperl-tmp*")
+
+ (defun cperl-setup-tmp-buf ()
+ (set-buffer (get-buffer-create cperl-tmp-buffer))
+ (set-syntax-table cperl-mode-syntax-table)
+ (buffer-disable-undo)
+ (auto-fill-mode 0))
+
+ (defun cperl-xsub-scan ()
+ (require 'cl)
+ (let ((index-alist '())
+ (prev-pos 0) index index1 name package prefix)
+ (goto-char (point-min))
+ (imenu-progress-message prev-pos 0)
+ ;; Search for the function
+ (progn ;;save-match-data
+ (while (re-search-forward
+ "^\\([ \t]*MODULE\\>[^\n]*\\<PACKAGE[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9:]*\\)\\>\\|\\([a-zA-Z_][a-zA-Z_0-9]*\\)(\\|[ \t]*BOOT:\\)"
+ nil t)
+ (imenu-progress-message prev-pos)
+ (cond
+ ((match-beginning 2) ; SECTION
+ (setq package (buffer-substring (match-beginning 2) (match-end 2)))
+ (goto-char (match-beginning 0))
+ (skip-chars-forward " \t")
+ (forward-char 1)
+ (if (looking-at "[^\n]*\\<PREFIX[ \t]*=[ \t]*\\([a-zA-Z_][a-zA-Z_0-9]*\\)\\>")
+ (setq prefix (buffer-substring (match-beginning 1) (match-end 1)))
+ (setq prefix nil)))
+ ((not package) nil) ; C language section
+ ((match-beginning 3) ; XSUB
+ (goto-char (1+ (match-beginning 3)))
+ (setq index (imenu-example--name-and-position))
+ (setq name (buffer-substring (match-beginning 3) (match-end 3)))
+ (if (and prefix (string-match (concat "^" prefix) name))
+ (setq name (substring name (length prefix))))
+ (setq meth nil)
+ (cond ((string-match "::" name) nil)
+ (t
+ (setq index1 (cons (concat package "::" name) (cdr index)))
+ (push index1 index-alist)))
+ (setcar index name)
+ (push index index-alist))
+ (t ; BOOT: section
+ ;; (beginning-of-line)
+ (setq index (imenu-example--name-and-position))
+ (setcar index (concat package "::BOOT:"))
+ (push index index-alist)))))
+ (imenu-progress-message prev-pos 100)
+ ;;(setq index-alist
+ ;; (if (default-value 'imenu-sort-function)
+ ;; (sort index-alist (default-value 'imenu-sort-function))
+ ;; (nreverse index-alist)))
+ index-alist))
+
+ (defun cperl-find-tags (file xs)
+ (let (ind (b (get-buffer cperl-tmp-buffer)) lst elt pos ret)
+ (save-excursion
+ (if b (set-buffer b)
+ (cperl-setup-tmp-buf))
+ (erase-buffer)
+ (setq file (car (insert-file-contents file)))
+ (message "Scanning file %s..." file)
+ (if xs
+ (setq lst (cperl-xsub-scan))
+ (setq ind (imenu-example--create-perl-index))
+ (setq lst (cdr (assoc "+Unsorted List+..." ind))))
+ (setq lst
+ (mapcar
+ (function
+ (lambda (elt)
+ (cond ((string-match "^[_a-zA-Z]" (car elt))
+ (goto-char (cdr elt))
+ (list (car elt)
+ (point) (count-lines 1 (point))
+ (buffer-substring (progn
+ (skip-chars-forward
+ ":_a-zA-Z0-9")
+ (or (eolp) (forward-char 1))
+ (point))
+ (progn
+ (beginning-of-line)
+ (point))))))))
+ lst))
+ (erase-buffer)
+ (while lst
+ (setq elt (car lst) lst (cdr lst))
+ (if elt
+ (progn
+ (insert (elt elt 3)
+ 127
+ (if (string-match "^package " (car elt))
+ (substring (car elt) 8)
+ (car elt) )
+ 1
+ (number-to-string (elt elt 1))
+ ","
+ (number-to-string (elt elt 2))
+ "\n")
+ (if (and (string-match "^[_a-zA-Z]+::" (car elt))
+ (string-match "^sub[ \t]+\\([_a-zA-Z]+\\)[^:_a-zA-Z]"
+ (elt elt 3)))
+ ;; Need to insert the name without package as well
+ (setq lst (cons (cons (substring (elt elt 3)
+ (match-beginning 1)
+ (match-end 1))
+ (cdr elt))
+ lst))))))
+ (setq pos (point))
+ (goto-char 1)
+ (insert "\f\n" file "," (number-to-string (1- pos)) "\n")
+ (setq ret (buffer-substring 1 (point-max)))
+ (erase-buffer)
+ (message "Scanning file %s finished" file)
+ ret)))
+
+ (defun cperl-write-tags (&optional file erase recurse dir inbuffer)
+ ;; If INBUFFER, do not select buffer, and do not save
+ ;; If ERASE is `ignore', do not erase, and do not try to delete old info.
+ (if file nil
+ (setq file (if dir default-directory (buffer-file-name)))
+ (if (and (not dir) (buffer-modified-p)) (error "Save buffer first!")))
+ (let ((tags-file-name "TAGS")
+ (case-fold-search (eq system-type 'emx))
+ xs)
+ (save-excursion
+ (cond (inbuffer nil) ; Already there
+ ((file-exists-p tags-file-name)
+ (visit-tags-table-buffer tags-file-name))
+ (t (set-buffer (find-file-noselect tags-file-name))))
+ (cond
+ (dir
+ (cond ((eq erase 'ignore))
+ (erase
+ (erase-buffer)
+ (setq erase 'ignore)))
+ (let ((files
+ (directory-files file t (if recurse nil "\\.[Pp][Llm]$") t)))
+ (mapcar (function (lambda (file)
+ (cond
+ ((string-match "/\\.\\.?$" file) nil)
+ ((not (file-directory-p file))
+ (if (string-match "\\.\\([Pp][Llm]\\|xs\\)$" file)
+ (cperl-write-tags file erase recurse nil t)))
+ ((not recurse) nil)
+ (t (cperl-write-tags file erase recurse t t)))))
+ files))
+ )
+ (t
+ (setq xs (string-match "\\.xs$" file))
+ (cond ((eq erase 'ignore) nil)
+ (erase (erase-buffer))
+ (t
+ (goto-char 1)
+ (if (search-forward (concat "\f\n" file ",") nil t)
+ (progn
+ (search-backward "\f\n")
+ (delete-region (point)
+ (progn
+ (forward-char 1)
+ (search-forward "\f\n" nil 'toend)
+ (point)))
+ (goto-char 1)))))
+ (insert (cperl-find-tags file xs))))
+ (if inbuffer nil ; Delegate to the caller
+ (save-buffer 0) ; No backup
+ (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]+::\\)")
+
+ (defvar cperl-hierarchy '(() ())
+ "Global hierarchy of classes")
+
+ (defun cperl-tags-hier-fill ()
+ ;; Suppose we are in a tag table cooked by cperl.
+ (goto-char 1)
+ (let (type pack name pos line chunk ord cons1 file str info fileind)
+ (while (re-search-forward cperl-tags-hier-regexp-list nil t)
+ (setq pos (match-beginning 0)
+ pack (match-beginning 2))
+ (beginning-of-line)
+ (if (looking-at "\\([^\n]+\\)\C-?\\([^\n]+\\)\C-a\\([0-9]+\\),\\([0-9]+\\)")
+ (progn
+ (setq ;;str (buffer-substring (match-beginning 1) (match-end 1))
+ name (buffer-substring (match-beginning 2) (match-end 2))
+ ;;pos (buffer-substring (match-beginning 3) (match-end 3))
+ line (buffer-substring (match-beginning 4) (match-end 4))
+ ord (if pack 1 0)
+ info (etags-snarf-tag) ; Moves to beginning of the next line
+ file (file-of-tag)
+ fileind (format "%s:%s" file line))
+ ;; Move back
+ (forward-char -1)
+ ;; Make new member of hierarchy name ==> file ==> pos if needed
+ (if (setq cons1 (assoc name (nth ord cperl-hierarchy)))
+ ;; Name known
+ (setcdr cons1 (cons (cons fileind (vector file info))
+ (cdr cons1)))
+ ;; First occurence of the name, start alist
+ (setq cons1 (cons name (list (cons fileind (vector file info)))))
+ (if pack
+ (setcar (cdr cperl-hierarchy)
+ (cons cons1 (nth 1 cperl-hierarchy)))
+ (setcar cperl-hierarchy
+ (cons cons1 (car cperl-hierarchy)))))))
+ (end-of-line))))
+
+ (defun cperl-tags-hier-init (&optional update)
+ "Show hierarchical menu of classes and methods.
+ Finds info about classes by a scan of loaded TAGS files.
+ Supposes that the TAGS files contain fully qualified function names.
+ One may build such TAGS files from CPerl mode menu."
+ (interactive)
+ (require 'etags)
+ (require 'imenu)
+ (if (or update (null (nth 2 cperl-hierarchy)))
+ (let (pack name cons1 to l1 l2 l3 l4
+ (remover (function (lambda (elt) ; (name (file1...) (file2..))
+ (or (nthcdr 2 elt)
+ ;; Only in one file
+ (setcdr elt (cdr (nth 1 elt))))))))
+ ;; (setq cperl-hierarchy '(() () ())) ; Would write into '() later!
+ (setq cperl-hierarchy (list l1 l2 l3))
+ (or tags-table-list
+ (call-interactively 'visit-tags-table))
+ (message "Updating list of classes...")
+ (mapcar
+ (function
+ (lambda (tagsfile)
+ (set-buffer (get-file-buffer tagsfile))
+ (cperl-tags-hier-fill)))
+ tags-table-list)
+ (mapcar remover (car cperl-hierarchy))
+ (mapcar remover (nth 1 cperl-hierarchy))
+ (setq to (list nil (cons "Packages: " (nth 1 cperl-hierarchy))
+ (cons "Methods: " (car cperl-hierarchy))))
+ (cperl-tags-treeify to 1)
+ (setcar (nthcdr 2 cperl-hierarchy)
+ (cperl-menu-to-keymap (cons '("+++UPDATE+++" . -999) (cdr to))))
+ (message "Updating list of classes: done, requesting display...")
+ ;;(cperl-imenu-addback (nth 2 cperl-hierarchy))
+ ))
+ (or (nth 2 cperl-hierarchy)
+ (error "No items found"))
+ (setq update
+ ;;; (imenu-choose-buffer-index "Packages: " (nth 2 cperl-hierarchy))
+ (if window-system
+ (x-popup-menu t (nth 2 cperl-hierarchy))
+ (require 'tmm)
+ (tmm-prompt t (nth 2 cperl-hierarchy))))
+ (if (and update (listp update))
+ (progn (while (cdr update) (setq update (cdr update)))
+ (setq update (car update)))) ; Get the last from the list
+ (if (vectorp update)
+ (progn
+ (find-file (elt update 0))
+ (etags-goto-tag-location (elt update 1))))
+ (if (eq update -999) (cperl-tags-hier-init t)))
+
+ (defun cperl-tags-treeify (to level)
+ ;; cadr of to is read-write. On start it is a cons
+ (let* ((regexp (concat "^\\(" (mapconcat
+ 'identity
+ (make-list level "[_a-zA-Z0-9]+")
+ "::")
+ "\\)\\(::\\)?"))
+ (packages (cdr (nth 1 to)))
+ (methods (cdr (nth 2 to)))
+ l1 head tail cons1 cons2 ord writeto packs recurse
+ root-packages root-functions ms many_ms same_name ps
+ (move-deeper
+ (function
+ (lambda (elt)
+ (cond ((and (string-match regexp (car elt))
+ (or (eq ord 1) (match-end 2)))
+ (setq head (substring (car elt) 0 (match-end 1))
+ tail (if (match-end 2) (substring (car elt)
+ (match-end 2)))
+ recurse t)
+ (if (setq cons1 (assoc head writeto)) nil
+ ;; Need to init new head
+ (setcdr writeto (cons (list head (list "Packages: ")
+ (list "Methods: "))
+ (cdr writeto)))
+ (setq cons1 (nth 1 writeto)))
+ (setq cons2 (nth ord cons1)) ; Either packs or meths
+ (setcdr cons2 (cons elt (cdr cons2))))
+ ((eq ord 2)
+ (setq root-functions (cons elt root-functions)))
+ (t
+ (setq root-packages (cons elt root-packages))))))))
+ (setcdr to l1) ; Init to dynamic space
+ (setq writeto to)
+ (setq ord 1)
+ (mapcar move-deeper packages)
+ (setq ord 2)
+ (mapcar move-deeper methods)
+ (if recurse
+ (mapcar (function (lambda (elt)
+ (cperl-tags-treeify elt (1+ level))))
+ (cdr to)))
+ ;; Now add back functions removed from display
+ (mapcar (function (lambda (elt)
+ (setcdr to (cons elt (cdr to)))))
+ root-functions)
+ ;; Now add back packages removed from display
+ (mapcar (function (lambda (elt)
+ (setcdr to (cons (cons (concat "package " (car elt))
+ (cdr elt))
+ (cdr to)))))
+ root-packages)
+ ;;Now clean up leaders with one child only
+ (mapcar (function (lambda (elt)
+ (if (not (and (listp (cdr elt))
+ (eq (length elt) 2))) nil
+ (setcar elt (car (nth 1 elt)))
+ (setcdr elt (cdr (nth 1 elt))))))
+ (cdr to))
+ ))
+
+ ;;;(x-popup-menu t
+ ;;; '(keymap "Name1"
+ ;;; ("Ret1" "aa")
+ ;;; ("Head1" "ab"
+ ;;; keymap "Name2"
+ ;;; ("Tail1" "x") ("Tail2" "y"))))
+
+ (defun cperl-list-fold (list name limit)
+ (let (list1 list2 elt1 (num 0))
+ (if (<= (length list) limit) list
+ (setq list1 nil list2 nil)
+ (while list
+ (setq num (1+ num)
+ elt1 (car list)
+ list (cdr list))
+ (if (<= num imenu-max-items)
+ (setq list2 (cons elt1 list2))
+ (setq list1 (cons (cons name
+ (nreverse list2))
+ list1)
+ list2 (list elt1)
+ num 1)))
+ (nreverse (cons (cons name
+ (nreverse list2))
+ list1)))))
+
+ (defun cperl-menu-to-keymap (menu &optional name)
+ (let (list)
+ (cons 'keymap
+ (mapcar
+ (function
+ (lambda (elt)
+ (cond ((listp (cdr elt))
+ (setq list (cperl-list-fold
+ (cdr elt) (car elt) imenu-max-items))
+ (cons nil
+ (cons (car elt)
+ (cperl-menu-to-keymap list))))
+ (t
+ (list (cdr elt) (car elt))))))
+ (cperl-list-fold menu "Root" imenu-max-items)))))
#~ Add banner warning to discourage direct changes to embed.h
#~ Incorporate new symbols and name changes to reduce C namespace collisions
diff -Pcr perl5_003/embed.h perl5_003_01/embed.h
*** perl5_003/embed.h Mon Mar 25 01:04:04 1996
--- perl5_003_01/embed.h Wed Jul 17 11:12:12 1996
***************
*** 1,4 ****
! /* This file is derived from global.sym and interp.sym */
/* (Doing namespace management portably in C is really gross.) */
--- 1,7 ----
! /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
! This file is derived from global.sym and interp.sym
! Any changes made here will be lost
! */
/* (Doing namespace management portably in C is really gross.) */
***************
*** 41,46 ****
--- 44,50 ----
#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
***************
*** 49,54 ****
--- 53,59 ----
#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
***************
*** 161,166 ****
--- 166,173 ----
#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
***************
*** 172,178 ****
#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
--- 179,185 ----
#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
***************
*** 219,225 ****
#define sle_amg Perl_sle_amg
#define slt_amg Perl_slt_amg
#define sne_amg Perl_sne_amg
- #define stack Perl_stack
#define stack_base Perl_stack_base
#define stack_max Perl_stack_max
#define stack_sp Perl_stack_sp
--- 226,231 ----
***************
*** 310,316 ****
#define cast_ulong Perl_cast_ulong
#define check_uni Perl_check_uni
#define checkcomma Perl_checkcomma
- #define chsize Perl_chsize
#define ck_aelem Perl_ck_aelem
#define ck_concat Perl_ck_concat
#define ck_delete Perl_ck_delete
--- 316,321 ----
***************
*** 426,431 ****
--- 431,437 ----
#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
***************
*** 433,448 ****
--- 439,459 ----
#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
***************
*** 461,472 ****
--- 472,485 ----
#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 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
***************
*** 506,511 ****
--- 519,525 ----
#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
***************
*** 992,997 ****
--- 1006,1012 ----
#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
***************
*** 1059,1064 ****
--- 1074,1080 ----
#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
***************
*** 1080,1085 ****
--- 1096,1109 ----
#ifdef MULTIPLICITY
+ /* Undefine symbols that were defined by EMBED. Somewhat ugly */
+
+ #undef curcop
+ #undef envgv
+ #undef siggv
+ #undef stack
+ #undef tainting
+
#define Argv (curinterp->IArgv)
#define Cmd (curinterp->ICmd)
#define DBgv (curinterp->IDBgv)
***************
*** 1100,1107 ****
--- 1124,1133 ----
#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)
***************
*** 1153,1158 ****
--- 1179,1185 ----
#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)
***************
*** 1183,1190 ****
#define origfilename (curinterp->Iorigfilename)
#define ors (curinterp->Iors)
#define orslen (curinterp->Iorslen)
- #define pad (curinterp->Ipad)
- #define padname (curinterp->Ipadname)
#define parsehook (curinterp->Iparsehook)
#define patchlevel (curinterp->Ipatchlevel)
#define perldb (curinterp->Iperldb)
--- 1210,1215 ----
***************
*** 1210,1222 ****
#define sortstack (curinterp->Isortstack)
#define sortstash (curinterp->Isortstash)
#define splitstr (curinterp->Isplitstr)
- #define stack (curinterp->Istack)
#define statcache (curinterp->Istatcache)
#define statgv (curinterp->Istatgv)
#define statname (curinterp->Istatname)
#define statusvalue (curinterp->Istatusvalue)
#define stdingv (curinterp->Istdingv)
#define strchop (curinterp->Istrchop)
#define sv_count (curinterp->Isv_count)
#define sv_objcount (curinterp->Isv_objcount)
#define sv_root (curinterp->Isv_root)
--- 1235,1247 ----
#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)
***************
*** 1254,1261 ****
--- 1279,1288 ----
#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
***************
*** 1307,1312 ****
--- 1334,1340 ----
#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
***************
*** 1337,1344 ****
#define Iorigfilename origfilename
#define Iors ors
#define Iorslen orslen
- #define Ipad pad
- #define Ipadname padname
#define Iparsehook parsehook
#define Ipatchlevel patchlevel
#define Iperldb perldb
--- 1365,1370 ----
***************
*** 1364,1376 ****
#define Isortstack sortstack
#define Isortstash sortstash
#define Isplitstr splitstr
- #define Istack stack
#define Istatcache statcache
#define Istatgv statgv
#define Istatname statname
#define Istatusvalue statusvalue
#define Istdingv stdingv
#define Istrchop strchop
#define Isv_count sv_count
#define Isv_objcount sv_objcount
#define Isv_root sv_root
--- 1390,1402 ----
#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
#~ Add banner warning to embed.h to discourage direct changes
#~ Insure that symbols aren't defined once with EMBVED prefix and
#~ again in MULTIPLICITY block
diff -Pcr perl5_003/embed.pl perl5_003_01/embed.pl
*** perl5_003/embed.pl Mon Mar 25 01:04:04 1996
--- perl5_003_01/embed.pl Thu Jul 4 14:36:06 1996
***************
*** 3,9 ****
open(EM, ">embed.h") || die "Can't create embed.h: $!\n";
print EM <<'END';
! /* This file is derived from global.sym and interp.sym */
/* (Doing namespace management portably in C is really gross.) */
--- 3,12 ----
open(EM, ">embed.h") || 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
! */
/* (Doing namespace management portably in C is really gross.) */
***************
*** 41,46 ****
--- 44,57 ----
/* Put interpreter specific symbols into a struct? */
#ifdef MULTIPLICITY
+
+ /* Undefine symbols that were defined by EMBED. Somewhat ugly */
+
+ #undef curcop
+ #undef envgv
+ #undef siggv
+ #undef stack
+ #undef tainting
END
#~ Update to version 1.02
diff -Pcr perl5_003/ext/DB_File/DB_File.pm perl5_003_01/ext/DB_File/DB_File.pm
*** perl5_003/ext/DB_File/DB_File.pm Mon Feb 12 14:50:03 1996
--- perl5_003_01/ext/DB_File/DB_File.pm Fri Jul 5 18:47:36 1996
***************
*** 1,181 ****
# DB_File.pm -- Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
! # last modified 14th November 1995
! # version 1.01
package DB_File::HASHINFO ;
use strict;
- use vars qw(%elements);
use Carp;
! sub TIEHASH
{
! bless {} ;
}
! %elements = ( 'bsize' => 0,
! 'ffactor' => 0,
! 'nelem' => 0,
! 'cachesize' => 0,
! 'hash' => 0,
! 'lorder' => 0
! ) ;
sub FETCH
{
! return $_[0]{$_[1]} if defined $elements{$_[1]} ;
! croak "DB_File::HASHINFO::FETCH - Unknown element '$_[1]'" ;
}
sub STORE
{
! if ( defined $elements{$_[1]} )
{
! $_[0]{$_[1]} = $_[2] ;
return ;
}
! croak "DB_File::HASHINFO::STORE - Unknown element '$_[1]'" ;
}
sub DELETE
{
! if ( defined $elements{$_[1]} )
{
! delete ${$_[0]}{$_[1]} ;
return ;
}
! croak "DB_File::HASHINFO::DELETE - Unknown element '$_[1]'" ;
}
!
! sub DESTROY {undef %{$_[0]} }
! sub FIRSTKEY { croak "DB_File::HASHINFO::FIRSTKEY is not implemented" }
! sub NEXTKEY { croak "DB_File::HASHINFO::NEXTKEY is not implemented" }
! sub EXISTS { croak "DB_File::HASHINFO::EXISTS is not implemented" }
! sub CLEAR { croak "DB_File::HASHINFO::CLEAR is not implemented" }
!
! package DB_File::BTREEINFO ;
!
! use strict;
! use vars qw(%elements);
! use Carp;
!
! sub TIEHASH
{
! bless {} ;
! }
! %elements = ( 'flags' => 0,
! 'cachesize' => 0,
! 'maxkeypage' => 0,
! 'minkeypage' => 0,
! 'psize' => 0,
! 'compare' => 0,
! 'prefix' => 0,
! 'lorder' => 0
! ) ;
!
! sub FETCH
! {
! return $_[0]{$_[1]} if defined $elements{$_[1]} ;
!
! croak "DB_File::BTREEINFO::FETCH - Unknown element '$_[1]'" ;
}
!
! sub STORE
{
! if ( defined $elements{$_[1]} )
! {
! $_[0]{$_[1]} = $_[2] ;
! return ;
! }
!
! croak "DB_File::BTREEINFO::STORE - Unknown element '$_[1]'" ;
! }
! sub DELETE
! {
! if ( defined $elements{$_[1]} )
! {
! delete ${$_[0]}{$_[1]} ;
! return ;
! }
!
! croak "DB_File::BTREEINFO::DELETE - Unknown element '$_[1]'" ;
}
!
! sub DESTROY {undef %{$_[0]} }
! sub FIRSTKEY { croak "DB_File::BTREEINFO::FIRSTKEY is not implemented" }
! sub NEXTKEY { croak "DB_File::BTREEINFO::NEXTKEY is not implemented" }
! sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" }
! sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" }
package DB_File::RECNOINFO ;
! use strict;
! use vars qw(%elements);
! use Carp;
sub TIEHASH
{
! bless {} ;
}
! %elements = ( 'bval' => 0,
! 'cachesize' => 0,
! 'psize' => 0,
! 'flags' => 0,
! 'lorder' => 0,
! 'reclen' => 0,
! 'bfname' => 0
! ) ;
! sub FETCH
! {
! return $_[0]{$_[1]} if defined $elements{$_[1]} ;
! croak "DB_File::RECNOINFO::FETCH - Unknown element '$_[1]'" ;
! }
! sub STORE
{
! if ( defined $elements{$_[1]} )
! {
! $_[0]{$_[1]} = $_[2] ;
! return ;
! }
!
! croak "DB_File::RECNOINFO::STORE - Unknown element '$_[1]'" ;
! }
! sub DELETE
! {
! if ( defined $elements{$_[1]} )
! {
! delete ${$_[0]}{$_[1]} ;
! return ;
! }
!
! croak "DB_File::RECNOINFO::DELETE - Unknown element '$_[1]'" ;
}
- sub DESTROY {undef %{$_[0]} }
- sub FIRSTKEY { croak "DB_File::RECNOINFO::FIRSTKEY is not implemented" }
- sub NEXTKEY { croak "DB_File::RECNOINFO::NEXTKEY is not implemented" }
- sub EXISTS { croak "DB_File::BTREEINFO::EXISTS is not implemented" }
- sub CLEAR { croak "DB_File::BTREEINFO::CLEAR is not implemented" }
-
-
-
package DB_File ;
use strict;
--- 1,143 ----
# 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
package DB_File::HASHINFO ;
use strict;
use Carp;
+ require Tie::Hash;
+ @DB_File::HASHINFO::ISA = qw(Tie::Hash);
! sub new
{
! my $pkg = shift ;
! my %x ;
! tie %x, $pkg ;
! bless \%x, $pkg ;
}
! sub TIEHASH
! {
! my $pkg = shift ;
!
! bless { 'bsize' => undef,
! 'ffactor' => undef,
! 'nelem' => undef,
! 'cachesize' => undef,
! 'hash' => undef,
! 'lorder' => undef,
! }, $pkg ;
! }
sub FETCH
{
! my $self = shift ;
! my $key = shift ;
!
! return $self->{$key} if exists $self->{$key} ;
! my $pkg = ref $self ;
! croak "${pkg}::FETCH - Unknown element '$key'" ;
}
sub STORE
{
! my $self = shift ;
! my $key = shift ;
! my $value = shift ;
!
! if ( exists $self->{$key} )
{
! $self->{$key} = $value ;
return ;
}
! my $pkg = ref $self ;
! croak "${pkg}::STORE - Unknown element '$key'" ;
}
sub DELETE
{
! my $self = shift ;
! my $key = shift ;
!
! if ( exists $self->{$key} )
{
! delete $self->{$key} ;
return ;
}
! my $pkg = ref $self ;
! croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ;
}
! sub EXISTS
{
! my $self = shift ;
! my $key = shift ;
! exists $self->{$key} ;
}
! sub NotHere
{
! my $pkg = shift ;
! my $method = shift ;
! croak "${pkg} 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") }
package DB_File::RECNOINFO ;
! use strict ;
!
! @DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;
sub TIEHASH
{
! my $pkg = shift ;
!
! bless { 'bval' => undef,
! 'cachesize' => undef,
! 'psize' => undef,
! 'flags' => undef,
! 'lorder' => undef,
! 'reclen' => undef,
! 'bfname' => "",
! }, $pkg ;
}
! package DB_File::BTREEINFO ;
! use strict ;
+ @DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ;
! sub TIEHASH
{
! my $pkg = shift ;
! bless { 'flags' => undef,
! 'cachesize' => undef,
! 'maxkeypage' => undef,
! 'minkeypage' => undef,
! 'psize' => undef,
! 'compare' => undef,
! 'prefix' => undef,
! 'lorder' => undef,
! }, $pkg ;
}
package DB_File ;
use strict;
***************
*** 183,194 ****
use Carp;
! $VERSION = "1.01" ;
#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 ;
require Tie::Hash;
require Exporter;
--- 145,160 ----
use Carp;
! $VERSION = "1.02" ;
#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
! #$DB_BTREE = TIEHASH DB_File::BTREEINFO ;
! #$DB_HASH = TIEHASH DB_File::HASHINFO ;
! #$DB_RECNO = TIEHASH DB_File::RECNOINFO ;
!
! $DB_BTREE = new DB_File::BTREEINFO ;
! $DB_HASH = new DB_File::HASHINFO ;
! $DB_RECNO = new DB_File::RECNOINFO ;
require Tie::Hash;
require Exporter;
***************
*** 197,202 ****
--- 163,169 ----
@ISA = qw(Tie::Hash Exporter DynaLoader);
@EXPORT = qw(
$DB_BTREE $DB_HASH $DB_RECNO
+
BTREEMAGIC
BTREEVERSION
DB_LOCK
***************
*** 225,230 ****
--- 192,198 ----
R_SETCURSOR
R_SNAPSHOT
__R_UNUSED
+
);
sub AUTOLOAD {
***************
*** 251,256 ****
--- 219,261 ----
# Preloaded methods go here. Autoload methods go after __END__, and are
# processed by the autosplit program.
+
+ sub get_dup
+ {
+ croak "Usage: \$db->get_dup(key [,flag])\n"
+ unless @_ == 2 or @_ == 3 ;
+
+ my $db = shift ;
+ my $key = shift ;
+ my $flag = shift ;
+ my $value ;
+ my $origkey = $key ;
+ my $wantarray = wantarray ;
+ my @values = () ;
+ my $counter = 0 ;
+
+ # get the first value associated with the key, $key
+ $db->seq($key, $value, R_CURSOR()) ;
+
+ if ( $key eq $origkey) {
+
+ while (1) {
+ # save the value or count matches
+ if ($wantarray)
+ { push (@values, $value) ; push(@values, 1) if $flag }
+ 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 ;
+ }
+
+
1;
__END__
***************
*** 263,280 ****
=head1 SYNOPSIS
use DB_File ;
! [$X =] tie %hash, DB_File, $filename [, $flags, $mode, $DB_HASH] ;
[$X =] tie %hash, DB_File, $filename, $flags, $mode, $DB_BTREE ;
[$X =] tie @array, DB_File, $filename, $flags, $mode, $DB_RECNO ;
$status = $X->del($key [, $flags]) ;
$status = $X->put($key, $value [, $flags]) ;
$status = $X->get($key, $value [, $flags]) ;
! $status = $X->seq($key, $value [, $flags]) ;
$status = $X->sync([$flags]) ;
$status = $X->fd ;
untie %hash ;
untie @array ;
--- 268,294 ----
=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->sync([$flags]) ;
$status = $X->fd ;
+ $count = $X->get_dup($key) ;
+ @list = $X->get_dup($key) ;
+ %list = $X->get_dup($key, 1) ;
+
untie %hash ;
untie @array ;
***************
*** 282,288 ****
B<DB_File> is a module which allows Perl programs to make use of the
facilities provided by Berkeley DB. If you intend to use this
! module you should really have a copy of the Berkeley DB manualpage at
hand. The interface defined here mirrors the Berkeley DB interface
closely.
--- 296,302 ----
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
hand. The interface defined here mirrors the Berkeley DB interface
closely.
***************
*** 294,302 ****
=over 5
! =item DB_HASH
! This database type allows arbitrary key/data pairs to be stored in data
files. This is equivalent to the functionality provided by other
hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though,
the files created using DB_HASH are not compatible with any of the
--- 308,316 ----
=over 5
! =item B<DB_HASH>
! This database type allows arbitrary key/value pairs to be stored in data
files. This is equivalent to the functionality provided by other
hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though,
the files created using DB_HASH are not compatible with any of the
***************
*** 307,322 ****
hashing algorithm it is possible to write your own in Perl and have
B<DB_File> use it instead.
! =item DB_BTREE
! The btree format allows arbitrary key/data pairs to be stored in a
sorted, balanced binary tree.
As with the DB_HASH format, it is possible to provide a user defined
Perl routine to perform the comparison of keys. By default, though, the
keys are stored in lexical order.
! =item DB_RECNO
DB_RECNO allows both fixed-length and variable-length flat text files
to be manipulated using the same key/value pair interface as in DB_HASH
--- 321,341 ----
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
sorted, balanced binary tree.
As with the DB_HASH format, it is possible to provide a user defined
Perl routine to perform the comparison of keys. By default, though, the
keys are stored in lexical order.
! =item B<DB_RECNO>
DB_RECNO allows both fixed-length and variable-length flat text files
to be manipulated using the same key/value pair interface as in DB_HASH
***************
*** 333,342 ****
associative array (for DB_HASH & DB_BTREE file types) or an ordinary
array (for the DB_RECNO file type).
! In addition to the tie() interface, it is also possible to use most of
! the functions provided in the Berkeley DB API.
! =head2 Differences with Berkeley DB
Berkeley DB uses the function dbopen() to open or create a database.
Below is the C prototype for dbopen().
--- 352,362 ----
associative array (for DB_HASH & DB_BTREE file types) or an ordinary
array (for the DB_RECNO file type).
! In addition to the tie() interface, it is also possible to access most
! of the functions provided in the Berkeley DB API directly.
! See L<"Using the Berkeley DB API Directly">.
! =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().
***************
*** 352,386 ****
specific interface method.
This interface is handled slightly differently in B<DB_File>. Here is
! an equivalent call using B<DB_File>.
! tie %array, DB_File, $filename, $flags, $mode, $DB_HASH ;
The C<filename>, C<flags> and C<mode> parameters are the direct
equivalent of their dbopen() counterparts. The final parameter $DB_HASH
performs the function of both the C<type> and C<openinfo> parameters in
dbopen().
! In the example above $DB_HASH is actually a reference to a hash
! object. B<DB_File> has three of these pre-defined references. Apart
! from $DB_HASH, there is also $DB_BTREE and $DB_RECNO.
The keys allowed in each of these pre-defined references is limited to
the names used in the equivalent C structure. So, for example, the
$DB_HASH reference will only allow keys called C<bsize>, C<cachesize>,
! C<ffactor>, C<hash>, C<lorder> and C<nelem>.
! To change one of these elements, just assign to it like this
! $DB_HASH->{cachesize} = 10000 ;
! =head2 RECNO
! 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.
=head2 In Memory Databases
--- 372,655 ----
specific interface method.
This interface is handled slightly differently in B<DB_File>. Here is
! an equivalent call using B<DB_File>:
! tie %array, 'DB_File', $filename, $flags, $mode, $DB_HASH ;
The C<filename>, C<flags> and C<mode> parameters are the direct
equivalent of their dbopen() counterparts. The final parameter $DB_HASH
performs the function of both the C<type> and C<openinfo> parameters in
dbopen().
! In the example above $DB_HASH is actually a pre-defined reference to a
! hash object. B<DB_File> has three of these pre-defined references.
! Apart from $DB_HASH, there is also $DB_BTREE and $DB_RECNO.
The keys allowed in each of these pre-defined references is limited to
the names used in the equivalent C structure. So, for example, the
$DB_HASH reference will only allow keys called C<bsize>, C<cachesize>,
! C<ffactor>, C<hash>, C<lorder> and C<nelem>.
! To change one of these elements, just assign to it like this:
! $DB_HASH->{'cachesize'} = 10000 ;
+ The three predefined variables $DB_HASH, $DB_BTREE and $DB_RECNO are
+ usually adequate for most applications. If you do need to create extra
+ instances of these objects, constructors are available for each file
+ type.
+
+ Here are examples of the constructors and the valid options available
+ for DB_HASH, DB_BTREE and DB_RECNO respectively.
+
+ $a = new DB_File::HASHINFO ;
+ $a->{'bsize'} ;
+ $a->{'cachesize'} ;
+ $a->{'ffactor'};
+ $a->{'hash'} ;
+ $a->{'lorder'} ;
+ $a->{'nelem'} ;
+
+ $b = new DB_File::BTREEINFO ;
+ $b->{'flags'} ;
+ $b->{'cachesize'} ;
+ $b->{'maxkeypage'} ;
+ $b->{'minkeypage'} ;
+ $b->{'psize'} ;
+ $b->{'compare'} ;
+ $b->{'prefix'} ;
+ $b->{'lorder'} ;
+
+ $c = new DB_File::RECNOINFO ;
+ $c->{'bval'} ;
+ $c->{'cachesize'} ;
+ $c->{'psize'} ;
+ $c->{'flags'} ;
+ $c->{'lorder'} ;
+ $c->{'reclen'} ;
+ $c->{'bfname'} ;
+
+ The values stored in the hashes above are mostly the direct equivalent
+ of their C counterpart. Like their C counterparts, all are set to a
+ default set of 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
+ equivalent of the keys C<hash>, C<compare> and C<prefix> store pointers
+ to C functions. In B<DB_File> these keys are used to store references
+ to Perl subs. Below are templates for each of the subs:
! sub hash
! {
! my ($data) = @_ ;
! ...
! # return the hash value for $data
! return $hash ;
! }
!
! sub compare
! {
! my ($key, $key2) = @_ ;
! ...
! # return 0 if $key1 eq $key2
! # -1 if $key1 lt $key2
! # 1 if $key1 gt $key2
! return (-1 , 0 or 1) ;
! }
!
! sub prefix
! {
! my ($key, $key2) = @_ ;
! ...
! # return number of bytes of $key2 which are
! # necessary to determine that it is greater than $key1
! return $bytes ;
! }
!
! See L<"Using BTREE"> for an example of using the C<compare>
+ =head2 Default Parameters
! It is possible to omit some or all of the final 4 parameters in the
! call to C<tie> and let them take default values. As DB_HASH is the most
! common file format used, the call:
!
! tie %A, "DB_File", "filename" ;
!
! is equivalent to:
!
! tie %A, "DB_File", "filename", O_CREAT|O_RDWR, 0640, $DB_HASH ;
!
! It is also possible to omit the filename parameter as well, so the
! call:
!
! tie %A, "DB_File" ;
!
! is equivalent to:
!
! tie %A, "DB_File", undef, O_CREAT|O_RDWR, 0640, $DB_HASH ;
!
! 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
!
! 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
! 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 DB_File ;
! use Fcntl ;
!
! $filename = "tree" ;
! unlink $filename ;
!
! # Enable duplicate records
! $DB_BTREE->{'flags'} = R_DUP ;
!
! tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
! or die "Cannot open $filename: $!\n";
!
! # Add some key/value pairs to the file
! $h{'Wall'} = 'Larry' ;
! $h{'Wall'} = 'Brick' ; # Note the duplicate key
! $h{'Smith'} = 'John' ;
! $h{'mouse'} = 'mickey' ;
!
! # iterate through the associative array
! # and print each key/value pair.
! foreach (keys %h)
! { print "$_ -> $h{$_}\n" }
!
! Here is the output:
!
! Smith -> John
! Wall -> Larry
! Wall -> Larry
! mouse -> mickey
!
! As you can see 2 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.
!
! Although it may not be immediately obvious from the code above, the
! associative array interface can be used to write values with duplicate
! keys, but it cannot be used to read them back from the database.
!
! The way to get around this problem is to use the Berkeley DB API method
! called C<seq>. This method allows sequential access to key/value
! pairs. See L<"Using the Berkeley DB API Directly"> 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 DB_File ;
! use Fcntl ;
!
! $filename = "tree" ;
! unlink $filename ;
!
! # Enable duplicate records
! $DB_BTREE->{'flags'} = R_DUP ;
!
! $x = tie %h, "DB_File", $filename, O_RDWR|O_CREAT, 0640, $DB_BTREE
! or die "Cannot open $filename: $!\n";
!
! # Add some key/value pairs to the file
! $h{'Wall'} = 'Larry' ;
! $h{'Wall'} = 'Brick' ; # Note the duplicate key
! $h{'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
! # and print each key/value pair.
! print "$key -> $value\n" ;
! while ( $x->seq($key, $value, R_NEXT) == 0)
! { print "$key -> $value\n" }
!
! undef $x ;
! untie %h ;
!
! that prints:
!
! Smith -> John
! Wall -> Brick
! Wall -> Larry
! mouse -> mickey
!
! This time we have got all the key/value pairs, including both the
! values associated with the key C<Wall>.
!
! C<DB_File> comes with a utility method, called C<get_dup>, to assist in
! reading duplicate values from BTREE databases. The method can take the
! following forms:
!
! $count = $x->get_dup($key) ;
! @list = $x->get_dup($key) ;
! %list = $x->get_dup($key, 1) ;
!
! In a scalar context the method returns the number of values associated
! with the key, C<$key>.
!
! In list context, it returns all the values which match C<$key>. Note
! that the values returned will be 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>.
!
! So assuming the database created above, we can use C<get_dups> like
! this:
!
! $cnt = $x->get_dups("Wall") ;
! print "Wall occurred $cnt times\n" ;
!
! %hash = $x->get_dups("Wall", 1) ;
! print "Larry is there\n" if $hash{'Larry'} ;
!
! @list = $x->get_dups("Wall") ;
! print "Wall => [@list]\n" ;
!
! @list = $x->get_dups("Smith") ;
! print "Smith => [@list]\n" ;
!
! @list = $x->get_dups("Dog") ;
! print "Dog => [@list]\n" ;
!
!
! and it will print:
!
! Wall occurred 2 times
! Larry is there
! Wall => [Brick Larry]
! Smith => [John]
! Dog => []
+ =head2 RECNO
+
+ In order to make RECNO more compatible with Perl the array offset for
+ all RECNO arrays begins at 0 rather than 1 as in Berkeley DB.
+
+ As with normal Perl arrays, a RECNO array can be accessed using
+ negative indexes. The index -1 refers to the last element of the array,
+ -2 the second last, and so on. Attempting to access an element before
+ the start of the array will raise a fatal run-time error.
=head2 In Memory Databases
***************
*** 389,453 ****
uses C<undef> instead of NULL to provide this functionality.
! =head2 Using the Berkeley DB Interface Directly
As well as accessing Berkeley DB using a tied hash or array, it is also
! possible to make direct use of most of the functions defined in the
Berkeley DB documentation.
! To do this you need to remember the return value from the tie.
!
! $db = tie %hash, DB_File, "filename"
Once you have done that, you can access the Berkeley DB API functions
! directly.
$db->put($key, $value, R_NOOVERWRITE) ;
! All the functions defined in L<dbx(3X)> are available except for
! close() and dbopen() itself. The B<DB_File> interface to these
! functions have been implemented to mirror the the way Berkeley DB
! works. In particular note that all the functions return only a status
! value. Whenever a Berkeley DB function returns data via one of its
! parameters, the B<DB_File> equivalent does exactly the same.
! All the constants defined in L<dbopen> are also available.
! Below is a list of the functions available.
=over 5
! =item get
! Same as in C<recno> except that the flags parameter is optional.
! Remember the value associated with the key you request is returned in
! the $value parameter.
! =item put
! As usual the flags parameter is optional.
! If you use either the R_IAFTER or R_IBEFORE flags, the key parameter
will have the record number of the inserted key/value pair set.
! =item del
! The flags parameter is optional.
! =item fd
! As in I<recno>.
! =item seq
! The flags parameter is optional.
! Both the key and value parameters will be set.
! =item sync
! The flags parameter is optional.
=back
--- 658,812 ----
uses C<undef> instead of NULL to provide this functionality.
! =head2 Using the Berkeley DB API Directly
As well as accessing Berkeley DB using a tied hash or array, it is also
! possible to make direct use of most of the API functions defined in the
Berkeley DB documentation.
+ To do this you need to store a copy of the object returned from the tie.
! $db = tie %hash, "DB_File", "filename" ;
Once you have done that, you can access the Berkeley DB API functions
! as B<DB_File> methods directly like this:
$db->put($key, $value, R_NOOVERWRITE) ;
! B<Important:> If you have saved a copy of the object returned from
! C<tie>, the underlying database file will I<not> be closed until both
! the tied variable is untied and all copies of the saved object are
! destroyed.
!
! use DB_File ;
! $db = tie %hash, "DB_File", "filename"
! or die "Cannot tie filename: $!" ;
! ...
! undef $db ;
! untie %hash ;
!
! All the functions defined in L<dbopen> are available except for
! close() and dbopen() itself. The B<DB_File> method interface to the
! supported functions have been implemented to mirror the way Berkeley DB
! works whenever possible. In particular note that:
!
! =over 5
!
! =item *
!
! The methods return a status value. All return 0 on success.
! All return -1 to signify an error and set C<$!> to the exact
! error code. The return code 1 generally (but not always) means that the
! key specified did not exist in the database.
!
! Other return codes are defined. See below and in the Berkeley DB
! documentation for details. The Berkeley DB documentation should be used
! as the definitive source.
! =item *
! Whenever a Berkeley DB function returns data via one of its parameters,
! the equivalent B<DB_File> method does exactly the same.
!
! =item *
!
! If you are careful, it is possible to mix API calls with the tied
! hash/array interface in the same piece of code. Although only a few of
! the methods used to implement the tied interface currently make use of
! the cursor, you should always assume that the cursor has been changed
! any time the tied hash/array interface is used. As an example, this
! code will probably not do what you expect:
!
! $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE
! or die "Cannot tie $filename: $!" ;
!
! # Get the first key/value pair and set the cursor
! $X->seq($key, $value, R_FIRST) ;
!
! # this line will modify the cursor
! $count = scalar keys %x ;
!
! # Get the second key/value pair.
! # oops, it didn't, it got the last key/value pair!
! $X->seq($key, $value, R_NEXT) ;
!
! The code above can be rearranged to get around the problem, like this:
!
! $X = tie %x, 'DB_File', $filename, O_RDWR|O_CREAT, 0777, $DB_BTREE
! or die "Cannot tie $filename: $!" ;
!
! # this line will modify the cursor
! $count = scalar keys %x ;
!
! # Get the first key/value pair and set the cursor
! $X->seq($key, $value, R_FIRST) ;
!
! # Get the second key/value pair.
! # worked this time.
! $X->seq($key, $value, R_NEXT) ;
!
! =back
!
! All the constants defined in L<dbopen> for use in the flags parameters
! in the methods defined below are also available. Refer to the Berkeley
! DB documentation for the precise meaning of the flags values.
!
! Below is a list of the methods available.
=over 5
! =item C<$status = $X-E<gt>get($key, $value [, $flags]) ;>
!
! Given a key (C<$key>) this method reads the value associated with it
! from the database. The value read from the database is returned in the
! C<$value> parameter.
!
! If the key does not exist the method returns 1.
! No flags are currently defined for this method.
! =item C<$status = $X-E<gt>put($key, $value [, $flags]) ;>
! Stores the key/value pair in the database.
! If you use either the R_IAFTER or R_IBEFORE flags, the C<$key> parameter
will have the record number of the inserted key/value pair set.
! Valid flags are R_CURSOR, R_IAFTER, R_IBEFORE, R_NOOVERWRITE and
! R_SETCURSOR.
! =item C<$status = $X-E<gt>del($key [, $flags]) ;>
! Removes all key/value pairs with key C<$key> from the database.
! A return code of 1 means that the requested key was not in the
! database.
! R_CURSOR is the only valid flag at present.
! =item C<$status = $X-E<gt>fd ;>
! Returns the file descriptor for the underlying database.
! See L<"Locking Databases"> for an example of how to make use of the
! C<fd> method to lock your database.
! =item C<$status = $X-E<gt>seq($key, $value, $flags) ;>
!
! This interface allows sequential retrieval from the database. See
! L<dbopen> for full details.
!
! Both the C<$key> and C<$value> parameters will be set to the key/value
! pair read from the database.
!
! The flags parameter is mandatory. The valid flag values are R_CURSOR,
! R_FIRST, R_LAST, R_NEXT and R_PREV.
!
! =item C<$status = $X-E<gt>sync([$flags]) ;>
!
! Flushes any cached buffers to disk.
!
! R_RECNOSYNC is the only valid flag at present.
=back
***************
*** 460,515 ****
use DB_File ;
use Fcntl ;
!
! tie %h, "DB_File", "hashed", O_RDWR|O_CREAT, 0640, $DB_HASH ;
!
# Add a key/value pair to the file
$h{"apple"} = "orange" ;
!
# Check for existence of a key
print "Exists\n" if $h{"banana"} ;
!
# Delete
delete $h{"apple"} ;
!
untie %h ;
=head2 Using BTREE
! Here is sample of code which used BTREE. Just to make life more
! interesting the default comparision function will not be used. Instead
a Perl sub, C<Compare()>, will be used to do a case insensitive
comparison.
use DB_File ;
use Fcntl ;
!
sub Compare
{
my ($key1, $key2) = @_ ;
!
"\L$key1" cmp "\L$key2" ;
}
!
! $DB_BTREE->{compare} = 'Compare' ;
!
! tie %h, 'DB_File', "tree", O_RDWR|O_CREAT, 0640, $DB_BTREE ;
!
# Add a key/value pair to the file
$h{'Wall'} = 'Larry' ;
$h{'Smith'} = 'John' ;
$h{'mouse'} = 'mickey' ;
$h{'duck'} = 'donald' ;
!
# Delete
delete $h{"duck"} ;
!
# Cycle through the keys printing them in order.
# Note it is not necessary to sort the keys as
# the btree will have kept them in order automatically.
foreach (keys %h)
{ print "$_\n" }
!
untie %h ;
Here is the output from the code above.
--- 819,876 ----
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.
***************
*** 521,541 ****
=head2 Using RECNO
use DB_File ;
use Fcntl ;
!
! $DB_RECNO->{psize} = 3000 ;
!
! tie @h, DB_File, "text", O_RDWR|O_CREAT, 0640, $DB_RECNO ;
!
# Add a key/value pair to the file
$h[0] = "orange" ;
!
# Check for existence of a key
print "Exists\n" if $h[1] ;
-
- untie @h ;
=head2 Locking Databases
--- 882,904 ----
=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] ;
+ untie @h ;
=head2 Locking Databases
***************
*** 588,596 ****
--- 951,961 ----
print "$$: Write lock granted\n";
$db{$key} = $value;
+ $db->sync;
sleep 10;
flock(DB_FH, LOCK_UN);
+ undef $db;
untie %db;
close(DB_FH);
print "$$: Updated db to $key=$value\n";
***************
*** 631,641 ****
The return value from TIEHASH wasn't set to NULL when dbopen returned
an error.
=head1 WARNINGS
! If you happen find any other functions defined in the source for this
! module that have not been mentioned in this document -- beware. I may
! drop them at a moments notice.
If you cannot find any, then either you didn't look very hard or the
moment has passed and I have dropped them.
--- 996,1023 ----
The return value from TIEHASH wasn't set to NULL when dbopen returned
an error.
+ =item 1.02
+
+ Merged OS2 specific code into DB_File.xs
+
+ Removed some redundant code in DB_File.xs.
+
+ Documentation update.
+
+ Allow negative subscripts with RECNO interface.
+
+ Changed the default flags from O_RDWR to O_CREAT|O_RDWR.
+
+ The example code which showed how to lock a database needed a call to
+ C<sync> added. Without it the resultant database file was empty.
+
+ Added get_dups method.
+
=head1 WARNINGS
! 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.
If you cannot find any, then either you didn't look very hard or the
moment has passed and I have dropped them.
***************
*** 656,661 ****
--- 1038,1047 ----
host F<ftp.cs.berkeley.edu> in F</ucb/4bsd/db.tar.gz>. It is I<not> under
the GPL.
+ If you are running IRIX, then get Berkeley DB from
+ F<http://reality.sgi.com/ariel>. It has the patches necessary to
+ compile properly on IRIX 5.3.
+
=head1 SEE ALSO
L<perl(1)>, L<dbopen(3)>, L<hash(3)>, L<recno(3)>, L<btree(3)>
***************
*** 666,673 ****
=head1 AUTHOR
The DB_File interface was written by Paul Marquess
! <pmarquess@bfsec.bt.co.uk>.
Questions about the DB system itself may be addressed to Keith Bostic
! <bostic@cs.berkeley.edu>.
=cut
--- 1052,1059 ----
=head1 AUTHOR
The DB_File interface was written by Paul Marquess
! E<lt>pmarquess@bfsec.bt.co.ukE<gt>.
Questions about the DB system itself may be addressed to Keith Bostic
! E<lt>bostic@cs.berkeley.eduE<gt>.
=cut
#~ Update to version 1.02
diff -Pcr perl5_003/ext/DB_File/DB_File.xs perl5_003_01/ext/DB_File/DB_File.xs
*** perl5_003/ext/DB_File/DB_File.xs Sat Jan 20 00:55:34 1996
--- perl5_003_01/ext/DB_File/DB_File.xs Fri Jul 5 18:45:21 1996
***************
*** 3,10 ****
DB_File.xs -- Perl 5 interface to Berkeley DB
written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
! last modified 14th November 1995
! version 1.01
All comments/suggestions/problems are welcome
--- 3,10 ----
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
All comments/suggestions/problems are welcome
***************
*** 17,22 ****
--- 17,27 ----
1.01 - Fixed a SunOS core dump problem.
The return value from TIEHASH wasn't set to NULL when
dbopen returned an error.
+ 1.02 - Use ALIAS to define TIEARRAY.
+ Removed some redundant commented code.
+ Merged OS2 code into the main distribution.
+ Allow negative subscripts with RECNO interface.
+ Changed the default flags to O_CREAT|O_RDWR
*/
#include "EXTERN.h"
***************
*** 45,51 ****
} ;
! /* #define TRACE */
#define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
--- 50,56 ----
} ;
! /* #define TRACE */
#define db_DESTROY(db) ((db->dbp)->close)(db->dbp)
#define db_DELETE(db, key, flags) ((db->dbp)->del)(db->dbp, &key, flags)
***************
*** 61,74 ****
#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
! #define OutputValue(arg, name) \
! { if (RETVAL == 0) sv_setpvn(arg, name.data, name.size) ; }
#define OutputKey(arg, name) \
{ if (RETVAL == 0) \
{ \
! if (db->type != DB_RECNO) \
sv_setpvn(arg, name.data, name.size); \
else \
sv_setiv(arg, (I32)*(I32*)name.data - 1); \
} \
--- 66,83 ----
#define db_sync(db, flags) ((db->dbp)->sync)(db->dbp, flags)
! #define OutputValue(arg, name) \
! { if (RETVAL == 0) { \
! sv_setpvn(arg, name.data, name.size) ; \
! } \
! }
#define OutputKey(arg, name) \
{ if (RETVAL == 0) \
{ \
! if (db->type != DB_RECNO) { \
sv_setpvn(arg, name.data, name.size); \
+ } \
else \
sv_setiv(arg, (I32)*(I32*)name.data - 1); \
} \
***************
*** 235,241 ****
printf (" lorder = %d\n", recno.lorder) ;
printf (" reclen = %d\n", recno.reclen) ;
printf (" bval = %d\n", recno.bval) ;
! printf (" bfname = %s\n", recno.bfname) ;
}
PrintBtree(btree)
--- 244,250 ----
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) ;
}
PrintBtree(btree)
***************
*** 278,283 ****
--- 287,313 ----
return (RETVAL) ;
}
+ static recno_t
+ GetRecnoKey(db, value)
+ DB_File db ;
+ I32 value ;
+ {
+ if (value < 0) {
+ /* Get the length of the array */
+ I32 length = GetArrayLength(db->dbp) ;
+
+ /* check for attempt to write before start of array */
+ if (length + value + 1 <= 0)
+ croak("Modification of non-creatable array value attempted, subscript %d", value) ;
+
+ value = length + value + 1 ;
+ }
+ else
+ ++ value ;
+
+ return value ;
+ }
+
static DB_File
ParseOpenInfo(name, flags, mode, sv, string)
char * name ;
***************
*** 291,298 ****
union INFO info ;
DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
void * openinfo = NULL ;
- /* DBTYPE type = DB_HASH ; */
RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
RETVAL->type = DB_HASH ;
--- 321,328 ----
union INFO info ;
DB_File RETVAL = (DB_File)safemalloc(sizeof(DB_File_type)) ;
void * openinfo = NULL ;
+ /* Default to HASH */
RETVAL->hash = RETVAL->compare = RETVAL->prefix = NULL ;
RETVAL->type = DB_HASH ;
***************
*** 415,421 ****
}
svp = hv_fetch(action, "bfname", 6, FALSE);
! info.recno.bfname = (char *) svp ? SvPV(*svp,na) : 0;
PrintRecno(info) ;
}
--- 445,454 ----
}
svp = hv_fetch(action, "bfname", 6, FALSE);
! if (svp) {
! char * ptr = SvPV(*svp,na) ;
! info.recno.bfname = (char*) na ? ptr : 0 ;
! }
PrintRecno(info) ;
}
***************
*** 424,440 ****
}
! RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
!
! #if 0
! /* kludge mode on: RETVAL->type for DB_RECNO is set to DB_BTREE
! so remember a DB_RECNO by saving the address
! of one of it's internal routines
! */
! if (RETVAL->dbp && type == DB_RECNO)
! DB_recno_close = RETVAL->dbp->close ;
! #endif
return (RETVAL) ;
}
--- 457,470 ----
}
! /* OS2 Specific Code */
! #ifdef OS2
! #ifdef __EMX__
! flags |= O_BINARY;
! #endif /* __EMX__ */
! #endif /* OS2 */
+ RETVAL->dbp = dbopen(name, flags, mode, RETVAL->type, openinfo) ;
return (RETVAL) ;
}
***************
*** 695,704 ****
DB_File
! db_TIEHASH(dbtype, name=undef, flags=O_RDWR, mode=0640, type=DB_HASH)
char * dbtype
int flags
int mode
CODE:
{
char * name = (char *) NULL ;
--- 725,735 ----
DB_File
! db_TIEHASH(dbtype, name=undef, flags=O_CREAT|O_RDWR, mode=0640, type=DB_HASH)
char * dbtype
int flags
int mode
+ ALIAS: TIEARRAY = 1
CODE:
{
char * name = (char *) NULL ;
***************
*** 716,724 ****
}
OUTPUT:
RETVAL
-
- BOOT:
- newXS("DB_File::TIEARRAY", XS_DB_File_db_TIEHASH, file);
int
db_DESTROY(db)
--- 747,752 ----
#~ Update to version 1.02
diff -Pcr perl5_003/ext/DB_File/Makefile.PL perl5_003_01/ext/DB_File/Makefile.PL
*** perl5_003/ext/DB_File/Makefile.PL Sun Jun 23 22:06:40 1996
--- perl5_003_01/ext/DB_File/Makefile.PL Fri Jul 5 18:45:33 1996
***************
*** 1,11 ****
! use ExtUtils::MakeMaker;
WriteMakefile(
! NAME => 'DB_File',
! LIBS => ["-L/usr/local/lib -ldb"],
! MAN3PODS => ' ', # Pods will be built by installman.
! #INC => '-I/usr/local/include',
VERSION_FROM => 'DB_File.pm',
! XSPROTOARG => '-noprototypes', # XXX remove later?
! );
--- 1,16 ----
! use ExtUtils::MakeMaker 5.16 ;
! use Config ;
!
! # OS2 is a special case, so check for it now.
! my $OS2 = "-DOS2" if $Config{'osname'} eq 'os2' ;
WriteMakefile(
! NAME => 'DB_File',
! LIBS => ["-L/usr/local/lib -ldb"],
! MAN3PODS => ' ', # Pods will be built by installman.
! #INC => '-I/usr/local/include',
VERSION_FROM => 'DB_File.pm',
! XSPROTOARG => '-noprototypes',
! DEFINE => "$OS2",
! );
#~ Update to version 1.02
diff -Pcr perl5_003/ext/DB_File/typemap perl5_003_01/ext/DB_File/typemap
*** perl5_003/ext/DB_File/typemap Sat Jan 20 00:55:41 1996
--- perl5_003_01/ext/DB_File/typemap Fri Jul 5 18:45:31 1996
***************
*** 1,8 ****
# typemap for Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
! # last modified 23rd June 1994
! # version 0.1
#
#################################### DB SECTION
#
--- 1,8 ----
# typemap for Perl 5 interface to Berkeley DB
#
# written by Paul Marquess (pmarquess@bfsec.bt.co.uk)
! # last modified 28th June 1996
! # version 0.2
#
#################################### DB SECTION
#
***************
*** 15,29 ****
INPUT
T_dbtkeydatum
! if (db->type != DB_RECNO)
! {
$var.data = SvPV($arg, na);
$var.size = (int)na;
}
! else
! {
! Value = SvIV($arg) ;
! ++ Value ;
$var.data = & Value;
$var.size = (int)sizeof(recno_t);
}
--- 15,26 ----
INPUT
T_dbtkeydatum
! if (db->type != DB_RECNO) {
$var.data = SvPV($arg, na);
$var.size = (int)na;
}
! else {
! Value = GetRecnoKey(db, SvIV($arg)) ;
$var.data = & Value;
$var.size = (int)sizeof(recno_t);
}
#~ Use explicit dependency to select XS file, and suffix rules from there
diff -Pcr perl5_003/ext/DynaLoader/Makefile.PL perl5_003_01/ext/DynaLoader/Makefile.PL
*** perl5_003/ext/DynaLoader/Makefile.PL Sun Jun 23 22:07:51 1996
--- perl5_003_01/ext/DynaLoader/Makefile.PL Mon Jun 17 15:09:19 1996
***************
*** 1,21 ****
use ExtUtils::MakeMaker;
WriteMakefile(
! NAME => 'DynaLoader',
LINKTYPE => 'static',
DEFINE => '-DLIBC="$(LIBC)"',
MAN3PODS => ' ', # Pods will be built by installman.
SKIP => [qw(dynamic dynamic_lib dynamic_bs)],
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'DynaLoader.pm',
! clean => {FILES => 'DynaLoader.c'},
);
sub MY::postamble {
'
! DynaLoader.c: $(DLSRC)
! $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $(DLSRC) >tmp && mv tmp $@
# Perform very simple tests just to check for major gaffs.
# We can\'t do much more for platforms we are not executing on.
--- 1,21 ----
use ExtUtils::MakeMaker;
WriteMakefile(
! NAME => 'DynaLoader',
LINKTYPE => 'static',
DEFINE => '-DLIBC="$(LIBC)"',
MAN3PODS => ' ', # Pods will be built by installman.
SKIP => [qw(dynamic dynamic_lib dynamic_bs)],
XSPROTOARG => '-noprototypes', # XXX remove later?
VERSION_FROM => 'DynaLoader.pm',
! clean => {FILES => 'DynaLoader.c DynaLoader.xs'},
);
sub MY::postamble {
'
! DynaLoader.xs: $(DLSRC)
! $(CP) $? $@
# Perform very simple tests just to check for major gaffs.
# We can\'t do much more for platforms we are not executing on.
#~ Add NeXTSTEP/OPENSTEP 4 support
diff -Pcr perl5_003/ext/DynaLoader/dl_next.xs perl5_003_01/ext/DynaLoader/dl_next.xs
*** perl5_003/ext/DynaLoader/dl_next.xs Thu Oct 19 20:13:39 1995
--- perl5_003_01/ext/DynaLoader/dl_next.xs Thu Jul 11 12:26:01 1996
***************
*** 31,39 ****
--- 31,42 ----
*/
+ #if NS_TARGET_MAJOR >= 4
+ #else
/* include these before perl headers */
#include <mach-o/rld.h>
#include <streams/streams.h>
+ #endif
#include "EXTERN.h"
#include "perl.h"
***************
*** 47,61 ****
static char * dl_last_error = (char *) 0;
static AV *dl_resolve_using = Nullav;
! NXStream *
! OpenError()
{
return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY);
}
! void
! TransferError( s)
! NXStream *s;
{
char *buffer;
int len, maxlen;
--- 50,154 ----
static char * dl_last_error = (char *) 0;
static AV *dl_resolve_using = Nullav;
! static char *dlerror()
! {
! return dl_last_error;
! }
!
! int dlclose(handle) /* stub only */
! void *handle;
! {
! return 0;
! }
!
! #if NS_TARGET_MAJOR >= 4
! #import <mach-o/dyld.h>
!
! enum dyldErrorSource
! {
! OFImage,
! };
!
! static void TranslateError
! (const char *path, enum dyldErrorSource type, int number)
! {
! char errorBuffer[128];
! unsigned int index;
! static char *OFIErrorStrings[] =
! {
! "%s(%d): Object Image Load Failure\n",
! "%s(%d): Object Image Load Success\n",
! "%s(%d): Not an recognisable object file\n",
! "%s(%d): No valid architecture\n",
! "%s(%d): Object image has an invalid format\n",
! "%s(%d): Invalid access (permissions?)\n",
! "%s(%d): Unknown error code from NSCreateObjectFileImageFromFile\n",
! };
! #define NUM_OFI_ERRORS (sizeof(OFIErrorStrings) / sizeof(OFIErrorStrings[0]))
!
! if ( dl_last_error ) {
! safefree(dl_last_error);
! }
! switch (type)
! {
! case OFImage:
! index = number;
! if (index > NUM_OFI_ERRORS - 1)
! index = NUM_OFI_ERRORS - 1;
! sprintf(errorBuffer, OFIErrorStrings[index], path, number);
! break;
!
! default:
! sprintf(errorBuffer, "%s(%d): Totally unknown error type %d\n",
! path, number, type);
! break;
! }
! dl_last_error = safemalloc(strlen(errorBuffer)+1);
! strcpy(dl_last_error, errorBuffer);
! }
!
! static char *dlopen(char *path, int mode /* mode is ignored */)
! {
! int dyld_result;
! NSObjectFileImage ofile;
! NSModule handle = NULL;
!
! dyld_result = NSCreateObjectFileImageFromFile(path, &ofile);
! if (dyld_result != NSObjectFileImageSuccess)
! TranslateError(path, OFImage, dyld_result);
! else
! {
! // NSLinkModule will cause the run to abort on any link error's
! // not very friendly but the error recovery functionality is limited.
! handle = NSLinkModule(ofile, path, TRUE);
! }
!
! return handle;
! }
!
! void *
! dlsym(handle, symbol)
! void *handle;
! char *symbol;
! {
! void *addr;
!
! if (NSIsSymbolNameDefined(symbol))
! addr = NSAddressOfSymbol(NSLookupAndBindSymbol(symbol));
! else
! addr = NULL;
!
! return addr;
! }
!
! #else /* NS_TARGET_MAJOR <= 3 */
!
! static NXStream *OpenError(void)
{
return NXOpenMemory( (char *) 0, 0, NX_WRITEONLY);
}
! static void TransferError(NXStream *s)
{
char *buffer;
int len, maxlen;
***************
*** 68,91 ****
strcpy(dl_last_error, buffer);
}
! void
! CloseError( s)
! NXStream *s;
{
if ( s ) {
NXCloseMemory( s, NX_FREEBUFFER);
}
}
! char *dlerror()
! {
! return dl_last_error;
! }
!
! char *
! dlopen(path, mode)
! char * path;
! int mode; /* mode is ignored */
{
int rld_success;
NXStream *nxerr;
--- 161,174 ----
strcpy(dl_last_error, buffer);
}
! static void CloseError(NXStream *s)
{
if ( s ) {
NXCloseMemory( s, NX_FREEBUFFER);
}
}
! static char *dlopen(char *path, int mode /* mode is ignored */)
{
int rld_success;
NXStream *nxerr;
***************
*** 120,132 ****
return result;
}
- int
- dlclose(handle) /* stub only */
- void *handle;
- {
- return 0;
- }
-
void *
dlsym(handle, symbol)
void *handle;
--- 203,208 ----
***************
*** 144,149 ****
--- 220,227 ----
return (void*) symref;
}
+ #endif /* NS_TARGET_MAJOR >= 4 */
+
/* ----- code from dl_dlopen.xs below here ----- */
***************
*** 182,187 ****
--- 260,269 ----
void * libhandle
char * symbolname
CODE:
+ #if NS_TARGET_MAJOR >= 4
+ char symbolname_buf[1024];
+ symbolname = dl_add_underscore(symbolname, symbolname_buf);
+ #endif
DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
libhandle, symbolname));
RETVAL = dlsym(libhandle, symbolname);
#~ Add cast to malloc to calm cc when system headers decalre int malloc()
diff -Pcr perl5_003/ext/DynaLoader/dlutils.c perl5_003_01/ext/DynaLoader/dlutils.c
*** perl5_003/ext/DynaLoader/dlutils.c Thu Oct 19 20:13:53 1995
--- perl5_003_01/ext/DynaLoader/dlutils.c Wed Jul 3 17:45:45 1996
***************
*** 75,81 ****
if (LastError)
LastError = (char*)saferealloc(LastError, len) ;
else
! LastError = safemalloc(len) ;
/* Copy message into LastError (including terminating null char) */
strncpy(LastError, message, len) ;
--- 75,81 ----
if (LastError)
LastError = (char*)saferealloc(LastError, len) ;
else
! LastError = (char *) safemalloc(len) ;
/* Copy message into LastError (including terminating null char) */
strncpy(LastError, message, len) ;
#~ Close file only once during object destruction.
diff -Pcr perl5_003/ext/FileHandle/FileHandle.pm perl5_003_01/ext/FileHandle/FileHandle.pm
*** perl5_003/ext/FileHandle/FileHandle.pm Mon Mar 25 01:04:05 1996
--- perl5_003_01/ext/FileHandle/FileHandle.pm Wed Jul 24 10:05:27 1996
***************
*** 252,258 ****
sub DESTROY {
my ($fh) = @_;
! close($fh);
}
################################################
--- 252,270 ----
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);
! }
}
################################################
#~ Don't repeat inclusion of stdio.h
#~ Use Fflush() macro to allow for OS-specific overrides
diff -Pcr perl5_003/ext/FileHandle/FileHandle.xs perl5_003_01/ext/FileHandle/FileHandle.xs
*** perl5_003/ext/FileHandle/FileHandle.xs Mon Feb 12 14:50:47 1996
--- perl5_003_01/ext/FileHandle/FileHandle.xs Sat Jul 27 14:16:53 1996
***************
*** 1,7 ****
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
- #include <stdio.h>
typedef int SysRet;
typedef FILE * InputStream;
--- 1,6 ----
***************
*** 137,143 ****
OutputStream handle
CODE:
if (handle)
! RETVAL = fflush(handle);
else {
RETVAL = -1;
errno = EINVAL;
--- 136,142 ----
OutputStream handle
CODE:
if (handle)
! RETVAL = Fflush(handle);
else {
RETVAL = -1;
errno = EINVAL;
#~ Quote string argument in example -- necessary if using strict subs
diff -Pcr perl5_003/ext/GDBM_File/GDBM_File.pm perl5_003_01/ext/GDBM_File/GDBM_File.pm
*** perl5_003/ext/GDBM_File/GDBM_File.pm Mon Feb 12 14:51:00 1996
--- perl5_003_01/ext/GDBM_File/GDBM_File.pm Mon Jul 15 13:35:30 1996
***************
*** 7,13 ****
=head1 SYNOPSIS
use GDBM_File ;
! tie %hash, GDBM_File, $filename, &GDBM_WRCREAT, 0640);
# Use the %hash array.
untie %hash ;
--- 7,13 ----
=head1 SYNOPSIS
use GDBM_File ;
! tie %hash, 'GDBM_File', $filename, &GDBM_WRCREAT, 0640);
# Use the %hash array.
untie %hash ;
#~ Add IO extension
diff -Pcr perl5_003/ext/IO/IO.pm perl5_003_01/ext/IO/IO.pm
*** perl5_003/ext/IO/IO.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/IO/IO.pm Mon Jul 8 16:45:36 1996
***************
*** 0 ****
--- 1,12 ----
+ #
+
+ package IO;
+
+ use IO::Handle;
+ use IO::Seekable;
+ use IO::File;
+ use IO::Pipe;
+ use IO::Socket;
+
+ 1;
+
#~ Add IO extension
diff -Pcr perl5_003/ext/IO/IO.xs perl5_003_01/ext/IO/IO.xs
*** perl5_003/ext/IO/IO.xs Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/IO/IO.xs Sat Jul 27 14:17:48 1996
***************
*** 0 ****
--- 1,208 ----
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+ #ifdef I_UNISTD
+ # include <unistd.h>
+ #endif
+
+ typedef int SysRet;
+ typedef FILE * InputStream;
+ typedef FILE * OutputStream;
+
+ static int
+ not_here(s)
+ char *s;
+ {
+ croak("%s not implemented on this architecture", s);
+ return -1;
+ }
+
+ static bool
+ constant(name, pval)
+ char *name;
+ IV *pval;
+ {
+ switch (*name) {
+ case '_':
+ if (strEQ(name, "_IOFBF"))
+ #ifdef _IOFBF
+ { *pval = _IOFBF; return TRUE; }
+ #else
+ return FALSE;
+ #endif
+ if (strEQ(name, "_IOLBF"))
+ #ifdef _IOLBF
+ { *pval = _IOLBF; return TRUE; }
+ #else
+ return FALSE;
+ #endif
+ if (strEQ(name, "_IONBF"))
+ #ifdef _IONBF
+ { *pval = _IONBF; return TRUE; }
+ #else
+ return FALSE;
+ #endif
+ break;
+ case 'S':
+ if (strEQ(name, "SEEK_SET"))
+ #ifdef SEEK_SET
+ { *pval = SEEK_SET; return TRUE; }
+ #else
+ return FALSE;
+ #endif
+ if (strEQ(name, "SEEK_CUR"))
+ #ifdef SEEK_CUR
+ { *pval = SEEK_CUR; return TRUE; }
+ #else
+ return FALSE;
+ #endif
+ if (strEQ(name, "SEEK_END"))
+ #ifdef SEEK_END
+ { *pval = SEEK_END; return TRUE; }
+ #else
+ return FALSE;
+ #endif
+ if (strEQ(name, "SEEK_EOF"))
+ #ifdef SEEK_EOF
+ { *pval = SEEK_EOF; return TRUE; }
+ #else
+ return FALSE;
+ #endif
+ break;
+ }
+
+ return FALSE;
+ }
+
+
+ MODULE = IO PACKAGE = IO::Seekable PREFIX = f
+
+ 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("IO::Seekable::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("IO::Seekable::fsetpos");
+ #endif
+ OUTPUT:
+ RETVAL
+
+ MODULE = IO PACKAGE = IO::File PREFIX = f
+
+ OutputStream
+ new_tmpfile(packname = "IO::File")
+ char * packname
+ CODE:
+ RETVAL = tmpfile();
+ OUTPUT:
+ RETVAL
+
+ MODULE = IO PACKAGE = IO::Handle PREFIX = f
+
+ SV *
+ constant(name)
+ char * name
+ CODE:
+ IV i;
+ if (constant(name, &i))
+ ST(0) = sv_2mortal(newSViv(i));
+ else
+ ST(0) = &sv_undef;
+
+ int
+ ungetc(handle, c)
+ InputStream handle
+ int c
+ CODE:
+ if (handle)
+ RETVAL = ungetc(c, handle);
+ else {
+ RETVAL = -1;
+ errno = EINVAL;
+ }
+ 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("IO::Handle::setvbuf");
+ #endif /* _IOFBF */
+ OUTPUT:
+ RETVAL
+
+
#~ Add IO extension
diff -Pcr perl5_003/ext/IO/Makefile.PL perl5_003_01/ext/IO/Makefile.PL
*** perl5_003/ext/IO/Makefile.PL Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/IO/Makefile.PL Tue Jul 9 12:05:14 1996
***************
*** 0 ****
--- 1,7 ----
+ use ExtUtils::MakeMaker;
+ WriteMakefile(
+ NAME => 'IO',
+ MAN3PODS => ' ', # Pods will be built by installman.
+ XSPROTOARG => '-noprototypes', # XXX remove later?
+ VERSION_FROM => 'lib/IO/Handle.pm',
+ );
#~ Add IO extension
diff -Pcr perl5_003/ext/IO/lib/IO/File.pm perl5_003_01/ext/IO/lib/IO/File.pm
*** perl5_003/ext/IO/lib/IO/File.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/IO/lib/IO/File.pm Mon Jul 8 16:45:22 1996
***************
*** 0 ****
--- 1,144 ----
+ #
+
+ package IO::File;
+
+ =head1 NAME
+
+ IO::File - supply object methods for filehandles
+
+ =head1 SYNOPSIS
+
+ use IO::File;
+
+ $fh = new IO::File;
+ if ($fh->open "< file") {
+ print <$fh>;
+ $fh->close;
+ }
+
+ $fh = new IO::File "> FOO";
+ if (defined $fh) {
+ print $fh "bar\n";
+ $fh->close;
+ }
+
+ $fh = new IO::File "file", "r";
+ if (defined $fh) {
+ print <$fh>;
+ undef $fh; # automatically closes the file
+ }
+
+ $fh = new IO::File "file", O_WRONLY|O_APPEND;
+ if (defined $fh) {
+ print $fh "corge\n";
+ undef $fh; # automatically closes the file
+ }
+
+ $pos = $fh->getpos;
+ $fh->setpos $pos;
+
+ $fh->setvbuf($buffer_var, _IOLBF, 1024);
+
+ autoflush STDOUT 1;
+
+ =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::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.).
+
+ =head1 SEE ALSO
+
+ L<perlfunc>,
+ L<perlop/"I/O Operators">,
+ L<"IO::Handle">
+ L<"IO::Seekable">
+
+ =head1 HISTORY
+
+ Derived from FileHandle.pm by Graham Barr <bodg@tiuk.ti.com>
+
+ =head1 REVISION
+
+ $Revision: 1.3 $
+
+ =cut
+
+ 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;
+
+ require Exporter;
+ require DynaLoader;
+
+ @ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader);
+
+ $VERSION = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\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;
+ eval {
+ require Fcntl;
+ Exporter::export 'Fcntl', $callpkg;
+ };
+ };
+
+
+ ################################################
+ ## Constructor
+ ##
+
+ sub new {
+ @_ >= 1 && @_ <= 3 or croak 'usage: new IO::File [FILENAME [,MODE]]';
+ my $class = shift;
+ my $fh = $class->SUPER::new();
+ if (@_) {
+ $fh->open(@_)
+ or return undef;
+ }
+ $fh;
+ }
+
+ ################################################
+ ## Open
+ ##
+
+ sub open {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
+ my ($fh, $file) = @_;
+ if (@_ > 2) {
+ my ($mode, $perms) = @_[2, 3];
+ if ($mode =~ /^\d+$/) {
+ defined $perms or $perms = 0666;
+ return sysopen($fh, $file, $mode, $perms);
+ }
+ $file = "./" . $file unless $file =~ m#^/#;
+ $file = _open_mode_string($mode) . " $file\0";
+ }
+ open($fh, $file);
+ }
+
+ 1;
#~ Add IO extension
diff -Pcr perl5_003/ext/IO/lib/IO/Handle.pm perl5_003_01/ext/IO/lib/IO/Handle.pm
*** perl5_003/ext/IO/lib/IO/Handle.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/IO/lib/IO/Handle.pm Mon Jul 8 16:45:22 1996
***************
*** 0 ****
--- 1,514 ----
+ #
+
+ package IO::Handle;
+
+ =head1 NAME
+
+ IO::Handle - supply object methods for filehandles
+
+ =head1 SYNOPSIS
+
+ use IO::Handle;
+
+ $fh = new IO::Handle;
+ if ($fh->open "< file") {
+ print <$fh>;
+ $fh->close;
+ }
+
+ $fh = new IO::Handle "> FOO";
+ if (defined $fh) {
+ print $fh "bar\n";
+ $fh->close;
+ }
+
+ $fh = new IO::Handle "file", "r";
+ if (defined $fh) {
+ print <$fh>;
+ undef $fh; # automatically closes the file
+ }
+
+ $fh = new IO::Handle "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);
+
+ autoflush STDOUT 1;
+
+ =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::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>.
+
+ C<IO::Handle::opened> returns true if the object is currently a valid
+ file descriptor.
+
+ 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.
+
+ If the C function setvbuf() is available, then C<IO::Handle::setvbuf>
+ sets the buffering policy for the IO::Handle. 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<IO::Handle::setvbuf> must not be
+ modified in any way until the IO::Handle is closed or until
+ C<IO::Handle::setvbuf> is called again, or memory corruption may
+ result!
+
+ See L<perlfunc> for complete descriptions of each of the following
+ supported C<IO::Handle> methods, which are just front ends for the
+ corresponding built-in functions:
+
+ close
+ fileno
+ getc
+ gets
+ eof
+ read
+ truncate
+ stat
+
+ See L<perlvar> for complete descriptions of each of the following
+ supported C<IO::Handle> methods:
+
+ autoflush
+ output_field_separator
+ output_record_separator
+ input_record_separator
+ input_line_number
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ format_line_break_characters
+ format_formfeed
+ format_write
+
+ Furthermore, for doing normal I/O you might need these:
+
+ =over
+
+ =item $fh->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
+
+ The reference returned from new is a GLOB reference. Some modules that
+ inherit from C<IO::Handle> may want to keep object related variables
+ in the hash table part of the GLOB. In an attempt to prevent modules
+ trampling on each other I propose the that any such module should prefix
+ its variables with its own name separated by _'s. For example the IO::Socket
+ module keeps a C<timeout> variable in 'io_socket_timeout'.
+
+ =head1 SEE ALSO
+
+ L<perlfunc>,
+ L<perlop/"I/O Operators">,
+ L<POSIX/"FileHandle">
+
+ =head1 BUGS
+
+ Due to backwards compatibility, all filehandles resemble objects
+ of class C<IO::Handle>, or actually classes derived from that class.
+ They actually aren't. Which means you can't derive your own
+ class from C<IO::Handle> and inherit those methods.
+
+ =head1 HISTORY
+
+ Derived from FileHandle.pm by Graham Barr <bodg@tiuk.ti.com>
+
+ =cut
+
+ require 5.000;
+ use vars qw($VERSION @EXPORT_OK $AUTOLOAD);
+ use Carp;
+ use Symbol;
+ 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+)/);
+
+ @EXPORT_OK = qw(
+ autoflush
+ output_field_separator
+ output_record_separator
+ input_record_separator
+ input_line_number
+ format_page_number
+ format_lines_per_page
+ format_lines_left
+ format_name
+ format_top_name
+ format_line_break_characters
+ format_formfeed
+ format_write
+
+ print
+ printf
+ getline
+ getlines
+
+ SEEK_SET
+ SEEK_CUR
+ SEEK_END
+ _IOFBF
+ _IOLBF
+ _IONBF
+
+ _open_mode_string
+ );
+
+
+ ################################################
+ ## Interaction with the XS.
+ ##
+
+ require DynaLoader;
+ @IO::ISA = qw(DynaLoader);
+ bootstrap IO $VERSION;
+
+ sub AUTOLOAD {
+ if ($AUTOLOAD =~ /::(_?[a-z])/) {
+ $AutoLoader::AUTOLOAD = $AUTOLOAD;
+ goto &AutoLoader::AUTOLOAD
+ }
+ my $constname = $AUTOLOAD;
+ $constname =~ s/.*:://;
+ my $val = constant($constname);
+ defined $val or croak "$constname is not a valid IO::Handle macro";
+ *$AUTOLOAD = sub { $val };
+ goto &$AUTOLOAD;
+ }
+
+
+ ################################################
+ ## Constructors, destructors.
+ ##
+
+ sub new {
+ @_ == 1 or croak 'usage: new IO::Handle';
+ my $class = ref($_[0]) || $_[0];
+ 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 $fh = gensym;
+ 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 :-)
+
+ sub DESTROY { }
+
+ ################################################
+ ## Open and close.
+ ##
+
+ sub _open_mode_string {
+ my ($mode) = @_;
+ $mode =~ /^\+?(<|>>?)$/
+ or $mode =~ s/^r(\+?)$/$1</
+ or $mode =~ s/^w(\+?)$/$1>/
+ or $mode =~ s/^a(\+?)$/$1>>/
+ or croak "IO::Handle: bad open mode: $mode";
+ $mode;
+ }
+
+ sub fdopen {
+ @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
+ my ($fh, $fd, $mode) = @_;
+ local(*GLOB);
+
+ if (ref($fd) && "".$fd =~ /GLOB\(/o) {
+ # It's a glob reference; Alias it as we cannot get name of anon GLOBs
+ my $n = qualify(*GLOB);
+ *GLOB = *{*$fd};
+ $fd = $n;
+ } elsif ($fd =~ m#^\d+$#) {
+ # It's an FD number; prefix with "=".
+ $fd = "=$fd";
+ }
+
+ open($fh, _open_mode_string($mode) . '&' . $fd)
+ ? $fh : undef;
+ }
+
+ sub close {
+ @_ == 1 or croak 'usage: $fh->close()';
+ my($fh) = @_;
+ my $r = close($fh);
+
+ # This may seem as though it should be in IO::Pipe, but the
+ # object gets blessed out of IO::Pipe when reader/writer is called
+ waitpid(${*$fh}{'io_pipe_pid'},0)
+ if(defined ${*$fh}{'io_pipe_pid'});
+
+ $r;
+ }
+
+ ################################################
+ ## Normal I/O functions.
+ ##
+
+ # fcntl
+ # flock
+ # ioctl
+ # select
+ # sysread
+ # syswrite
+
+ sub opened {
+ @_ == 1 or croak 'usage: $fh->opened()';
+ defined fileno($_[0]);
+ }
+
+ sub fileno {
+ @_ == 1 or croak 'usage: $fh->fileno()';
+ fileno($_[0]);
+ }
+
+ sub getc {
+ @_ == 1 or croak 'usage: $fh->getc()';
+ getc($_[0]);
+ }
+
+ sub gets {
+ @_ == 1 or croak 'usage: $fh->gets()';
+ my ($handle) = @_;
+ scalar <$handle>;
+ }
+
+ sub eof {
+ @_ == 1 or croak 'usage: $fh->eof()';
+ eof($_[0]);
+ }
+
+ sub print {
+ @_ or croak 'usage: $fh->print([ARGS])';
+ my $this = shift;
+ print $this @_;
+ }
+
+ sub printf {
+ @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])';
+ my $this = shift;
+ printf $this @_;
+ }
+
+ sub getline {
+ @_ == 1 or croak 'usage: $fh->getline';
+ my $this = shift;
+ return scalar <$this>;
+ }
+
+ 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";
+ return <$this>;
+ }
+
+ sub truncate {
+ @_ == 2 or croak 'usage: $fh->truncate(LEN)';
+ truncate($_[0], $_[1]);
+ }
+
+ sub read {
+ @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])';
+ read($_[0], $_[1], $_[2], $_[3] || 0);
+ }
+
+ sub write {
+ @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])';
+ local($\) = "";
+ print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
+ }
+
+ sub stat {
+ @_ == 1 or croak 'usage: $fh->stat()';
+ stat($_[0]);
+ }
+
+ ################################################
+ ## State modification functions.
+ ##
+
+ sub autoflush {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $|;
+ $| = @_ > 1 ? $_[1] : 1;
+ $prev;
+ }
+
+ sub output_field_separator {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $,;
+ $, = $_[1] if @_ > 1;
+ $prev;
+ }
+
+ sub output_record_separator {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $\;
+ $\ = $_[1] if @_ > 1;
+ $prev;
+ }
+
+ sub input_record_separator {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $/;
+ $/ = $_[1] if @_ > 1;
+ $prev;
+ }
+
+ sub input_line_number {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $.;
+ $. = $_[1] if @_ > 1;
+ $prev;
+ }
+
+ sub format_page_number {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $%;
+ $% = $_[1] if @_ > 1;
+ $prev;
+ }
+
+ sub format_lines_per_page {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $=;
+ $= = $_[1] if @_ > 1;
+ $prev;
+ }
+
+ sub format_lines_left {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $-;
+ $- = $_[1] if @_ > 1;
+ $prev;
+ }
+
+ sub format_name {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $~;
+ $~ = qualify($_[1], caller) if @_ > 1;
+ $prev;
+ }
+
+ sub format_top_name {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $^;
+ $^ = qualify($_[1], caller) if @_ > 1;
+ $prev;
+ }
+
+ sub format_line_break_characters {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $:;
+ $: = $_[1] if @_ > 1;
+ $prev;
+ }
+
+ sub format_formfeed {
+ my $old = new SelectSaver qualify($_[0], caller);
+ my $prev = $^L;
+ $^L = $_[1] if @_ > 1;
+ $prev;
+ }
+
+ sub formline {
+ my $fh = shift;
+ my $picture = shift;
+ local($^A) = $^A;
+ local($\) = "";
+ formline($picture, @_);
+ print $fh $^A;
+ }
+
+ sub format_write {
+ @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )';
+ if (@_ == 2) {
+ my ($fh, $fmt) = @_;
+ my $oldfmt = $fh->format_name($fmt);
+ write($fh);
+ $fh->format_name($oldfmt);
+ } else {
+ write($_[0]);
+ }
+ }
+
+
+ 1;
#~ Add IO extension
diff -Pcr perl5_003/ext/IO/lib/IO/Pipe.pm perl5_003_01/ext/IO/lib/IO/Pipe.pm
*** perl5_003/ext/IO/lib/IO/Pipe.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/IO/lib/IO/Pipe.pm Mon Jul 8 16:45:22 1996
***************
*** 0 ****
--- 1,177 ----
+ #
+
+ package IO::Pipe;
+
+ =head1 NAME
+
+ IO::pipe - supply object methods for pipes
+
+ =head1 SYNOPSIS
+
+ use IO::Pipe;
+
+ $pipe = new IO::Pipe;
+
+ if($pid = fork()) { # Parent
+ $pipe->reader();
+
+ while(<$pipe> {
+ ....
+ }
+
+ }
+ elsif(defined $pid) { # Child
+ $pipe->writer();
+
+ print $pipe ....
+ }
+
+ or
+
+ $pipe = new IO::Pipe;
+
+ $pipe->reader(qw(ls -l));
+
+ while(<$pipe>) {
+ ....
+ }
+
+ =head1 DESCRIPTION
+
+ C<IO::Pipe::new> 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
+ C<reader> or C<writer> is called.
+
+ =over
+
+ =item $fh->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])
+
+ 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
+
+ This method is called during construction by C<IO::Pipe::new>
+ on the newly created C<IO::Pipe> object. It returns an array of two objects
+ blessed into C<IO::Handle>, or a subclass thereof.
+
+ =back
+
+ =head1 SEE ALSO
+
+ L<IO::Handle>
+
+ =head1 AUTHOR
+
+ Graham Barr <bodg@tiuk.ti.com>
+
+ =head1 REVISION
+
+ $Revision: 1.4 $
+
+ =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
+
+ require 5.000;
+ use vars qw($VERSION);
+ use Carp;
+ use Symbol;
+ require IO::Handle;
+
+ $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
+
+ sub new {
+ @_ == 1 || @_ == 3 or croak 'usage: new IO::Pipe([$READFH, $WRITEFH])';
+
+ my $me = bless gensym(), shift;
+
+ my($readfh,$writefh) = @_ ? @_ : $me->handles;
+
+ pipe($readfh, $writefh)
+ or return undef;
+
+ @{*$me} = ($readfh, $writefh);
+
+ $me;
+ }
+
+ sub handles {
+ @_ == 1 or croak 'usage: $pipe->handles()';
+ (IO::Handle->new(), IO::Handle->new());
+ }
+
+ sub _doit {
+ my $me = shift;
+ my $rw = shift;
+
+ my $pid = fork();
+
+ if($pid) { # Parent
+ return $pid;
+ }
+ elsif(defined $pid) { # Child
+ my $fh = $rw ? $me->reader() : $me->writer();
+ my $io = $rw ? \*STDIN : \*STDOUT;
+
+ bless $io, "IO::Handle";
+ $io->fdopen($fh, $rw ? "r" : "w");
+ exec @_ or
+ croak "IO::Pipe: Cannot exec: $!";
+ }
+ else {
+ croak "IO::Pipe: Cannot fork: $!";
+ }
+
+ # NOT Reached
+ }
+
+ sub reader {
+ @_ >= 1 or croak 'usage: $pipe->reader()';
+ my $me = shift;
+ my $fh = ${*$me}[0];
+ my $pid = $me->_doit(0,@_)
+ if(@_);
+
+ bless $me, ref($fh);
+ *{*$me} = *{*$fh}; # Alias self to handle
+ ${*$me}{'io_pipe_pid'} = $pid
+ if defined $pid;
+
+ $me;
+ }
+
+ sub writer {
+ @_ >= 1 or croak 'usage: $pipe->writer()';
+ my $me = shift;
+ my $fh = ${*$me}[1];
+ my $pid = $me->_doit(1,@_)
+ if(@_);
+
+ bless $me, ref($fh);
+ *{*$me} = *{*$fh}; # Alias self to handle
+ ${*$me}{'io_pipe_pid'} = $pid
+ if defined $pid;
+
+ $me;
+ }
+
+ 1;
+
#~ Add IO extension
diff -Pcr perl5_003/ext/IO/lib/IO/Seekable.pm perl5_003_01/ext/IO/lib/IO/Seekable.pm
*** perl5_003/ext/IO/lib/IO/Seekable.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/IO/lib/IO/Seekable.pm Mon Jul 8 16:45:23 1996
***************
*** 0 ****
--- 1,71 ----
+ #
+
+ package IO::Seekable;
+
+ =head1 NAME
+
+ IO::Seekable - supply seek based methods for I/O objects
+
+ =head1 DESCRIPTION
+
+ C<IO::Seekable> does not have a constuctor of its own as is intended to
+ be inherited by other C<IO::Handle> based objects. It provides methods
+ which allow seeking of the file descriptors.
+
+ If the C functions fgetpos() and fsetpos() are available, then
+ C<IO::File::getpos> returns an opaque value that represents the
+ current position of the IO::File, and C<IO::File::setpos> uses
+ that value to return to a previously visited position.
+
+ See L<perlfunc> for complete descriptions of each of the following
+ supported C<IO::Seekable> methods, which are just front ends for the
+ corresponding built-in functions:
+
+ clearerr
+ seek
+ tell
+
+ =head1 SEE ALSO
+
+ L<perlfunc>,
+ L<perlop/"I/O Operators">,
+ L<"IO::Handle">
+ L<"IO::File">
+
+ =head1 HISTORY
+
+ Derived from FileHandle.pm by Graham Barr <bodg@tiuk.ti.com>
+
+ =head1 REVISION
+
+ $Revision: 1.4 $
+
+ =cut
+
+ require 5.000;
+ use Carp;
+ use vars qw($VERSION @EXPORT @ISA);
+ use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
+ require Exporter;
+
+ @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
+ @ISA = qw(Exporter);
+
+ $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
+
+ sub clearerr {
+ @_ == 1 or croak 'usage: $fh->clearerr()';
+ seek($_[0], 0, SEEK_CUR);
+ }
+
+ sub seek {
+ @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
+ seek($_[0], $_[1], $_[2]);
+ }
+
+ sub tell {
+ @_ == 1 or croak 'usage: $fh->tell()';
+ tell($_[0]);
+ }
+
+ 1;
#~ Add IO extension
diff -Pcr perl5_003/ext/IO/lib/IO/Select.pm perl5_003_01/ext/IO/lib/IO/Select.pm
*** perl5_003/ext/IO/lib/IO/Select.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/IO/lib/IO/Select.pm Mon Jul 8 16:45:23 1996
***************
*** 0 ****
--- 1,280 ----
+ # IO::Select.pm
+
+ package IO::Select;
+
+ =head1 NAME
+
+ IO::Select - OO interface to the system select call
+
+ =head1 SYNOPSYS
+
+ use IO::Select;
+
+ $s = IO::Select->new();
+
+ $s->add(\*STDIN);
+ $s->add($some_handle);
+
+ @ready = $s->can_read($timeout);
+
+ @ready = IO::Select->new(@handles)->read(0);
+
+ =head1 DESCRIPTION
+
+ The C<IO::Select> package implements an object approach to the system C<select>
+ function call. It allows the user to see what IO handles, see L<IO::Handle>,
+ are ready for reading, writing or have an error condition pending.
+
+ =head1 CONSTRUCTOR
+
+ =over 4
+
+ =item new ( [ HANDLES ] )
+
+ The constructor create a new object and optionally initialises it with a set
+ of handles.
+
+ =back
+
+ =head1 METHODS
+
+ =over 4
+
+ =item add ( HANDLES )
+
+ Add the list of handles to the C<IO::Select> object. It is these values that
+ will be returned when an event occurs. C<IO::Select> keeps these values in a
+ cache which is indexed by the C<fileno> of the handle, so if more than one
+ handle with the same C<fileno> is specified then only the last one is cached.
+
+ =item remove ( HANDLES )
+
+ Remove all the given handles from the object.
+
+ =item can_read ( [ TIMEOUT ] )
+
+ Return an array of handles that are ready for reading. C<TIMEOUT> is the maximum
+ amount of time to wait before returning an empty list. If C<TIMEOUT> is
+ not given then the call will block.
+
+ =item can_write ( [ TIMEOUT ] )
+
+ Same as C<can_read> except check for handles that can be written to.
+
+ =item has_error ( [ TIMEOUT ] )
+
+ Same as C<can_read> except check for handles that have an error condition, for
+ example EOF.
+
+ =item select ( READ, WRITE, ERROR [, TIMEOUT ] )
+
+ C<select> is a static method, that is you call it with the package name
+ like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef> or
+ C<IO::Select> objects. C<TIMEOUT> is optional and has the same effect as
+ before.
+
+ The result will be an array of 3 elements, each a reference to an array
+ which will hold the handles that are ready for reading, writing and have
+ error conditions respectively. Upon error an empty array is returned.
+
+ =back
+
+ =head1 EXAMPLE
+
+ Here is a short example which shows how C<IO::Select> could be used
+ to write a server which communicates with several sockets while also
+ listening for more connections on a listen socket
+
+ use IO::Select;
+ use IO::Socket;
+
+ $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
+ $sel = new IO::Select( $lsn );
+
+ while(@ready = $sel->can_read) {
+ foreach $fh (@ready) {
+ if($fh == $lsn) {
+ # Create a new socket
+ $new = $lsn->accept;
+ $sel->add($new);
+ }
+ else {
+ # Process socket
+
+ # Maybe we have finished with the socket
+ $sel->remove($fh);
+ $fh->close;
+ }
+ }
+ }
+
+ =head1 AUTHOR
+
+ Graham Barr <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
+
+ use strict;
+ use vars qw($VERSION @ISA);
+ require Exporter;
+
+ $VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/);
+
+ @ISA = qw(Exporter); # This is only so we can do version checking
+
+ sub new
+ {
+ my $self = shift;
+ my $type = ref($self) || $self;
+
+ my $vec = bless [''], $type;
+
+ $vec->add(@_)
+ if @_;
+
+ $vec;
+ }
+
+ sub add
+ {
+ my $vec = shift;
+ my $f;
+
+ foreach $f (@_)
+ {
+ my $fn = $f =~ /^\d+$/ ? $f : fileno($f);
+ next
+ unless defined $fn;
+ vec($vec->[0],$fn++,1) = 1;
+ $vec->[$fn] = $f;
+ }
+ }
+
+ sub remove
+ {
+ my $vec = shift;
+ my $f;
+
+ foreach $f (@_)
+ {
+ my $fn = $f =~ /^\d+$/ ? $f : fileno($f);
+ next
+ unless defined $fn;
+ vec($vec->[0],$fn++,1) = 0;
+ $vec->[$fn] = undef;
+ }
+ }
+
+ sub can_read
+ {
+ my $vec = shift;
+ my $timeout = shift;
+
+ my $r = $vec->[0];
+
+ select($r,undef,undef,$timeout) > 0
+ ? _handles($vec, $r)
+ : ();
+ }
+
+ sub can_write
+ {
+ my $vec = shift;
+ my $timeout = shift;
+
+ my $w = $vec->[0];
+
+ select(undef,$w,undef,$timeout) > 0
+ ? _handles($vec, $w)
+ : ();
+ }
+
+ sub has_error
+ {
+ my $vec = shift;
+ my $timeout = shift;
+
+ my $e = $vec->[0];
+
+ select(undef,undef,$e,$timeout) > 0
+ ? _handles($vec, $e)
+ : ();
+ }
+
+ sub _max
+ {
+ my($a,$b,$c) = @_;
+ $a > $b
+ ? $a > $c
+ ? $a
+ : $c
+ : $b > $c
+ ? $b
+ : $c;
+ }
+
+ sub select
+ {
+ shift
+ if defined $_[0] && !ref($_[0]);
+
+ my($r,$w,$e,$t) = @_;
+ my @result = ();
+
+ my $rb = defined $r ? $r->[0] : undef;
+ my $wb = defined $w ? $e->[0] : undef;
+ my $eb = defined $e ? $w->[0] : 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);
+
+ for( ; $i > 0 ; $i--)
+ {
+ my $j = $i - 1;
+ push(@r, $r->[$i])
+ if defined $r->[$i] && vec($rb, $j, 1);
+ push(@w, $w->[$i])
+ if defined $w->[$i] && vec($wb, $j, 1);
+ push(@e, $e->[$i])
+ if defined $e->[$i] && vec($eb, $j, 1);
+ }
+
+ @result = (\@r, \@w, \@e);
+ }
+ @result;
+ }
+
+ sub _handles
+ {
+ my $vec = shift;
+ my $bits = shift;
+ my @h = ();
+ my $i;
+
+ for($i = scalar(@$vec) - 1 ; $i > 0 ; $i--)
+ {
+ next unless defined $vec->[$i];
+ push(@h, $vec->[$i])
+ if vec($bits,$i - 1,1);
+ }
+
+ @h;
+ }
+
+ 1;
#~ Add IO extension
diff -Pcr perl5_003/ext/IO/lib/IO/Socket.pm perl5_003_01/ext/IO/lib/IO/Socket.pm
*** perl5_003/ext/IO/lib/IO/Socket.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/IO/lib/IO/Socket.pm Thu Jul 18 14:03:32 1996
***************
*** 0 ****
--- 1,563 ----
+ #
+
+ package IO::Socket;
+
+ =head1 NAME
+
+ IO::Socket - supply object methods for sockets
+
+ =head1 SYNOPSIS
+
+ use IO::Socket;
+
+ =head1 DESCRIPTION
+
+ C<IO::Socket> provides an object interface to creating and using sockets. It
+ is built upon the L<IO::Handle> interface and inherits all the methods defined
+ by L<IO::Handle>.
+
+ C<IO::Socket> only defines methods for those operations which are common to all
+ types of socket. Operations which are specified to a socket in a particular
+ domain have methods defined in sub classes of C<IO::Socket>
+
+ 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:
+
+ socket
+ socketpair
+ bind
+ listen
+ accept
+ send
+ recv
+ peername (getpeername)
+ sockname (getsockname)
+
+ Some methods take slightly different arguments to those defined in L<perlfunc>
+ in attempt to make the interface more flexible. These are
+
+ =item accept([PKG])
+
+ perform the system call C<accept> on the socket and return a new object. The
+ new object will be created in the same class as the listen socket, unless
+ C<PKG> is specified. This object can be used to communicate with the client
+ that was trying to connect. In a scalar context the new socket is returned,
+ or undef upon failure. In an array context a two-element array is returned
+ containing the new socket and the peer address, the list will
+ be empty upon failure.
+
+ Additional methods that are provided are
+
+ =item timeout([VAL])
+
+ Set or get the timeout value associated with this socket. If called without
+ any arguments then the current setting is returned. If called with an argument
+ the current setting is changed and the previous value returned.
+
+ =item sockopt(OPT [, VAL])
+
+ Unified method to both set and get options in the SOL_SOCKET level. If called
+ with one argument then getsockopt is called, otherwise setsockopt is called
+
+ =cut
+
+
+ require 5.000;
+
+ use Config;
+ use IO::Handle;
+ use Socket 1.3;
+ use Carp;
+ use strict;
+ use vars qw(@ISA @EXPORT_OK $VERSION);
+ 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};
+
+ sub import {
+ my $pkg = shift;
+ my $callpkg = caller;
+ Exporter::export 'Socket', $callpkg, @_;
+ }
+
+ sub new {
+ my($class,%arg) = @_;
+ my $fh = $class->SUPER::new();
+
+ ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
+
+ return scalar(%arg) ? $fh->configure(\%arg)
+ : $fh;
+ }
+
+ sub configure {
+ croak 'IO::Socket: Cannot configure a generic socket';
+ }
+
+ sub socket {
+ @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
+ my($fh,$domain,$type,$protocol) = @_;
+
+ socket($fh,$domain,$type,$protocol) or
+ return undef;
+
+ ${*$fh}{'io_socket_type'} = $type;
+ $fh;
+ }
+
+ sub socketpair {
+ @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
+ my($class,$domain,$type,$protocol) = @_;
+ my $fh1 = $class->new();
+ my $fh2 = $class->new();
+
+ socketpair($fh1,$fh1,$domain,$type,$protocol) or
+ return ();
+
+ ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type;
+
+ ($fh1,$fh2);
+ }
+
+ sub connect {
+ @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
+ my $fh = shift;
+ my $addr = @_ == 1 ? shift : sockaddr_in(@_);
+ my $timeout = ${*$fh}{'io_socket_timeout'};
+ local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
+ : $SIG{ALRM} || 'DEFAULT';
+
+ eval {
+ croak 'connect: Bad address'
+ if(@_ == 2 && !defined $_[1]);
+
+ if($timeout) {
+ defined $Config{d_alarm} && defined alarm($timeout) or
+ $timeout = 0;
+ }
+
+ my $ok = eval { connect($fh, $addr) };
+
+ alarm(0)
+ if($timeout);
+
+ croak "connect: timeout"
+ unless defined $fh;
+
+ undef $fh unless $ok;
+
+ };
+ $fh;
+ }
+
+ sub bind {
+ @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
+ my $fh = shift;
+ my $addr = @_ == 1 ? shift : sockaddr_in(@_);
+
+ return bind($fh, $addr) ? $fh
+ : undef;
+ }
+
+ sub listen {
+ @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
+ my($fh,$queue) = @_;
+ $queue = 5
+ unless $queue && $queue > 0;
+
+ return listen($fh, $queue) ? $fh
+ : undef;
+ }
+
+ sub accept {
+ @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])';
+ my $fh = shift;
+ my $pkg = shift || $fh;
+ my $timeout = ${*$fh}{'io_socket_timeout'};
+ my $new = $pkg->new(Timeout => $timeout);
+ my $peer = undef;
+
+ eval {
+ if($timeout) {
+ my $fdset = "";
+ vec($fdset, $fh->fileno,1) = 1;
+ croak "accept: timeout"
+ unless select($fdset,undef,undef,$timeout);
+ }
+ $peer = accept($new,$fh);
+ };
+
+ return wantarray ? defined $peer ? ($new, $peer)
+ : ()
+ : defined $peer ? $new
+ : undef;
+ }
+
+ sub sockname {
+ @_ == 1 or croak 'usage: $fh->sockname()';
+ getsockname($_[0]);
+ }
+
+ sub peername {
+ @_ == 1 or croak 'usage: $fh->peername()';
+ my($fh) = @_;
+ getpeername($fh)
+ || ${*$fh}{'io_socket_peername'}
+ || undef;
+ }
+
+ sub send {
+ @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
+ my $fh = $_[0];
+ my $flags = $_[2] || 0;
+ my $peer = $_[3] || $fh->peername;
+
+ croak 'send: Cannot determine peer address'
+ unless($peer);
+
+ my $r = send($fh, $_[1], $flags, $peer);
+
+ # remember who we send to, if it was sucessful
+ ${*$fh}{'io_socket_peername'} = $peer
+ if(@_ == 4 && defined $r);
+
+ $r;
+ }
+
+ sub recv {
+ @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
+ my $sock = $_[0];
+ my $len = $_[2];
+ my $flags = $_[3] || 0;
+
+ # remember who we recv'd from
+ ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
+ }
+
+
+ sub setsockopt {
+ @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
+ setsockopt($_[0],$_[1],$_[2],$_[3]);
+ }
+
+ my $intsize = length(pack("i",0));
+
+ sub getsockopt {
+ @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
+ my $r = getsockopt($_[0],$_[1],$_[2]);
+ # Just a guess
+ $r = unpack("i", $r)
+ if(defined $r && length($r) == $intsize);
+ $r;
+ }
+
+ sub sockopt {
+ my $fh = shift;
+ @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
+ : $fh->setsockopt(SOL_SOCKET,@_);
+ }
+
+ sub timeout {
+ @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
+ my($fh,$val) = @_;
+ my $r = ${*$fh}{'io_socket_timeout'} || undef;
+
+ ${*$fh}{'io_socket_timeout'} = 0 + $val
+ if(@_ == 2);
+
+ $r;
+ }
+
+ sub socktype {
+ @_ == 1 or croak '$fh->socktype()';
+ ${*{$_[0]}}{'io_socket_type'} || undef;
+ }
+
+ =head1 SUB-CLASSES
+
+ =cut
+
+ ##
+ ## AF_INET
+ ##
+
+ package IO::Socket::INET;
+
+ use strict;
+ use vars qw(@ISA $VERSION);
+ use Socket;
+ use Carp;
+ use Exporter;
+
+ @ISA = qw(IO::Socket);
+
+ my %socket_type = ( tcp => SOCK_STREAM,
+ udp => SOCK_DGRAM,
+ );
+
+ =head2 IO::Socket::INET
+
+ C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
+ and some related methods. The constructor can take the following options
+
+ PeerAddr Remote host address
+ PeerPort Remote port or service
+ LocalPort Local host bind port
+ LocalAddr Local host bind address
+ Proto Protocol name (eg tcp udp etc)
+ Type Socket type (SOCK_STREAM etc)
+ 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
+
+ Only one of C<Type> or C<Proto> needs to be specified, one will be assumed
+ from the other.
+
+ =head2 METHODS
+
+ =item sockaddr()
+
+ Return the address part of the sockaddr structure for the socket
+
+ =item sockport()
+
+ Return the port number that the socket is using on the local host
+
+ =item sockhost()
+
+ Return the address part of the sockaddr structure for the socket in a
+ text form xx.xx.xx.xx
+
+ =item peeraddr(), peerport(), peerhost()
+
+ Same as for the sock* functions, but returns the data about the peer
+ host instead of the local host.
+
+ =cut
+
+
+ sub _sock_info {
+ my($addr,$port,$proto) = @_;
+ my @proto = ();
+ my @serv = ();
+
+ $port = $1
+ if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
+
+ if(defined $proto) {
+ @proto = $proto =~ m,\D, ? getprotobyname($proto)
+ : getprotobynumber($proto);
+
+ $proto = $proto[2] || undef;
+ }
+
+ if(defined $port) {
+ $port =~ s,\((\d+)\)$,,;
+
+ my $defport = $1 || undef;
+ my $pnum = ($port =~ m,^(\d+)$,)[0];
+
+ @serv= getservbyname($port, $proto[0] || "")
+ if($port =~ m,\D,);
+
+ $port = $pnum || $serv[2] || $defport || undef;
+
+ $proto = (getprotobyname($serv[3]))[2] || undef
+ if @serv && !$proto;
+ }
+
+ return ($addr || undef,
+ $port || undef,
+ $proto || undef
+ );
+ }
+
+ sub configure {
+ my($fh,$arg) = @_;
+ my($lport,$rport,$laddr,$raddr,$proto,$type);
+
+
+ ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
+ $arg->{LocalPort},
+ $arg->{Proto});
+
+ $laddr = defined $laddr ? inet_aton($laddr)
+ : INADDR_ANY;
+
+ unless(exists $arg->{Listen}) {
+ ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
+ $arg->{PeerPort},
+ $proto);
+ }
+
+ croak 'IO::Socket: Cannot determine protocol'
+ unless($proto);
+
+ my $pname = (getprotobynumber($proto))[0];
+ $type = $arg->{Type} || $socket_type{$pname};
+
+ $fh->socket(AF_INET, $type, $proto) or
+ return undef;
+
+ $fh->bind($lport || 0, $laddr) or
+ return undef;
+
+ if(exists $arg->{Listen}) {
+ $fh->listen($arg->{Listen} || 5) or
+ return undef;
+ }
+ else {
+ croak "IO::Socket: Cannot determine remote port"
+ unless($rport || $type == SOCK_DGRAM);
+
+ if($type == SOCK_STREAM || defined $raddr) {
+ croak "IO::Socket: Bad peer address"
+ unless defined $raddr;
+
+ $fh->connect($rport,inet_aton($raddr)) or
+ return undef;
+ }
+ }
+
+ $fh;
+ }
+
+ sub sockaddr {
+ @_ == 1 or croak 'usage: $fh->sockaddr()';
+ my($fh) = @_;
+ (sockaddr_in($fh->sockname))[1];
+ }
+
+ sub sockport {
+ @_ == 1 or croak 'usage: $fh->sockport()';
+ my($fh) = @_;
+ (sockaddr_in($fh->sockname))[0];
+ }
+
+ sub sockhost {
+ @_ == 1 or croak 'usage: $fh->sockhost()';
+ my($fh) = @_;
+ inet_ntoa($fh->sockaddr);
+ }
+
+ sub peeraddr {
+ @_ == 1 or croak 'usage: $fh->peeraddr()';
+ my($fh) = @_;
+ (sockaddr_in($fh->peername))[1];
+ }
+
+ sub peerport {
+ @_ == 1 or croak 'usage: $fh->peerport()';
+ my($fh) = @_;
+ (sockaddr_in($fh->peername))[0];
+ }
+
+ sub peerhost {
+ @_ == 1 or croak 'usage: $fh->peerhost()';
+ my($fh) = @_;
+ inet_ntoa($fh->peeraddr);
+ }
+
+ ##
+ ## AF_UNIX
+ ##
+
+ package IO::Socket::UNIX;
+
+ use strict;
+ use vars qw(@ISA $VERSION);
+ use Socket;
+ use Carp;
+ use Exporter;
+
+ @ISA = qw(IO::Socket);
+
+ =head2 IO::Socket::UNIX
+
+ C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
+ and some related methods. The constructor can take the following options
+
+ Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
+ Local Path to local fifo
+ Peer Path to peer fifo
+ Listen Create a listen socket
+
+ =head2 METHODS
+
+ =item hostpath()
+
+ Returns the pathname to the fifo at the local end
+
+ =item peerpath()
+
+ Returns the pathanme to the fifo at the peer end
+
+ =cut
+
+ sub configure {
+ my($fh,$arg) = @_;
+ my($bport,$cport);
+
+ my $type = $arg->{Type} || SOCK_STREAM;
+
+ $fh->socket(AF_UNIX, $type, 0) or
+ return undef;
+
+ if(exists $arg->{Local}) {
+ my $addr = sockaddr_un($arg->{Local});
+ $fh->bind($addr) or
+ return undef;
+ }
+ if(exists $arg->{Listen}) {
+ $fh->listen($arg->{Listen} || 5) or
+ return undef;
+ }
+ elsif(exists $arg->{Peer}) {
+ my $addr = sockaddr_un($arg->{Peer});
+ $fh->connect($addr) or
+ return undef;
+ }
+
+ $fh;
+ }
+
+ sub hostpath {
+ @_ == 1 or croak 'usage: $fh->hostpath()';
+ (sockaddr_un($_[0]->hostname))[0];
+ }
+
+ sub peerpath {
+ @_ == 1 or croak 'usage: $fh->peerpath()';
+ (sockaddr_un($_[0]->peername))[0];
+ }
+
+ =head1 AUTHOR
+
+ Graham Barr <Graham.Barr@tiuk.ti.com>
+
+ =head1 REVISION
+
+ $Revision: 1.8 $
+
+ 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
+
+ =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
#~ Quote string argument in example -- necessary if using strict subs
diff -Pcr perl5_003/ext/NDBM_File/NDBM_File.pm perl5_003_01/ext/NDBM_File/NDBM_File.pm
*** perl5_003/ext/NDBM_File/NDBM_File.pm Mon Jun 24 16:07:53 1996
--- perl5_003_01/ext/NDBM_File/NDBM_File.pm Mon Jul 15 13:35:34 1996
***************
*** 28,34 ****
use NDBM_File;
! tie(%h,NDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640);
untie %h;
--- 28,34 ----
use NDBM_File;
! tie(%h, 'NDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640);
untie %h;
#~ Quote string argument in example -- necessary if using strict subs
diff -Pcr perl5_003/ext/ODBM_File/ODBM_File.pm perl5_003_01/ext/ODBM_File/ODBM_File.pm
*** perl5_003/ext/ODBM_File/ODBM_File.pm Wed Feb 14 21:40:21 1996
--- perl5_003_01/ext/ODBM_File/ODBM_File.pm Mon Jul 15 13:35:38 1996
***************
*** 24,30 ****
use ODBM_File;
! tie(%h,ODBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640);
untie %h;
--- 24,30 ----
use ODBM_File;
! tie(%h, 'ODBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640);
untie %h;
#~ Add Opcode extension
diff -Pcr perl5_003/ext/Opcode/Makefile.PL perl5_003_01/ext/Opcode/Makefile.PL
*** perl5_003/ext/Opcode/Makefile.PL Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/Opcode/Makefile.PL Tue Jun 18 15:04:01 1996
***************
*** 0 ****
--- 1,6 ----
+ use ExtUtils::MakeMaker;
+ WriteMakefile(
+ NAME => 'Opcode',
+ VERSION_FROM => 'Opcode.pm',
+ MAN3PODS => ' '
+ );
#~ Add Opcode extension
diff -Pcr perl5_003/ext/Opcode/Opcode.pm perl5_003_01/ext/Opcode/Opcode.pm
*** perl5_003/ext/Opcode/Opcode.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/Opcode/Opcode.pm Tue Jun 18 14:59:41 1996
***************
*** 0 ****
--- 1,564 ----
+ package Opcode;
+
+ require 5.002;
+
+ use vars qw($VERSION @ISA @EXPORT_OK);
+
+ $VERSION = "1.01";
+
+ use strict;
+ use Carp;
+ use Exporter ();
+ use DynaLoader ();
+ @ISA = qw(Exporter DynaLoader);
+
+ BEGIN {
+ @EXPORT_OK = qw(
+ opset ops_to_opset
+ opset_to_ops opset_to_hex invert_opset
+ empty_opset full_opset
+ opdesc opcodes opmask define_optag
+ opmask_add verify_opset opdump
+ );
+ }
+
+ use subs @EXPORT_OK;
+
+ bootstrap Opcode $VERSION;
+
+ _init_optags();
+
+
+ *ops_to_opset = \&opset; # alias for old name
+
+
+ sub opset_to_hex ($) {
+ return "(invalid opset)" unless verify_opset($_[0]);
+ unpack("h*",$_[0]);
+ }
+
+ sub opdump (;$) {
+ my $pat = shift;
+ # handy utility: perl -MOpcode=opdump -e 'opdump File'
+ foreach(opset_to_ops(full_opset)) {
+ my $op = sprintf " %12s %s\n", $_, opdesc($_);
+ next if defined $pat and $op !~ m/$pat/i;
+ print $op;
+ }
+ }
+
+
+
+ sub _init_optags {
+ my(%all, %seen);
+ @all{opset_to_ops(full_opset)} = (); # keys only
+
+ local($/) = "\n=cut"; # skip to optags definition section
+ <DATA>;
+ $/ = "\n="; # now read in 'pod section' chunks
+ while(<DATA>) {
+ next unless m/^item\s+(:\w+)/;
+ my $tag = $1;
+
+ # Split into lines, keep only indented lines
+ my @lines = grep { m/^\s/ } split(/\n/);
+ foreach (@lines) { s/--.*// } # delete comments
+ my @ops = map { split ' ' } @lines; # get op words
+
+ foreach(@ops) {
+ warn "$tag - $_ already tagged in $seen{$_}\n" if $seen{$_};
+ $seen{$_} = $tag;
+ delete $all{$_};
+ }
+ # opset will croak on invalid names
+ define_optag($tag, opset(@ops));
+ }
+ close(DATA);
+ warn "Untagged opnames: ".join(' ',keys %all)."\n" if %all;
+ }
+
+
+ 1;
+
+ __DATA__
+
+ =head1 NAME
+
+ Opcode - Disable named opcodes when compiling perl code
+
+ =head1 SYNOPSIS
+
+ use Opcode;
+
+
+ =head1 DESCRIPTION
+
+ Perl code is always compiled into an internal format before execution.
+
+ Evaluating perl code (e.g. via "eval" or "do 'file'") causes
+ the code to be compiled into an internal format and then,
+ provided there was no error in the compilation, executed.
+ The internal format is based on many distinct I<opcodes>.
+
+ By default no opmask is in effect and any code can be compiled.
+
+ The Opcode module allow you to define an I<operator mask> to be in
+ effect when perl I<next> compiles any code. Attempting to compile code
+ which contains a masked opcode will cause the compilation to fail
+ with an error. The code will not be executed.
+
+ =head1 NOTE
+
+ The Opcode module is not usually used directly. See the ops pragma and
+ Safe modules for more typical uses.
+
+ =head1 WARNING
+
+ The authors make B<no warranty>, implied or otherwise, about the
+ suitability of this software for safety or security purposes.
+
+ The authors shall not in any case be liable for special, incidental,
+ consequential, indirect or other similar damages arising from the use
+ of this software.
+
+ Your mileage will vary. If in any doubt B<do not use it>.
+
+
+ =head1 Operator Names and Operator Lists
+
+ The canonical list of operator names is the contents of the array
+ op_name defined and initialised in file F<opcode.h> of the Perl
+ source distribution (and installed into the perl library).
+
+ Each operator has both a terse name (its opname) and a more verbose or
+ recognisable descriptive name. The opdesc function can be used to
+ return a list of descriptions for a list of operators.
+
+ Many of the functions and methods listed below take a list of
+ operators as parameters. Most operator lists can be made up of several
+ types of element. Each element can be one of
+
+ =over 8
+
+ =item an operator name (opname)
+
+ Operator names are typically small lowercase words like enterloop,
+ leaveloop, last, next, redo etc. Sometimes they are rather cryptic
+ like gv2cv, i_ncmp and ftsvtx.
+
+ =item an operator tag name (optag)
+
+ Operator tags can be used to refer to groups (or sets) of operators.
+ Tag names always being with a colon. The Opcode module defines several
+ optags and the user can define others using the define_optag function.
+
+ =item a negated opname or optag
+
+ An opname or optag can be prefixed with an exclamation mark, e.g., !mkdir.
+ Negating an opname or optag means remove the corresponding ops from the
+ accumulated set of ops at that point.
+
+ =item an operator set (opset)
+
+ An I<opset> as a binary string of approximately 43 bytes which holds a
+ set or zero or more operators.
+
+ The opset and opset_to_ops functions can be used to convert from
+ a list of operators to an opset and I<vice versa>.
+
+ Wherever a list of operators can be given you can use one or more opsets.
+ See also Manipulating Opsets below.
+
+ =back
+
+
+ =head1 Opcode Functions
+
+ The Opcode package contains functions for manipulating operator names
+ tags and sets. All are available for export by the package.
+
+ =over 8
+
+ =item opcodes
+
+ In a scalar context opcodes returns the number of opcodes in this
+ version of perl (around 340 for perl5.002).
+
+ In a list context it returns a list of all the operator names.
+ (Not yet implemented, use @names = opset_to_ops(full_opset).)
+
+ =item opset (OP, ...)
+
+ Returns an opset containing the listed operators.
+
+ =item opset_to_ops (OPSET)
+
+ Returns a list of operator names corresponding to those operators in
+ the set.
+
+ =item opset_to_hex (OPSET)
+
+ Returns a string representation of an opset. Can be handy for debugging.
+
+ =item full_opset
+
+ Returns an opset which includes all operators.
+
+ =item empty_opset
+
+ Returns an opset which contains no operators.
+
+ =item invert_opset (OPSET)
+
+ Returns an opset which is the inverse set of the one supplied.
+
+ =item verify_opset (OPSET, ...)
+
+ Returns true if the supplied opset looks like a valid opset (is the
+ right length etc) otherwise it returns false. If an optional second
+ parameter is true then verify_opset will croak on an invalid opset
+ instead of returning false.
+
+ Most of the other Opcode functions call verify_opset automatically
+ and will croak if given an invalid opset.
+
+ =item define_optag (OPTAG, OPSET)
+
+ Define OPTAG as a symbolic name for OPSET. Optag names always start
+ with a colon C<:>.
+
+ The optag name used must not be defined already (define_optag will
+ croak if it is already defined). Optag names are global to the perl
+ process and optag definitions cannot be altered or deleted once
+ defined.
+
+ It is strongly recommended that applications using Opcode should use a
+ leading capital letter on their tag names since lowercase names are
+ reserved for use by the Opcode module. If using Opcode within a module
+ you should prefix your tags names with the name of your module to
+ ensure uniqueness and thus avoid clashes with other modules.
+
+ =item opmask_add (OPSET)
+
+ Adds the supplied opset to the current opmask. Note that there is
+ currently I<no> mechanism for unmasking ops once they have been masked.
+ This is intentional.
+
+ =item opmask
+
+ Returns an opset corresponding to the current opmask.
+
+ =item opdesc (OP, ...)
+
+ This takes a list of operator names and returns the corresponding list
+ of operator descriptions.
+
+ =item opdump (PAT)
+
+ Dumps to STDOUT a two column list of op names and op descriptions.
+ If an optional pattern is given then only lines which match the
+ (case insensitive) pattern will be output.
+
+ It's designed to be used as a handy command line utility:
+
+ perl -MOpcode=opdump -e opdump
+ perl -MOpcode=opdump -e 'opdump Eval'
+
+ =back
+
+ =head1 Manipulating Opsets
+
+ Opsets may be manipulated using the perl bit vector operators & (and), | (or),
+ ^ (xor) and ~ (negate/invert).
+
+ However you should never rely on the numerical position of any opcode
+ within the opset. In other words both sides of a bit vector operator
+ should be opsets returned from Opcode functions.
+
+ Also, since the number of opcodes in your current version of perl might
+ not be an exact multiple of eight, there may be unused bits in the last
+ byte of an upset. This should not cause any problems (Opcode functions
+ ignore those extra bits) but it does mean that using the ~ operator
+ will typically not produce the same 'physical' opset 'string' as the
+ invert_opset function.
+
+
+ =head1 TO DO (maybe)
+
+ $bool = opset_eq($opset1, $opset2) true if opsets are logically eqiv
+
+ $yes = opset_can($opset, @ops) true if $opset has all @ops set
+
+ @diff = opset_diff($opset1, $opset2) => ('foo', '!bar', ...)
+
+ =cut
+
+ # the =cut above is used by _init_optags() to get here quickly
+
+ =head1 Predefined Opcode Tags
+
+ =over 5
+
+ =item :base_core
+
+ null stub scalar pushmark wantarray const defined undef
+
+ rv2sv sassign
+
+ rv2av aassign aelem aelemfast aslice av2arylen
+
+ rv2hv helem hslice each values keys exists delete
+
+ preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec
+ int hex oct abs pow multiply i_multiply divide i_divide
+ modulo i_modulo add i_add subtract i_subtract
+
+ left_shift right_shift bit_and bit_xor bit_or negate i_negate
+ not complement
+
+ lt i_lt gt i_gt le i_le ge i_ge eq i_eq ne i_ne ncmp i_ncmp
+ slt sgt sle sge seq sne scmp
+
+ substr vec stringify study pos length index rindex ord chr
+
+ ucfirst lcfirst uc lc quotemeta trans chop schop chomp schomp
+
+ match split
+
+ list lslice splice push pop shift unshift reverse
+
+ cond_expr flip flop andassign orassign and or xor
+
+ warn die lineseq nextstate unstack scope enter leave
+
+ rv2cv anoncode prototype
+
+ entersub leavesub return method -- XXX loops via recursion?
+
+ leaveeval -- needed for Safe to operate, is safe without entereval
+
+ =item :base_mem
+
+ These memory related ops are not included in :base_core because they
+ can easily be used to implement a resource attack (e.g., consume all
+ available memory).
+
+ concat repeat join range
+
+ anonlist anonhash
+
+ Note that despite the existance of this optag a memory resource attack
+ may still be possible using only :base_core ops.
+
+ Disabling these ops is a I<very> heavy handed way to attempt to prevent
+ a memory resource attack. It's probable that a specific memory limit
+ mechanism will be added to perl in the near future.
+
+ =item :base_loop
+
+ These loop ops are not included in :base_core because they can easily be
+ used to implement a resource attack (e.g., consume all available CPU time).
+
+ grepstart grepwhile
+ mapstart mapwhile
+ enteriter iter
+ enterloop leaveloop
+ last next redo
+ goto
+
+ =item :base_io
+
+ These ops enable I<filehandle> (rather than filename) based input and
+ output. These are safe on the assumption that only pre-existing
+ filehandles are available for use. To create new filehandles other ops
+ such as open would need to be enabled.
+
+ readline rcatline getc read
+
+ formline enterwrite leavewrite
+
+ print sysread syswrite send recv eof tell seek
+
+ readdir telldir seekdir rewinddir
+
+ =item :base_orig
+
+ These are a hotchpotch of opcodes still waiting to be considered
+
+ gvsv gv gelem
+
+ padsv padav padhv padany
+
+ rv2gv refgen srefgen ref
+
+ bless -- could be used to change ownership of objects (reblessing)
+
+ glob
+
+ pushre regcmaybe regcomp subst substcont
+
+ sprintf prtf -- can core dump
+
+ crypt
+
+ tie untie
+
+ dbmopen dbmclose
+ sselect select
+ pipe_op sockpair
+
+ getppid getpgrp setpgrp getpriority setpriority localtime gmtime
+
+ entertry leavetry -- can be used to 'hide' fatal errors
+
+ =item :base_math
+
+ These ops are not included in :base_core because of the risk of them being
+ used to generate floating point exceptions (which would have to be caught
+ using a $SIG{FPE} handler).
+
+ atan2 sin cos exp log sqrt
+
+ These ops are not included in :base_core because they have an effect
+ beyond the scope of the compartment.
+
+ rand srand
+
+ =item :default
+
+ A handy tag name for a I<reasonable> default set of ops. (The current ops
+ allowed are unstable while development continues. It will change.)
+
+ :base_core :base_mem :base_loop :base_io :base_orig
+
+ If safety matters to you (and why else would you be using the Opcode module?)
+ then you should not rely on the definition of this, or indeed any other, optag!
+
+
+ =item :filesys_read
+
+ stat lstat readlink
+
+ ftatime ftblk ftchr ftctime ftdir fteexec fteowned fteread
+ ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned
+ ftrread ftsgid ftsize ftsock ftsuid fttty ftzero ftrwrite ftsvtx
+
+ fttext ftbinary
+
+ fileno
+
+ =item :sys_db
+
+ ghbyname ghbyaddr ghostent shostent ehostent -- hosts
+ gnbyname gnbyaddr gnetent snetent enetent -- networks
+ gpbyname gpbynumber gprotoent sprotoent eprotoent -- protocols
+ gsbyname gsbyport gservent sservent eservent -- services
+
+ gpwnam gpwuid gpwent spwent epwent getlogin -- users
+ ggrnam ggrgid ggrent sgrent egrent -- groups
+
+ =item :browse
+
+ A handy tag name for a I<reasonable> default set of ops beyond the
+ :default optag. Like :default (and indeed all the other optags) its
+ current definition is unstable while development continues. It will change.
+
+ The :browse tag represents the next step beyond :default. It it a
+ superset of the :default ops and adds :filesys_read the :sys_db.
+ The intent being that scripts can access more (possibly sensitive)
+ information about your system but not be able to change it.
+
+ :default :filesys_read :sys_db
+
+ =item :filesys_open
+
+ sysopen open close
+ umask binmode
+
+ open_dir closedir -- other dir ops are in :base_io
+
+ =item :filesys_write
+
+ link unlink rename symlink truncate
+
+ mkdir rmdir
+
+ utime chmod chown
+
+ fcntl -- not strictly filesys related, but possibly as dangerous?
+
+ =item :subprocess
+
+ backtick system
+
+ fork
+
+ wait waitpid
+
+ =item :ownprocess
+
+ exec exit kill
+
+ time tms -- could be used for timing attacks (paranoid?)
+
+ =item :others
+
+ This tag holds groups of assorted specialist opcodes that don't warrant
+ having optags defined for them.
+
+ SystemV Interprocess Communications:
+
+ msgctl msgget msgrcv msgsnd
+
+ semctl semget semop
+
+ shmctl shmget shmread shmwrite
+
+ =item :still_to_be_decided
+
+ chdir
+ flock ioctl
+
+ socket getpeername ssockopt
+ bind connect listen accept shutdown gsockopt getsockname
+
+ sleep alarm -- changes global timer state and signal handling
+ sort -- assorted problems including core dumps
+ tied -- can be used to access object implementing a tie
+ pack unpack -- can be used to create/use memory pointers
+
+ entereval -- can be used to hide code from initial compile
+ require dofile
+
+ caller -- get info about calling environment and args
+
+ reset
+
+ dbstate -- perl -d version of nextstate(ment) opcode
+
+ =item :dangerous
+
+ This tag is simply a bucket for opcodes that are unlikely to be used via
+ a tag name but need to be tagged for completness and documentation.
+
+ syscall dump chroot
+
+
+ =back
+
+ =head1 SEE ALSO
+
+ ops(3) -- perl pragma interface to Opcode module.
+
+ Safe(3) -- Opcode and namespace limited execution compartments
+
+ =head1 AUTHORS
+
+ Originally designed and implemented by Malcolm Beattie,
+ mbeattie@sable.ox.ac.uk as part of Safe version 1.
+
+ Split out from Safe module version 1, named opcode tags and other
+ changes added by Tim Bunce <Tim.Bunce@ig.co.uk>.
+
+ =cut
+
#~ Add Opcode extension
diff -Pcr perl5_003/ext/Opcode/Opcode.xs perl5_003_01/ext/Opcode/Opcode.xs
*** perl5_003/ext/Opcode/Opcode.xs Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/Opcode/Opcode.xs Tue Jun 18 15:12:05 1996
***************
*** 0 ****
--- 1,471 ----
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+
+ /* maxo shouldn't differ from MAXO but leave room anyway (see BOOT:) */
+ #define OP_MASK_BUF_SIZE (MAXO + 100)
+
+ static HV *op_named_bits; /* cache shared for whole process */
+ static SV *opset_all; /* mask with all bits set */
+ static IV opset_len; /* length of opmasks in bytes */
+ static int opcode_debug = 0;
+
+ static SV *new_opset _((SV *old_opset));
+ static int verify_opset _((SV *opset, int fatal));
+ static void set_opset_bits _((char *bitmap, SV *bitspec, int on, char *opname));
+ static void put_op_bitspec _((char *optag, STRLEN len, SV *opset));
+ static SV *get_op_bitspec _((char *opname, STRLEN len, int fatal));
+
+
+ /* Initialise our private op_named_bits HV.
+ * It is first loaded with the name and number of each perl operator.
+ * Then the builtin tags :none and :all are added.
+ * Opcode.pm loads the standard optags from __DATA__
+ */
+
+ static void
+ op_names_init()
+ {
+ int i;
+ STRLEN len;
+ char *opname;
+ char *bitmap;
+
+ op_named_bits = newHV();
+ for(i=0; i < maxo; ++i) {
+ hv_store(op_named_bits, op_name[i],strlen(op_name[i]),
+ Sv=newSViv(i), 0);
+ SvREADONLY_on(Sv);
+ }
+
+ put_op_bitspec(":none",0, sv_2mortal(new_opset(Nullsv)));
+
+ opset_all = new_opset(Nullsv);
+ bitmap = SvPV(opset_all, len);
+ i = len-1; /* deal with last byte specially, see below */
+ while(i-- > 0)
+ bitmap[i] = 0xFF;
+ /* Take care to set the right number of bits in the last byte */
+ bitmap[len-1] = ~(~0 << (maxo & 0x07));
+ put_op_bitspec(":all",0, opset_all); /* don't mortalise */
+ }
+
+
+ /* Store a new tag definition. Always a mask.
+ * The tag must not already be defined.
+ * SV *mask is copied not referenced.
+ */
+
+ static void
+ put_op_bitspec(optag, len, mask)
+ char *optag;
+ STRLEN len;
+ SV *mask;
+ {
+ SV **svp;
+ verify_opset(mask,1);
+ if (!len)
+ len = strlen(optag);
+ svp = hv_fetch(op_named_bits, optag, len, 1);
+ if (SvOK(*svp))
+ croak("Opcode tag \"%s\" already defined", optag);
+ sv_setsv(*svp, mask);
+ SvREADONLY_on(*svp);
+ }
+
+
+
+ /* Fetch a 'bits' entry for an opname or optag (IV/PV).
+ * Note that we return the actual entry for speed.
+ * Always sv_mortalcopy() if returing it to user code.
+ */
+
+ static SV *
+ get_op_bitspec(opname, len, fatal)
+ char *opname;
+ STRLEN len;
+ int fatal;
+ {
+ SV **svp;
+ if (!len)
+ len = strlen(opname);
+ svp = hv_fetch(op_named_bits, opname, len, 0);
+ if (!svp || !SvOK(*svp)) {
+ if (!fatal)
+ return Nullsv;
+ if (*opname == ':')
+ croak("Unknown operator tag \"%s\"", opname);
+ if (*opname == '!') /* XXX here later, or elsewhere? */
+ croak("Can't negate operators here (\"%s\")", opname);
+ if (isALPHA(*opname))
+ croak("Unknown operator name \"%s\"", opname);
+ croak("Unknown operator prefix \"%s\"", opname);
+ }
+ return *svp;
+ }
+
+
+
+ static SV *
+ new_opset(old_opset)
+ SV *old_opset;
+ {
+ SV *opset;
+ if (old_opset) {
+ verify_opset(old_opset,1);
+ opset = newSVsv(old_opset);
+ }
+ else {
+ opset = newSV(opset_len);
+ Zero(SvPVX(opset), opset_len, char);
+ SvCUR_set(opset, opset_len);
+ (void)SvPOK_only(opset);
+ }
+ /* not mortalised here */
+ return opset;
+ }
+
+
+ static int
+ verify_opset(opset, fatal)
+ SV *opset;
+ int fatal;
+ {
+ char *err = Nullch;
+ if (!SvOK(opset)) err = "undefined";
+ else if (!SvPOK(opset)) err = "wrong type";
+ else if (SvCUR(opset) != opset_len) err = "wrong size";
+ if (err && fatal) {
+ croak("Invalid opset: %s", err);
+ }
+ return !err;
+ }
+
+
+ static void
+ set_opset_bits(bitmap, bitspec, on, opname)
+ char *bitmap;
+ SV *bitspec;
+ int on;
+ char *opname;
+ {
+ if (SvIOK(bitspec)) {
+ int myopcode = SvIV(bitspec);
+ int offset = myopcode >> 3;
+ int bit = myopcode & 0x07;
+ if (myopcode >= maxo || myopcode < 0)
+ croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode);
+ if (opcode_debug >= 2)
+ warn("set_opset_bits bit %2d (off=%d, bit=%d) %s on\n",
+ myopcode, offset, bit, opname, (on)?"on":"off");
+ if (on)
+ bitmap[offset] |= 1 << bit;
+ else
+ bitmap[offset] &= ~(1 << bit);
+ }
+ else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
+
+ STRLEN len;
+ char *specbits = SvPV(bitspec, len);
+ if (opcode_debug >= 2)
+ warn("set_opset_bits opset %s %s\n", opname, (on)?"on":"off");
+ if (on)
+ while(len-- > 0) bitmap[len] |= specbits[len];
+ else
+ while(len-- > 0) bitmap[len] &= ~specbits[len];
+ }
+ else
+ croak("panic: invalid bitspec for \"%s\" (type %d)",
+ opname, SvTYPE(bitspec));
+ }
+
+
+ static void
+ opmask_add(opset) /* THE ONLY FUNCTION TO EDIT op_mask ITSELF */
+ SV *opset;
+ {
+ int i,j;
+ char *bitmask;
+ STRLEN len;
+ int myopcode = 0;
+
+ verify_opset(opset,1); /* croaks on bad opset */
+
+ if (!op_mask) /* caller must ensure op_mask exists */
+ croak("Can't add to uninitialised op_mask");
+
+ /* OPCODES ALREADY MASKED ARE NEVER UNMASKED. See opmask_addlocal() */
+
+ bitmask = SvPV(opset, len);
+ for (i=0; i < opset_len; i++) {
+ U16 bits = bitmask[i];
+ if (!bits) { /* optimise for sparse masks */
+ myopcode += 8;
+ continue;
+ }
+ for (j=0; j < 8 && myopcode < maxo; )
+ op_mask[myopcode++] |= bits & (1 << j++);
+ }
+ }
+
+ static void
+ opmask_addlocal(opset, op_mask_buf) /* Localise op_mask then opmask_add() */
+ SV *opset;
+ char *op_mask_buf;
+ {
+ char *orig_op_mask = op_mask;
+ SAVEPPTR(op_mask);
+ if (opcode_debug >= 2)
+ SAVEDESTRUCTOR((void(*)_((void*)))warn,"op_mask restored");
+ op_mask = &op_mask_buf[0];
+ if (orig_op_mask)
+ Copy(orig_op_mask, op_mask, maxo, char);
+ else
+ Zero(op_mask, maxo, char);
+ opmask_add(opset);
+ }
+
+
+
+ MODULE = Opcode PACKAGE = Opcode
+
+ PROTOTYPES: ENABLE
+
+ BOOT:
+ assert(maxo < OP_MASK_BUF_SIZE);
+ opset_len = (maxo / 8) + 1;
+ if (opcode_debug >= 1)
+ warn("opset_len %d\n", opset_len);
+ op_names_init();
+
+
+ void
+ _safe_call_sv(package, mask, codesv)
+ char * package
+ SV * mask
+ SV * codesv
+ PPCODE:
+ char op_mask_buf[OP_MASK_BUF_SIZE];
+ GV *gv;
+
+ ENTER;
+
+ opmask_addlocal(mask, op_mask_buf);
+
+ save_aptr(&endav);
+ endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */
+
+ save_hptr(&defstash); /* save current default stack */
+ /* the assignment to global defstash changes our sense of 'main' */
+ defstash = gv_stashpv(package, GV_ADDWARN); /* should exist already */
+
+ /* defstash must itself contain a main:: so we'll add that now */
+ /* take care with the ref counts (was cause of long standing bug) */
+ /* XXX I'm still not sure if this is right, GV_ADDWARN should warn! */
+ gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV);
+ sv_free((SV*)GvHV(gv));
+ GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
+
+ PUSHMARK(sp);
+ perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */
+ SPAGAIN; /* for the PUTBACK added by xsubpp */
+ LEAVE;
+
+
+ int
+ verify_opset(opset, fatal = 0)
+ SV *opset
+ int fatal
+
+
+ void
+ invert_opset(opset)
+ SV *opset
+ CODE:
+ {
+ char *bitmap;
+ STRLEN len = opset_len;
+ opset = new_opset(opset); /* verify and clone opset */
+ bitmap = SvPVX(opset);
+ while(len-- > 0)
+ bitmap[len] = ~bitmap[len];
+ /* take care of extra bits beyond maxo in last byte */
+ bitmap[opset_len-1] &= ~(0xFF << (maxo & 0x0F));
+ }
+ ST(0) = opset;
+
+
+ void
+ opset_to_ops(opset, desc = 0)
+ SV *opset
+ int desc
+ PPCODE:
+ {
+ STRLEN len;
+ int i, j, myopcode;
+ char *bitmap = SvPV(opset, len);
+ char **names = (desc) ? op_desc : op_name;
+ verify_opset(opset,1);
+ for (myopcode=0, i=0; i < opset_len; i++) {
+ U16 bits = bitmap[i];
+ for (j=0; j < 8 && myopcode < maxo; j++, myopcode++) {
+ if ( bits & (1 << j) )
+ XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0)));
+ }
+ }
+ }
+
+
+ void
+ opset(...)
+ CODE:
+ int i, j;
+ SV *bitspec, *opset;
+ char *bitmap;
+ STRLEN len, on;
+ opset = new_opset(Nullsv);
+ bitmap = SvPVX(opset);
+ for (i = 0; i < items; i++) {
+ char *opname;
+ on = 1;
+ if (verify_opset(ST(i),0)) {
+ opname = "(opset)";
+ bitspec = ST(i);
+ }
+ else {
+ opname = SvPV(ST(i), len);
+ if (*opname == '!') { on=0; ++opname;--len; }
+ bitspec = get_op_bitspec(opname, len, 1);
+ }
+ set_opset_bits(bitmap, bitspec, on, opname);
+ }
+ ST(0) = opset;
+
+
+ #define PERMITING (ix == 0 || ix == 1)
+ #define ONLY_THESE (ix == 0 || ix == 2)
+
+ void
+ permit_only(safe, ...)
+ SV *safe
+ ALIAS:
+ permit = 1
+ deny_only = 2
+ deny = 3
+ CODE:
+ int i, on;
+ SV *bitspec, *mask;
+ char *bitmap, *opname;
+ STRLEN len;
+
+ if (!SvROK(safe) || !SvOBJECT(SvRV(safe)) || SvTYPE(SvRV(safe))!=SVt_PVHV)
+ croak("Not a Safe object");
+ mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1);
+ if (ONLY_THESE) /* *_only = new mask, else edit current */
+ sv_setsv(mask, new_opset(PERMITING ? opset_all : Nullsv));
+ else verify_opset(mask,1); /* croaks */
+ bitmap = SvPVX(mask);
+ for (i = 1; i < items; i++) {
+ on = PERMITING ? 0 : 1; /* deny = mask bit on */
+ if (verify_opset(ST(i),0)) { /* it's a valid mask */
+ opname = "(opset)";
+ bitspec = ST(i);
+ }
+ else { /* it's an opname/optag */
+ opname = SvPV(ST(i), len);
+ /* invert if op has ! prefix (only one allowed) */
+ if (*opname == '!') { on = !on; ++opname; --len; }
+ bitspec = get_op_bitspec(opname, len, 1); /* croaks */
+ }
+ set_opset_bits(bitmap, bitspec, on, opname);
+ }
+ ST(0) = &sv_yes;
+
+
+
+ void
+ opdesc(...)
+ PPCODE:
+ int i, myopcode;
+ STRLEN len;
+ SV **args;
+ /* copy args to a scratch area since we may push output values onto */
+ /* the stack faster than we read values off it if masks are used. */
+ args = (SV**)SvPVX(sv_2mortal(newSVpv((char*)&ST(0), items*sizeof(SV*))));
+ for (i = 0; i < items; i++) {
+ char *opname = SvPV(args[i], len);
+ SV *bitspec = get_op_bitspec(opname, len, 1);
+ if (SvIOK(bitspec)) {
+ myopcode = SvIV(bitspec);
+ if (myopcode < 0 || myopcode >= maxo)
+ croak("panic: opcode %d (%s) out of range",myopcode,opname);
+ XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
+ }
+ else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
+ int b, j;
+ char *bitmap = SvPV(bitspec,na);
+ myopcode = 0;
+ for (b=0; b < opset_len; b++) {
+ U16 bits = bitmap[b];
+ for (j=0; j < 8 && myopcode < maxo; j++, myopcode++)
+ if (bits & (1 << j))
+ XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
+ }
+ }
+ else
+ croak("panic: invalid bitspec for \"%s\" (type %d)",
+ opname, SvTYPE(bitspec));
+ }
+
+
+ void
+ define_optag(optagsv, mask)
+ SV *optagsv
+ SV *mask
+ CODE:
+ STRLEN len;
+ char *optag = SvPV(optagsv, len);
+ put_op_bitspec(optag, len, mask); /* croaks */
+ ST(0) = &sv_yes;
+
+
+ void
+ empty_opset()
+ CODE:
+ ST(0) = sv_2mortal(new_opset(Nullsv));
+
+ void
+ full_opset()
+ CODE:
+ ST(0) = sv_2mortal(new_opset(opset_all));
+
+ void
+ opmask_add(opset)
+ SV *opset
+ PREINIT:
+ if (!op_mask)
+ Newz(0, op_mask, maxo, char);
+
+ void
+ opcodes()
+ PPCODE:
+ if (GIMME == G_ARRAY) {
+ croak("opcodes in list context not yet implemented"); /* XXX */
+ }
+ else {
+ XPUSHs(sv_2mortal(newSViv(maxo)));
+ }
+
+ void
+ opmask()
+ CODE:
+ ST(0) = sv_2mortal(new_opset(Nullsv));
+ if (op_mask) {
+ char *bitmap = SvPVX(ST(0));
+ int myopcode;
+ for(myopcode=0; myopcode < maxo; ++myopcode) {
+ if (op_mask[myopcode])
+ bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07);
+ }
+ }
+
#~ New Opcode extension subsumes Safe
diff -Pcr perl5_003/ext/Opcode/Safe.pm perl5_003_01/ext/Opcode/Safe.pm
*** perl5_003/ext/Opcode/Safe.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/Opcode/Safe.pm Tue Jun 18 15:18:18 1996
***************
*** 0 ****
--- 1,555 ----
+ package Safe;
+
+ require 5.002;
+
+ use strict;
+ use Carp;
+
+ use vars qw($VERSION);
+
+ $VERSION = "2.06";
+
+ use Opcode 1.01, qw(
+ opset opset_to_ops opmask_add
+ empty_opset full_opset invert_opset verify_opset
+ opdesc opcodes opmask define_optag opset_to_hex
+ );
+
+ *ops_to_opset = \&opset; # Temporary alias for old Penguins
+
+
+ my $default_root = 0;
+ my $default_share = ['*_']; #, '*main::'];
+
+ sub new {
+ my($class, $root, $mask) = @_;
+ my $obj = {};
+ bless $obj, $class;
+
+ if (defined($root)) {
+ croak "Can't use \"$root\" as root name"
+ if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
+ $obj->{Root} = $root;
+ $obj->{Erase} = 0;
+ }
+ else {
+ $obj->{Root} = "Safe::Root".$default_root++;
+ $obj->{Erase} = 1;
+ }
+
+ # use permit/deny methods instead till interface issues resolved
+ # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
+ croak "Mask parameter to new no longer supported" if defined $mask;
+ $obj->permit_only(':default');
+
+ # We must share $_ and @_ with the compartment or else ops such
+ # as split, length and so on won't default to $_ properly, nor
+ # will passing argument to subroutines work (via @_). In fact,
+ # for reasons I don't completely understand, we need to share
+ # the whole glob *_ rather than $_ and @_ separately, otherwise
+ # @_ in non default packages within the compartment don't work.
+ $obj->share_from('main', $default_share);
+ return $obj;
+ }
+
+ sub DESTROY {
+ my $obj = shift;
+ $obj->erase if $obj->{Erase};
+ }
+
+ sub erase {
+ my $obj= shift;
+ my $pkg = $obj->root();
+ my ($stem, $leaf);
+
+ no strict 'refs';
+ $pkg = "main::$pkg\::"; # expand to full symbol table name
+ ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+
+ # The 'my $foo' is needed! Without it you get an
+ # 'Attempt to free unreferenced scalar' warning!
+ my $stem_symtab = *{$stem}{HASH};
+
+ #warn "erase($pkg) stem=$stem, leaf=$leaf";
+ #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
+ # ", join(', ', %$stem_symtab),"\n";
+
+ delete $stem_symtab->{$leaf};
+
+ # my $leaf_glob = $stem_symtab->{$leaf};
+ # my $leaf_symtab = *{$leaf_glob}{HASH};
+ # warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
+ # %$leaf_symtab = ();
+ #delete $leaf_symtab->{'__ANON__'};
+ #delete $leaf_symtab->{'foo'};
+ #delete $leaf_symtab->{'main::'};
+ # my $foo = undef ${"$stem\::"}{"$leaf\::"};
+
+ $obj->share_from('main', $default_share);
+ 1;
+ }
+
+
+ sub reinit {
+ my $obj= shift;
+ $obj->erase;
+ $obj->share_redo;
+ }
+
+ sub root {
+ my $obj = shift;
+ croak("Safe root method now read-only") if @_;
+ return $obj->{Root};
+ }
+
+
+ sub mask {
+ my $obj = shift;
+ return $obj->{Mask} unless @_;
+ $obj->deny_only(@_);
+ }
+
+ # v1 compatibility methods
+ sub trap { shift->deny(@_) }
+ sub untrap { shift->permit(@_) }
+
+ sub deny {
+ my $obj = shift;
+ $obj->{Mask} |= opset(@_);
+ }
+ sub deny_only {
+ my $obj = shift;
+ $obj->{Mask} = opset(@_);
+ }
+
+ sub permit {
+ my $obj = shift;
+ # XXX needs testing
+ $obj->{Mask} &= invert_opset opset(@_);
+ }
+ sub permit_only {
+ my $obj = shift;
+ $obj->{Mask} = invert_opset opset(@_);
+ }
+
+
+ sub dump_mask {
+ my $obj = shift;
+ print opset_to_hex($obj->{Mask}),"\n";
+ }
+
+
+
+ sub share {
+ my($obj, @vars) = @_;
+ $obj->share_from(scalar(caller), \@vars);
+ }
+
+ sub share_from {
+ my $obj = shift;
+ my $pkg = shift;
+ my $vars = shift;
+ my $no_record = shift || 0;
+ my $root = $obj->root();
+ my ($var, $arg);
+ croak("vars not an array ref") unless ref $vars eq 'ARRAY';
+ no strict 'refs';
+ # Check that 'from' package actually exists
+ croak("Package \"$pkg\" does not exist")
+ unless keys %{"$pkg\::"};
+ foreach $arg (@$vars) {
+ # catch some $safe->share($var) errors:
+ croak("'$arg' not a valid symbol table name")
+ unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/
+ or $arg =~ /^\$\W$/;
+ ($var = $arg) =~ s/^(\W)//; # get type char
+ # warn "share_from $pkg $1 $var";
+ *{$root."::$var"} = ($1 eq '$') ? \${$pkg."::$var"}
+ : ($1 eq '@') ? \@{$pkg."::$var"}
+ : ($1 eq '%') ? \%{$pkg."::$var"}
+ : ($1 eq '*') ? *{$pkg."::$var"}
+ : ($1 eq '&') ? \&{$pkg."::$var"}
+ : (!$1) ? \&{$pkg."::$var"}
+ : croak(qq(Can't share "$1$var" of unknown type));
+ }
+ $obj->share_record($pkg, $vars) unless $no_record or !$vars;
+ }
+
+ sub share_record {
+ my $obj = shift;
+ my $pkg = shift;
+ my $vars = shift;
+ my $shares = \%{$obj->{Shares} ||= {}};
+ # Record shares using keys of $obj->{Shares}. See reinit.
+ @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
+ }
+ sub share_redo {
+ my $obj = shift;
+ my $shares = \%{$obj->{Shares} ||= {}};
+ my($var, $pkg);
+ while(($var, $pkg) = each %$shares) {
+ # warn "share_redo $pkg\:: $var";
+ $obj->share_from($pkg, [ $var ], 1);
+ }
+ }
+ sub share_forget {
+ delete shift->{Shares};
+ }
+
+ sub varglob {
+ my ($obj, $var) = @_;
+ no strict 'refs';
+ return *{$obj->root()."::$var"};
+ }
+
+
+ sub reval {
+ my ($obj, $expr, $strict) = @_;
+ my $root = $obj->{Root};
+
+ # Create anon sub ref in root of compartment.
+ # Uses a closure (on $expr) to pass in the code to be executed.
+ # (eval on one line to keep line numbers as expected by caller)
+ my $evalcode = sprintf('package %s; sub { eval $expr; }', $root);
+ my $evalsub;
+
+ if ($strict) { use strict; $evalsub = eval $evalcode; }
+ else { no strict; $evalsub = eval $evalcode; }
+
+ return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+ }
+
+ sub rdo {
+ my ($obj, $file) = @_;
+ my $root = $obj->{Root};
+
+ my $evalsub = eval
+ sprintf('package %s; sub { do $file }', $root);
+ return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+ }
+
+
+ 1;
+
+ __DATA__
+
+ =head1 NAME
+
+ Safe - Compile and execute code in restricted compartments
+
+ =head1 SYNOPSIS
+
+ use Safe;
+
+ $compartment = new Safe;
+
+ $compartment->permit(qw(time sort :browse));
+
+ $result = $compartment->reval($unsafe_code);
+
+ =head1 DESCRIPTION
+
+ The Safe extension module allows the creation of compartments
+ in which perl code can be evaluated. Each compartment has
+
+ =over 8
+
+ =item a new namespace
+
+ The "root" of the namespace (i.e. "main::") is changed to a
+ different package and code evaluated in the compartment cannot
+ refer to variables outside this namespace, even with run-time
+ glob lookups and other tricks.
+
+ Code which is compiled outside the compartment can choose to place
+ variables into (or I<share> variables with) the compartment's namespace
+ and only that data will be visible to code evaluated in the
+ compartment.
+
+ By default, the only variables shared with compartments are the
+ "underscore" variables $_ and @_ (and, technically, the less frequently
+ used %_, the _ filehandle and so on). This is because otherwise perl
+ operators which default to $_ will not work and neither will the
+ assignment of arguments to @_ on subroutine entry.
+
+ =item an operator mask
+
+ Each compartment has an associated "operator mask". Recall that
+ perl code is compiled into an internal format before execution.
+ Evaluating perl code (e.g. via "eval" or "do 'file'") causes
+ the code to be compiled into an internal format and then,
+ provided there was no error in the compilation, executed.
+ Code evaulated in a compartment compiles subject to the
+ compartment's operator mask. Attempting to evaulate code in a
+ compartment which contains a masked operator will cause the
+ compilation to fail with an error. The code will not be executed.
+
+ The default operator mask for a newly created compartment is
+ the ':default' optag.
+
+ It is important that you read the L<Opcode(3)> module documentation
+ for more information. Especially for details definitions of opnames,
+ optags and opsets.
+
+ Since it is only at the compilation stage that the operator mask
+ applies, controlled access to potentially unsafe operations can
+ be achieved by having a handle to a wrapper subroutine (written
+ outside the compartment) placed into the compartment. For example,
+
+ $cpt = new Safe;
+ sub wrapper {
+ # vet arguments and perform potentially unsafe operations
+ }
+ $cpt->share('&wrapper');
+
+ =back
+
+
+ =head1 WARNING
+
+ The authors make B<no warranty>, implied or otherwise, about the
+ suitability of this software for safety or security purposes.
+
+ The authors shall not in any case be liable for special, incidental,
+ consequential, indirect or other similar damages arising from the use
+ of this software.
+
+ Your mileage will vary. If in any doubt B<do not use it>.
+
+
+ =head2 RECENT CHANGES
+
+ The interface to the Safe module has changed quite dramatically since
+ version 1 (as supplied with Perl5.002). Study these pages carefully if
+ you have code written to use Safe version 1 because you will need to
+ makes changes.
+
+
+ =head2 Methods in class Safe
+
+ To create a new compartment, use
+
+ $cpt = new Safe;
+
+ Optional argument is (NAMESPACE), where NAMESPACE is the root namespace
+ to use for the compartment (defaults to "Safe::Root0", incremented for
+ each new compartment).
+
+ Note that version 1.00 of the Safe module supported a second optional
+ parameter, MASK. That functionality has been withdrawn pending deeper
+ consideration. Use the permit and deny methods described below.
+
+ The following methods can then be used on the compartment
+ object returned by the above constructor. The object argument
+ is implicit in each case.
+
+
+ =over 8
+
+ =item permit (OP, ...)
+
+ Permit the listed operators to be used when compiling code in the
+ compartment (in I<addition> to any operators already permitted).
+
+ =item permit_only (OP, ...)
+
+ Permit I<only> the listed operators to be used when compiling code in
+ the compartment (I<no> other operators are permitted).
+
+ =item deny (OP, ...)
+
+ Deny the listed operators from being used when compiling code in the
+ compartment (other operators may still be permitted).
+
+ =item deny_only (OP, ...)
+
+ Deny I<only> the listed operators from being used when compiling code
+ in the compartment (I<all> other operators will be permitted).
+
+ =item trap (OP, ...)
+
+ =item untrap (OP, ...)
+
+ The trap and untrap methods are synonyms for deny and permit
+ respectfully.
+
+ =item share (NAME, ...)
+
+ This shares the variable(s) in the argument list with the compartment.
+ This is almost identical to exporting variables using the L<Exporter(3)>
+ module.
+
+ Each NAME must be the B<name> of a variable, typically with the leading
+ type identifier included. A bareword is treated as a function name.
+
+ Examples of legal names are '$foo' for a scalar, '@foo' for an
+ array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
+ for a glob (i.e. all symbol table entries associated with "foo",
+ including scalar, array, hash, sub and filehandle).
+
+ Each NAME is assumed to be in the calling package. See share_from
+ for an alternative method (which share uses).
+
+ =item share_from (PACKAGE, ARRAYREF)
+
+ This method is similar to share() but allows you to explicitly name the
+ package that symbols should be shared from. The symbol names (including
+ type characters) are supplied as an array reference.
+
+ $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
+
+
+ =item varglob (VARNAME)
+
+ This returns a glob reference for the symbol table entry of VARNAME in
+ the package of the compartment. VARNAME must be the B<name> of a
+ variable without any leading type marker. For example,
+
+ $cpt = new Safe 'Root';
+ $Root::foo = "Hello world";
+ # Equivalent version which doesn't need to know $cpt's package name:
+ ${$cpt->varglob('foo')} = "Hello world";
+
+
+ =item reval (STRING)
+
+ This evaluates STRING as perl code inside the compartment.
+
+ The code can only see the compartment's namespace (as returned by the
+ B<root> method). The compartment's root package appears to be the
+ C<main::> package to the code inside the compartment.
+
+ Any attempt by the code in STRING to use an operator which is not permitted
+ by the compartment will cause an error (at run-time of the main program
+ but at compile-time for the code in STRING). The error is of the form
+ "%s trapped by operation mask operation...".
+
+ If an operation is trapped in this way, then the code in STRING will
+ not be executed. If such a trapped operation occurs or any other
+ compile-time or return error, then $@ is set to the error message, just
+ as with an eval().
+
+ If there is no error, then the method returns the value of the last
+ expression evaluated, or a return statement may be used, just as with
+ subroutines and B<eval()>. The context (list or scalar) is determined
+ by the caller as usual.
+
+ This behaviour differs from the beta distribution of the Safe extension
+ where earlier versions of perl made it hard to mimic the return
+ behaviour of the eval() command and the context was always scalar.
+
+ Some points to note:
+
+ If the entereval op is permitted then the code can use eval "..." to
+ 'hide' code which might use denied ops. This is not a major problem
+ since when the code tries to execute the eval it will fail because the
+ opmask is still in effect. However this technique would allow clever,
+ and possibly harmful, code to 'probe' the boundaries of what is
+ possible.
+
+ Any string eval which is executed by code executing in a compartment,
+ or by code called from code executing in a compartment, will be eval'd
+ in the namespace of the compartment. This is potentially a serious
+ problem.
+
+ Consider a function foo() in package pkg compiled outside a compartment
+ but shared with it. Assume the compartment has a root package called
+ 'Root'. If foo() contains an eval statement like eval '$baz = 1' then,
+ normally, $pkg::foo will be set to 1. If foo() is called from the
+ compartment (by whatever means) then instead of setting $pkg::foo, the
+ eval will actually set $Root::pkg::foo.
+
+ This can easily be demonstrated by using a module, such as the Socket
+ module, which uses eval "..." as part of an AUTOLOAD function. You can
+ 'use' the module outside the compartment and share an (autoloaded)
+ function with the compartment. If an autoload is triggered by code in
+ the compartment, or by any code anywhere that is called by any means
+ from the compartment, then the eval in the Socket module's AUTOLOAD
+ function happens in the namespace of the compartment. Any variables
+ created or used by the eval'd code are now under the control of
+ the code in the compartment.
+
+ A similar effect applies to I<all> runtime symbol lookups in code
+ called from a compartment but not compiled within it.
+
+
+
+ =item rdo (FILENAME)
+
+ This evaluates the contents of file FILENAME inside the compartment.
+ See above documentation on the B<reval> method for further details.
+
+ =item root (NAMESPACE)
+
+ This method returns the name of the package that is the root of the
+ compartment's namespace.
+
+ Note that this behaviour differs from version 1.00 of the Safe module
+ where the root module could be used to change the namespace. That
+ functionality has been withdrawn pending deeper consideration.
+
+ =item mask (MASK)
+
+ This is a get-or-set method for the compartment's operator mask.
+
+ With no MASK argument present, it returns the current operator mask of
+ the compartment.
+
+ With the MASK argument present, it sets the operator mask for the
+ compartment (equivalent to calling the deny_only method).
+
+ =back
+
+
+ =head2 Some Safety Issues
+
+ This section is currently just an outline of some of the things code in
+ a compartment might do (intentionally or unintentionally) which can
+ have an effect outside the compartment.
+
+ =over 8
+
+ =item Memory
+
+ Consuming all (or nearly all) available memory.
+
+ =item CPU
+
+ Causing infinite loops etc.
+
+ =item Snooping
+
+ Copying private information out of your system. Even something as
+ simple as your user name is of value to others. Much useful information
+ could be gleaned from your environment variables for example.
+
+ =item Signals
+
+ Causing signals (especially SIGFPE and SIGALARM) to affect your process.
+
+ Setting up a signal handler will need to be carefully considered
+ and controlled. What mask is in effect when a signal handler
+ gets called? If a user can get an imported function to get an
+ exception and call the user's signal handler, does that user's
+ restricted mask get re-instated before the handler is called?
+ Does an imported handler get called with its original mask or
+ the user's one?
+
+ =item State Changes
+
+ Ops such as chdir obviously effect the process as a whole and not just
+ the code in the compartment. Ops such as rand and srand have a similar
+ but more subtle effect.
+
+ =back
+
+ =head2 AUTHOR
+
+ Originally designed and implemented by Malcolm Beattie,
+ mbeattie@sable.ox.ac.uk.
+
+ Reworked to use the Opcode module and other changes added by Tim Bunce
+ <Tim.Bunce@ig.co.uk>.
+
+ =cut
+
#~ Add Opcode extension
diff -Pcr perl5_003/ext/Opcode/ops.pm perl5_003_01/ext/Opcode/ops.pm
*** perl5_003/ext/Opcode/ops.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/ext/Opcode/ops.pm Tue Jun 18 15:07:53 1996
***************
*** 0 ****
--- 1,45 ----
+ package ops;
+
+ use Opcode qw(opmask_add opset invert_opset);
+
+ sub import {
+ shift;
+ # Not that unimport is the prefered form since import's don't
+ # accumulate well owing to the 'only ever add opmask' rule.
+ # E.g., perl -Mops=:set1 -Mops=:setb is unlikely to do as expected.
+ opmask_add(invert_opset opset(@_));
+ }
+
+ sub unimport {
+ shift;
+ opmask_add(opset(@_));
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ ops - Perl pragma to restrict unsafe operations when compiling
+
+ =head1 SYNOPSIS
+
+ perl -Mops=:default ... # only allow reasonably safe operations
+
+ perl -M-ops=system ... # disable the 'system' opcode
+
+ =head1 DESCRIPTION
+
+ Since the ops pragma currently has an irreversable global effect, it is
+ only of significant practical use with the C<-M> option on the command line.
+
+ See the L<Opcode> module for information about opcodes, optags, opmasks
+ and important information about safety.
+
+ =head1 SEE ALSO
+
+ Opcode(3), Safe(3), perlrun(3)
+
+ =cut
+
#~ Correct order of arguments in setcc documentation
diff -Pcr perl5_003/ext/POSIX/POSIX.pod perl5_003_01/ext/POSIX/POSIX.pod
*** perl5_003/ext/POSIX/POSIX.pod Mon Jan 29 19:24:16 1996
--- perl5_003_01/ext/POSIX/POSIX.pod Tue Jun 18 20:28:03 1996
***************
*** 1393,1399 ****
Set a value in the c_cc field of a termios object. The c_cc field is an
array so an index must be specified.
! $termios->setcc( 1, &POSIX::VEOF );
=item setcflag
--- 1393,1399 ----
Set a value in the c_cc field of a termios object. The c_cc field is an
array so an index must be specified.
! $termios->setcc( &POSIX::VEOF, 1 );
=item setcflag
#~ Quote string argument in example -- necessary if using strict subs
diff -Pcr perl5_003/ext/SDBM_File/SDBM_File.pm perl5_003_01/ext/SDBM_File/SDBM_File.pm
*** perl5_003/ext/SDBM_File/SDBM_File.pm Wed Feb 14 21:40:28 1996
--- perl5_003_01/ext/SDBM_File/SDBM_File.pm Mon Jul 15 13:35:42 1996
***************
*** 24,30 ****
use SDBM_File;
! tie(%h,SDBM_File,'Op.dbmx', O_RDWR|O_CREAT, 0640);
untie %h;
--- 24,30 ----
use SDBM_File;
! tie(%h, 'SDBM_File', 'Op.dbmx', O_RDWR|O_CREAT, 0640);
untie %h;
#~ Change name in Makefile.PL for clarity
diff -Pcr perl5_003/ext/SDBM_File/sdbm/Makefile.PL perl5_003_01/ext/SDBM_File/sdbm/Makefile.PL
*** perl5_003/ext/SDBM_File/sdbm/Makefile.PL Sun Jun 23 22:11:45 1996
--- perl5_003_01/ext/SDBM_File/sdbm/Makefile.PL Mon Jun 17 15:09:35 1996
***************
*** 1,13 ****
use ExtUtils::MakeMaker;
WriteMakefile(
! 'NAME' => 'SDBM_File',
! 'LINKTYPE' => 'static',
! 'DEFINE' => '-DSDBM -DDUFF',
! 'SKIP' => [qw(static static_lib dynamic dynamic_lib)],
! 'clean'
! => {'FILES' => 'dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag'},
! 'H' => [qw(tune.h sdbm.h pair.h $(PERL_INC)/config.h)],
! 'C' => [qw(sdbm.c pair.c hash.c)]
);
--- 1,12 ----
use ExtUtils::MakeMaker;
WriteMakefile(
! NAME => 'SDBM_File/sdbm', # doesn't matter what the name is here
! LINKTYPE => 'static',
! DEFINE => '-DSDBM -DDUFF',
! SKIP => [qw(static static_lib dynamic dynamic_lib)],
! clean => {'FILES' => 'dbu libsdbm.a dbd dba dbe x-dbu *.dir *.pag'},
! H => [qw(tune.h sdbm.h pair.h $(PERL_INC)/config.h)],
! C => [qw(sdbm.c pair.c hash.c)]
);
#~ Correct CODE block declaration
diff -Pcr perl5_003/ext/Socket/Socket.xs perl5_003_01/ext/Socket/Socket.xs
*** perl5_003/ext/Socket/Socket.xs Mon Jan 22 20:42:22 1996
--- perl5_003_01/ext/Socket/Socket.xs Thu Jul 25 15:26:49 1996
***************
*** 649,655 ****
void
unpack_sockaddr_un(sun_sv)
SV * sun_sv
! PPCODE:
{
#ifdef I_SYS_UN
STRLEN sockaddrlen;
--- 649,655 ----
void
unpack_sockaddr_un(sun_sv)
SV * sun_sv
! CODE:
{
#ifdef I_SYS_UN
STRLEN sockaddrlen;
#~ Add symbols for shared hash keys and improved signal handling
#~ Rename symbols to avoid collisions with other headers or libraries
diff -Pcr perl5_003/global.sym perl5_003_01/global.sym
*** perl5_003/global.sym Mon Mar 25 01:04:07 1996
--- perl5_003_01/global.sym Wed Jul 17 11:09:00 1996
***************
*** 28,33 ****
--- 28,34 ----
comppad
comppad_name
comppad_name_fill
+ comppad_name_floor
concat_amg
concat_ass_amg
cop_seqmax
***************
*** 36,41 ****
--- 37,43 ----
cshlen
cshname
curcop
+ curcopdb
curinterp
curpad
dc
***************
*** 148,153 ****
--- 150,157 ----
ppaddr
profiledata
provide_ref
+ psig_ptr
+ psig_name
qrt_amg
rcsid
reall_srchlen
***************
*** 206,212 ****
sle_amg
slt_amg
sne_amg
- stack
stack_base
stack_max
stack_sp
--- 210,215 ----
***************
*** 300,306 ****
cast_ulong
check_uni
checkcomma
- chsize
ck_aelem
ck_concat
ck_delete
--- 303,308 ----
***************
*** 416,421 ****
--- 418,424 ----
gv_fullname
gv_init
gv_stashpv
+ gv_stashpvn
gv_stashsv
he_delayfree
he_free
***************
*** 423,438 ****
--- 426,446 ----
hoistmust
hv_clear
hv_delete
+ hv_delete_ent
hv_exists
+ hv_exists_ent
hv_fetch
+ hv_fetch_ent
hv_iterinit
hv_iterkey
+ hv_iterkeysv
hv_iternext
hv_iternextsv
hv_iterval
hv_magic
hv_stashpv
hv_store
+ hv_store_ent
hv_undef
ibcmp
ingroup
***************
*** 451,462 ****
--- 459,472 ----
looks_like_number
magic_clearenv
magic_clearpack
+ magic_clearsig
magic_existspack
magic_get
magic_getarylen
magic_getglob
magic_getpack
magic_getpos
+ magic_getsig
magic_gettaint
magic_getuvar
magic_len
***************
*** 496,501 ****
--- 506,512 ----
my
my_bcopy
my_bzero
+ my_chsize
my_exit
my_htonl
my_lstat
***************
*** 982,987 ****
--- 993,999 ----
screaminstr
setdefout
setenv_getix
+ sharepvn
sighandler
skipspace
stack_grow
***************
*** 1049,1054 ****
--- 1061,1067 ----
too_few_arguments
too_many_arguments
unlnk
+ unsharepvn
utilize
wait4pid
warn
#~ Add casts where necessary to accomodate new GV type
#~ Speed up symbol table access and method lookup
diff -Pcr perl5_003/gv.c perl5_003_01/gv.c
*** perl5_003/gv.c Mon Mar 25 01:04:07 1996
--- perl5_003_01/gv.c Tue Jun 18 21:59:13 1996
***************
*** 81,87 ****
{
register GP *gp;
! sv_upgrade(gv, SVt_PVGV);
if (SvLEN(gv))
Safefree(SvPVX(gv));
Newz(602,gp, 1, GP);
--- 81,87 ----
{
register GP *gp;
! sv_upgrade((SV*)gv, SVt_PVGV);
if (SvLEN(gv))
Safefree(SvPVX(gv));
Newz(602,gp, 1, GP);
***************
*** 185,191 ****
}
if (!level) {
! if (lastchance = gv_stashpv("UNIVERSAL", FALSE)) {
if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) {
if (cv) { /* junk old undef */
assert(SvREFCNT(topgv) > 1);
--- 185,191 ----
}
if (!level) {
! if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) {
if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) {
if (cv) { /* junk old undef */
assert(SvREFCNT(topgv) > 1);
***************
*** 227,237 ****
/* Degenerate case ->SUPER::method should really lookup in original stash */
SV *tmpstr = sv_2mortal(newSVpv(HvNAME(curcop->cop_stash),0));
sv_catpvn(tmpstr, "::SUPER", 7);
! stash = gv_stashpv(SvPV(tmpstr,na),TRUE);
*nsplit = ch;
DEBUG_o( deb("Treating %s as %s::%s\n",origname,HvNAME(stash),name) );
} else {
! stash = gv_stashpv(origname,TRUE);
*nsplit = ch;
}
}
--- 227,237 ----
/* Degenerate case ->SUPER::method should really lookup in original stash */
SV *tmpstr = sv_2mortal(newSVpv(HvNAME(curcop->cop_stash),0));
sv_catpvn(tmpstr, "::SUPER", 7);
! stash = gv_stashpvn(SvPVX(tmpstr),SvCUR(tmpstr),TRUE);
*nsplit = ch;
DEBUG_o( deb("Treating %s as %s::%s\n",origname,HvNAME(stash),name) );
} else {
! stash = gv_stashpvn(origname, nsplit - origname, TRUE);
*nsplit = ch;
}
}
***************
*** 241,247 ****
/* Failed obvious case - look for SUPER as last element of stash's name */
char *packname = HvNAME(stash);
STRLEN len = strlen(packname);
! if (len >= 7 && strEQ(packname+len-7,"::SUPER")) {
/* Now look for @.*::SUPER::ISA */
GV** gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
if (!gvp || (gv = *gvp) == (GV*)&sv_undef || !GvAV(gv)) {
--- 241,247 ----
/* 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")) {
/* Now look for @.*::SUPER::ISA */
GV** gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
if (!gvp || (gv = *gvp) == (GV*)&sv_undef || !GvAV(gv)) {
***************
*** 249,259 ****
and see if there is an @ISA there
*/
HV *basestash;
! char ch = packname[len-7];
AV *av;
! packname[len-7] = '\0';
! basestash = gv_stashpv(packname, TRUE);
! packname[len-7] = ch;
gvp = (GV**)hv_fetch(basestash,"ISA",3,FALSE);
if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
/* Okay found @ISA after dropping the SUPER, alias it */
--- 249,259 ----
and see if there is an @ISA there
*/
HV *basestash;
! char ch = packname[len];
AV *av;
! packname[len] = '\0';
! basestash = gv_stashpvn(packname, len, TRUE);
! packname[len] = ch;
gvp = (GV**)hv_fetch(basestash,"ISA",3,FALSE);
if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
/* Okay found @ISA after dropping the SUPER, alias it */
***************
*** 276,282 ****
CV* cv;
if (strEQ(name,"import") || strEQ(name,"unimport"))
! gv = &sv_yes;
else if (strNE(name, "AUTOLOAD")) {
gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0);
if (gv && (cv = GvCV(gv))) { /* One more chance... */
--- 276,282 ----
CV* cv;
if (strEQ(name,"import") || strEQ(name,"unimport"))
! gv = (GV*)&sv_yes;
else if (strNE(name, "AUTOLOAD")) {
gv = gv_fetchmeth(stash, "AUTOLOAD", 8, 0);
if (gv && (cv = GvCV(gv))) { /* One more chance... */
***************
*** 297,310 ****
char *name;
I32 create;
{
! char tmpbuf[1234];
HV *stash;
GV *tmpgv;
! /* Use strncpy to avoid bug in VMS sprintf */
! /* sprintf(tmpbuf,"%.*s::",1200,name); */
! strncpy(tmpbuf, name, 1200);
! tmpbuf[1200] = '\0'; /* just in case . . . */
! strcat(tmpbuf, "::");
tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
if (!tmpgv)
return 0;
--- 297,327 ----
char *name;
I32 create;
{
! return gv_stashpvn(name, strlen(name), create);
! }
!
! HV*
! gv_stashpvn(name,namelen,create)
! char *name;
! U32 namelen;
! I32 create;
! {
! char tmpbuf[1203];
HV *stash;
GV *tmpgv;
!
! if (namelen > 1200) {
! namelen = 1200;
! #ifdef VMS
! warn("Weird package name \"%s\" truncated", name);
! #else
! warn("Weird package name \"%.*s...\" truncated", namelen, name);
! #endif
! }
! Copy(name,tmpbuf,namelen,char);
! tmpbuf[namelen++] = ':';
! tmpbuf[namelen++] = ':';
! tmpbuf[namelen] = '\0';
tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
if (!tmpgv)
return 0;
***************
*** 321,327 ****
SV *sv;
I32 create;
{
! return gv_stashpv(SvPV(sv,na), create);
}
--- 338,347 ----
SV *sv;
I32 create;
{
! register char *ptr;
! STRLEN len;
! ptr = SvPV(sv,len);
! return gv_stashpvn(ptr, len, create);
}
***************
*** 349,355 ****
{
if (!stash)
stash = defstash;
! if (!SvREFCNT(stash)) /* symbol table under destruction */
return Nullgv;
len = namend - name;
--- 369,375 ----
{
if (!stash)
stash = defstash;
! if (!stash || !SvREFCNT(stash)) /* symbol table under destruction */
return Nullgv;
len = namend - name;
***************
*** 384,390 ****
namend++;
name = namend;
if (!*name)
! return gv ? gv : *hv_fetch(defstash, "main::", 6, TRUE);
}
}
len = namend - name;
--- 404,410 ----
namend++;
name = namend;
if (!*name)
! return gv ? gv : (GV*)*hv_fetch(defstash, "main::", 6, TRUE);
}
}
len = namend - name;
***************
*** 518,532 ****
{
char *pname;
av_push(av, newSVpv(pname = "NDBM_File",0));
! gv_stashpv(pname, TRUE);
av_push(av, newSVpv(pname = "DB_File",0));
! gv_stashpv(pname, TRUE);
av_push(av, newSVpv(pname = "GDBM_File",0));
! gv_stashpv(pname, TRUE);
av_push(av, newSVpv(pname = "SDBM_File",0));
! gv_stashpv(pname, TRUE);
av_push(av, newSVpv(pname = "ODBM_File",0));
! gv_stashpv(pname, TRUE);
}
}
break;
--- 538,552 ----
{
char *pname;
av_push(av, newSVpv(pname = "NDBM_File",0));
! gv_stashpvn(pname, 9, TRUE);
av_push(av, newSVpv(pname = "DB_File",0));
! gv_stashpvn(pname, 7, TRUE);
av_push(av, newSVpv(pname = "GDBM_File",0));
! gv_stashpvn(pname, 9, TRUE);
av_push(av, newSVpv(pname = "SDBM_File",0));
! gv_stashpvn(pname, 9, TRUE);
av_push(av, newSVpv(pname = "ODBM_File",0));
! gv_stashpvn(pname, 9, TRUE);
}
}
break;
***************
*** 542,552 ****
case 'S':
if (strEQ(name, "SIG")) {
HV *hv;
siggv = gv;
GvMULTI_on(siggv);
hv = GvHVn(siggv);
hv_magic(hv, siggv, 'S');
!
/* initialize signal stack */
signalstack = newAV();
AvREAL_off(signalstack);
--- 562,580 ----
case 'S':
if (strEQ(name, "SIG")) {
HV *hv;
+ I32 i;
siggv = gv;
GvMULTI_on(siggv);
hv = GvHVn(siggv);
hv_magic(hv, siggv, 'S');
! for(i=1;sig_name[i];i++) {
! SV ** init;
! init=hv_fetch(hv,sig_name[i],strlen(sig_name[i]),1);
! if(init)
! sv_setsv(*init,&sv_undef);
! psig_ptr[i] = 0;
! psig_name[i] = 0;
! }
/* initialize signal stack */
signalstack = newAV();
AvREAL_off(signalstack);
***************
*** 702,708 ****
sv_upgrade((SV *)io,SVt_PVIO);
SvREFCNT(io) = 1;
SvOBJECT_on(io);
! iogv = gv_fetchpv("FileHandle::", TRUE, SVt_PVHV);
SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
return io;
}
--- 730,736 ----
sv_upgrade((SV *)io,SVt_PVIO);
SvREFCNT(io) = 1;
SvOBJECT_on(io);
! iogv = gv_fetchpv("IO::Handle::", TRUE, SVt_PVHV);
SvSTASH(io) = (HV*)SvREFCNT_inc(GvHV(iogv));
return io;
}
***************
*** 720,734 ****
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
! for (entry = HvARRAY(stash)[i]; entry; entry = entry->hent_next) {
! if (entry->hent_key[entry->hent_klen-1] == ':' &&
! (gv = (GV*)entry->hent_val) && (hv = GvHV(gv)) && HvNAME(hv))
{
if (hv != defstash)
gv_check(hv); /* nested package */
}
! else if (isALPHA(*entry->hent_key)) {
! gv = (GV*)entry->hent_val;
if (GvMULTI(gv))
continue;
curcop->cop_line = GvLINE(gv);
--- 748,762 ----
if (!HvARRAY(stash))
return;
for (i = 0; i <= (I32) HvMAX(stash); i++) {
! for (entry = HvARRAY(stash)[i]; entry; entry = HeNEXT(entry)) {
! if (HeKEY(entry)[HeKLEN(entry)-1] == ':' &&
! (gv = (GV*)HeVAL(entry)) && (hv = GvHV(gv)) && HvNAME(hv))
{
if (hv != defstash)
gv_check(hv); /* nested package */
}
! else if (isALPHA(*HeKEY(entry))) {
! gv = (GV*)HeVAL(entry);
if (GvMULTI(gv))
continue;
curcop->cop_line = GvLINE(gv);
***************
*** 736,742 ****
curcop->cop_filegv = filegv;
if (filegv && GvMULTI(filegv)) /* Filename began with slash */
continue;
! warn("Identifier \"%s::%s\" used only once: possible typo",
HvNAME(stash), GvNAME(gv));
}
}
--- 764,770 ----
curcop->cop_filegv = filegv;
if (filegv && GvMULTI(filegv)) /* Filename began with slash */
continue;
! warn("Name \"%s::%s\" used only once: possible typo",
HvNAME(stash), GvNAME(gv));
}
}
***************
*** 854,859 ****
--- 882,888 ----
AMT amt;
SV* sv;
SV** svp;
+ GV** gvp;
/* if (*(svp)==(SV*)amagic_generation && *(svp+1)==(SV*)sub_generation) {
DEBUG_o( deb("Overload magic in package %s up-to-date\n",HvNAME(stash))
***************
*** 878,884 ****
if ( (cp=((char**)(*AMG_names))[i]) ) {
svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE);
! if (svp && ((sv = *svp) != (GV*)&sv_undef)) {
switch (SvTYPE(sv)) {
default:
if (!SvROK(sv)) {
--- 907,913 ----
if ( (cp=((char**)(*AMG_names))[i]) ) {
svp=(SV**)hv_fetch(hv,cp,strlen(cp),FALSE);
! if (svp && ((sv = *svp) != &sv_undef)) {
switch (SvTYPE(sv)) {
default:
if (!SvROK(sv)) {
***************
*** 977,982 ****
--- 1006,1017 ----
case string_amg:
(void)((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg]));
break;
+ case not_amg:
+ (void)((cv = cvp[off=bool__amg])
+ || (cv = cvp[off=numer_amg])
+ || (cv = cvp[off=string_amg]));
+ postpr = 1;
+ break;
case copy_amg:
{
SV* ref=SvRV(left);
***************
*** 1132,1137 ****
--- 1167,1174 ----
ENTER;
SAVESPTR(op);
op = (OP *) &myop;
+ if (perldb && curstash != debstash)
+ op->op_private |= OPpENTERSUB_DB;
PUTBACK;
pp_pushmark();
***************
*** 1182,1187 ****
--- 1219,1226 ----
case inc_amg:
case dec_amg:
SvSetSV(left,res); return res; break;
+ case not_amg:
+ ans=!SvOK(res); break;
}
return ans? &sv_yes: &sv_no;
} else if (method==copy_amg) {
#~ Add cast for GV type
diff -Pcr perl5_003/gv.h perl5_003_01/gv.h
*** perl5_003/gv.h Fri Feb 23 22:07:17 1996
--- perl5_003_01/gv.h Tue Jun 18 20:41:19 1996
***************
*** 42,47 ****
--- 42,48 ----
#define GvFORM(gv) (GvGP(gv)->gp_form)
#define GvAV(gv) (GvGP(gv)->gp_av)
+ #define GvREFCNT_inc(gv) ((GV*)SvREFCNT_inc(gv))
#ifdef MICROPORT /* Microport 2.4 hack */
AV *GvAVn();
#~ Move up definitions of TRUE/FALSE
#~ Include bool typedef on NeXT
#~ Add calloc prototypes
diff -Pcr perl5_003/handy.h perl5_003_01/handy.h
*** perl5_003/handy.h Wed Jun 7 19:47:10 1995
--- perl5_003_01/handy.h Thu Jul 11 12:25:26 1996
***************
*** 23,28 ****
--- 23,37 ----
#define Nullfp Null(FILE*)
#define Nullsv Null(SV*)
+ #ifdef TRUE
+ #undef TRUE
+ #endif
+ #ifdef FALSE
+ #undef FALSE
+ #endif
+ #define TRUE (1)
+ #define FALSE (0)
+
/* bool is built-in for g++-2.6.3, which might be used for an extension.
If the extension includes <_G_config.h> before this file then
_G_HAVE_BOOL will be properly set. If, however, the extension includes
***************
*** 37,42 ****
--- 46,64 ----
# endif
#endif
+ /* The NeXT dynamic loader headers will not build with the bool macro
+ So declare them now to clear confusion.
+ */
+ #ifdef NeXT
+ # undef FALSE
+ # undef TRUE
+ typedef enum bool { FALSE = 0, TRUE = 1 } bool;
+ # define ENUM_BOOL 1
+ # ifndef HAS_BOOL
+ # define HAS_BOOL 1
+ # endif /* !HAS_BOOL */
+ #endif /* NeXT */
+
#ifndef HAS_BOOL
# ifdef UTS
# define bool int
***************
*** 45,59 ****
# endif
#endif
- #ifdef TRUE
- #undef TRUE
- #endif
- #ifdef FALSE
- #undef FALSE
- #endif
- #define TRUE (1)
- #define FALSE (0)
-
typedef char I8;
typedef unsigned char U8;
--- 67,72 ----
***************
*** 133,138 ****
--- 146,152 ----
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))))
***************
*** 155,160 ****
--- 169,175 ----
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)))), \
#~ Recognize gcc binaries with version in name
diff -Pcr perl5_003/hints/aux.sh perl5_003_01/hints/aux.sh
*** perl5_003/hints/aux.sh Wed Jun 7 19:47:19 1995
--- perl5_003_01/hints/aux.sh Fri Jul 5 17:35:09 1996
***************
*** 6,12 ****
# Fri May 5 10:59:43 EDT 1995
case "$cc" in
! gcc) optimize='-O2'
ccflags="$ccflags -D_POSIX_SOURCE"
echo "Setting hints for GNU CC."
;;
--- 6,12 ----
# Fri May 5 10:59:43 EDT 1995
case "$cc" in
! *gcc*) optimize='-O2'
ccflags="$ccflags -D_POSIX_SOURCE"
echo "Setting hints for GNU CC."
;;
#~ Recognize recent versions > 10.2
diff -Pcr perl5_003/hints/convexos.sh perl5_003_01/hints/convexos.sh
*** perl5_003/hints/convexos.sh Thu Jan 19 18:59:10 1995
--- perl5_003_01/hints/convexos.sh Wed Jul 10 11:46:40 1996
***************
*** 15,20 ****
# a mixed system, so we undef d_getpgrp.
# Andy Dougherty doughera@lafcol.lafayette.edu
#
! case "$osvers" in
! 10.2) d_getpgrp='undef' ;;
! esac
--- 15,21 ----
# a mixed system, so we undef d_getpgrp.
# Andy Dougherty doughera@lafcol.lafayette.edu
#
! if [ "$osvers" -ge 10.2 ]
! then
! d_getpgrp='undef' ;;
! fi
#~ Recognize gcc binaries with version in name
diff -Pcr perl5_003/hints/irix_4.sh perl5_003_01/hints/irix_4.sh
*** perl5_003/hints/irix_4.sh Wed Jun 7 19:47:33 1995
--- perl5_003_01/hints/irix_4.sh Fri Jul 5 17:35:11 1996
***************
*** 7,13 ****
d_charsprf=undef
case "$cc" in
! *gcc) ccflags="$ccflags -D_BSD_TYPES" ;;
*) ccflags="$ccflags -ansiposix -signed" ;;
esac
--- 7,13 ----
d_charsprf=undef
case "$cc" in
! *gcc*) ccflags="$ccflags -D_BSD_TYPES" ;;
*) ccflags="$ccflags -ansiposix -signed" ;;
esac
#~ Recognize gcc binaries with version in name
diff -Pcr perl5_003/hints/irix_5.sh perl5_003_01/hints/irix_5.sh
*** perl5_003/hints/irix_5.sh Mon Jan 22 20:42:34 1996
--- perl5_003_01/hints/irix_5.sh Fri Jul 5 17:35:13 1996
***************
*** 11,17 ****
i_time='define'
case "$cc" in
! *gcc) ccflags="$ccflags -D_BSD_TYPES" ;;
*) ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 3000" ;;
esac
--- 11,17 ----
i_time='define'
case "$cc" in
! *gcc*) ccflags="$ccflags -D_BSD_TYPES" ;;
*) ccflags="$ccflags -D_POSIX_SOURCE -ansiposix -D_BSD_TYPES -Olimit 3000" ;;
esac
#~ Eliminate hints now correctly handled by Configure
diff -Pcr perl5_003/hints/irix_6_2.sh perl5_003_01/hints/irix_6_2.sh
*** perl5_003/hints/irix_6_2.sh Mon Mar 25 01:04:08 1996
--- perl5_003_01/hints/irix_6_2.sh Wed Jul 10 11:55:14 1996
***************
*** 1,28 ****
# irix_6_2.sh
! # from Krishna Sethuraman, krishna@sgi.com
! # Date: Tue Aug 22 00:38:26 PDT 1995
! # removed -ansiposix and -D_POSIX_SOURCE cuz it was choking
- # Perl built with this hints file under IRIX 6.2 passes
- # all tests (`make test').
-
- ld=ld
- i_time='define'
- cc="cc -32"
ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -Olimit 3000"
- #ccflags="$ccflags -Olimit 3000" # this line builds perl but not tk (beta 8)
- lddlflags="-32 -shared"
- # Configure would suggest the default -Kpic, which won't work for SGI.
- # Configure will respect this blank hint value instead.
- cccdlflags=' '
# We don't want these libraries. Anyone know why?
set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ nsl / /' -e 's/ dl / /'`
shift
libswanted="$*"
# Don't need sun crypt bsd PW under 6.2. You *may* need to link
# with these if you want to run perl built under 6.2 on a 5.3 machine
# (I haven't checked)
! #set `echo X "$libswanted "|sed -e 's/ sun / /' -e 's/ crypt / /' -e 's/ bsd / /' -e 's/ PW / /'`
! #shift
! #libswanted="$*"
--- 1,17 ----
# irix_6_2.sh
! # original from Krishna Sethuraman, krishna@sgi.com
! # Configure has been made smarter, so this is shorter than it once was.
ccflags="$ccflags -D_BSD_TYPES -D_BSD_TIME -Olimit 3000"
# We don't want these libraries. Anyone know why?
set `echo X "$libswanted "|sed -e 's/ socket / /' -e 's/ nsl / /' -e 's/ dl / /'`
shift
libswanted="$*"
+
# Don't need sun crypt bsd PW under 6.2. You *may* need to link
# with these if you want to run perl built under 6.2 on a 5.3 machine
# (I haven't checked)
! set `echo X "$libswanted "|sed -e 's/ sun / /' -e 's/ crypt / /' -e 's/ bsd / /' -e 's/ PW / /'`
! shift
! libswanted="$*"
#~ Update cc and ld flags, and add MAB support
diff -Pcr perl5_003/hints/next_3.sh perl5_003_01/hints/next_3.sh
*** perl5_003/hints/next_3.sh Wed Jun 7 19:47:47 1995
--- perl5_003_01/hints/next_3.sh Thu Jul 11 12:26:05 1996
***************
*** 10,20 ****
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'
--- 10,24 ----
ldflags='-u libsys_s'
libswanted='dbm gdbm db'
! lddlflags='-nostdlib -r'
# Give cccdlflags an empty value since Configure will detect we are
# using GNU cc and try to specify -fpic for cccdlflags.
cccdlflags=' '
+ mab='-arch m68k -arch i386 -arch hppa -arch sparc'
+ archname='next-fat'
+ ld='cc'
+
i_utime='undef'
groupstype='int'
direntrytype='struct direct'
***************
*** 36,41 ****
#
# 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
--- 40,43 ----
#~ Add hints file for NeXT 3.2
diff -Pcr perl5_003/hints/next_3_2.sh perl5_003_01/hints/next_3_2.sh
*** perl5_003/hints/next_3_2.sh Wed Dec 31 19:00:00 1969
--- perl5_003_01/hints/next_3_2.sh Fri Jul 5 15:34:09 1996
***************
*** 0 ****
--- 1,64 ----
+ # 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
#~ Add hints file for NeXT 3.3
diff -Pcr perl5_003/hints/next_3_3.sh perl5_003_01/hints/next_3_3.sh
*** perl5_003/hints/next_3_3.sh Wed Dec 31 19:00:00 1969
--- perl5_003_01/hints/next_3_3.sh Fri Jul 5 15:34:11 1996
***************
*** 0 ****
--- 1,69 ----
+ # 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
#~ Add hints file for NeXT 4.0
diff -Pcr perl5_003/hints/next_4.sh perl5_003_01/hints/next_4.sh
*** perl5_003/hints/next_4.sh Wed Dec 31 19:00:00 1969
--- perl5_003_01/hints/next_4.sh Thu Jul 11 12:26:09 1996
***************
*** 0 ****
--- 1,55 ----
+ # 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):
+ # DYLD_LIBRARY_PATH=`pwd`; export DYLD_LIBRARY_PATH
+ # or
+ # setenv DYLD_LIBRARY_PATH `pwd`
+ #
+ 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'
+ cccdlflags='none'
+ ld='cc'
+ optimize='-g -O'
+
+ d_shrplib='define'
+ dlext='bundle'
+ so='dylib'
+
+ prefix='/usr/local/OPENSTEP'
+ #archlib='/usr/lib/perl5'
+ #archlibexp='/usr/lib/perl5'
+ archname='OPENSTEP-Mach'
+
+ d_strcoll='undef'
+ i_dbm='define'
+ i_utime='undef'
+ groupstype='int'
+ direntrytype='struct direct'
+
+ # 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'
+ clocktype='int'
+
+ #
+ # On some NeXT machines, the timestamp put by ranlib is not correct, and
+ # this may cause useless recompiles. Fix that by adding a sleep before
+ # running ranlib. The '5' is an empirical number that's "long enough."
+ # (Thanks to Andreas Koenig <k@franz.ww.tu-berlin.de>)
+ ranlib='sleep 5; /bin/ranlib'
+ #
+ # There where reports that the compiler on HPPA machines
+ # fails with the -O flag on pp.c.
+ # But since there is no HPPA for OPENSTEP...
+ # pp_cflags='optimize="-g"'
#~ Insure execution by shell
#~ Locate shell binary for BIN_SH cpp macro
#~ Include a.out support
#~ Account for home-grown process priority functions
diff -Pcr perl5_003/hints/os2.sh perl5_003_01/hints/os2.sh
*** perl5_003/hints/os2.sh Mon Mar 25 01:04:09 1996
--- perl5_003_01/hints/os2.sh Tue Jun 18 21:17:45 1996
***************
*** 1,3 ****
--- 1,4 ----
+ #! /bin/sh
# hints/os2.sh
# This file reflects the tireless work of
# Ilya Zakharevich <ilya@math.ohio-state.edu>
***************
*** 5,11 ****
# Trimmed and comments added by
# Andy Dougherty <doughera@lafcol.lafayette.edu>
# Exactly what is required beyond a standard OS/2 installation?
! # There are notes about "patched pdksh" I don't understand.
# Note that symbol extraction code gives wrong answers (sometimes?) on
# gethostent and setsid.
--- 6,12 ----
# Trimmed and comments added by
# Andy Dougherty <doughera@lafcol.lafayette.edu>
# Exactly what is required beyond a standard OS/2 installation?
! # There are notes about "patched pdksh" I do not understand.
# Note that symbol extraction code gives wrong answers (sometimes?) on
# gethostent and setsid.
***************
*** 13,18 ****
--- 14,22 ----
# 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
+
#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'
***************
*** 30,46 ****
firstmakefile='GNUmakefile'
exe_ext='.exe'
if [ "$emxaout" != "" ]; then
! d_shrplib='undef'
! obj_ext='.o'
! lib_ext='.a'
! ar='ar'
! plibext='.a'
! d_fork='define'
! lddlflags='-Zdll'
! ldflags='-Zexe'
! ccflags='-DDOSISH -DNO_SYS_ALLOC -DOS2=2 -DEMBED -I. -DPACK_MALLOC'
! use_clib='c'
else
d_shrplib='define'
obj_ext='.obj'
--- 34,72 ----
firstmakefile='GNUmakefile'
exe_ext='.exe'
+ # We provide it
+ i_dlfcn='define'
+
+ aout_d_shrplib='undef'
+ 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'
+ 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'
+
if [ "$emxaout" != "" ]; then
! d_shrplib="$aout_d_shrplib"
! obj_ext="$aout_obj_ext"
! lib_ext="$aout_lib_ext"
! ar="$aout_ar"
! plibext="$aout_plibext"
! d_fork="$aout_d_fork"
! lddlflags="$aout_lddlflags"
! ldflags="$aout_ldflags"
! ccflags="$aout_ccflags"
! cppflags="$aout_cppflags"
! use_clib="$aout_use_clib"
! usedl="$aout_usedl"
else
d_shrplib='define'
obj_ext='.obj'
***************
*** 51,58 ****
lddlflags='-Zdll -Zomf -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'
use_clib='c_import'
fi
# To get into config.sh (should start at the beginning of line)
--- 77,85 ----
lddlflags='-Zdll -Zomf -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'
use_clib='c_import'
+ usedl='define'
fi
# To get into config.sh (should start at the beginning of line)
***************
*** 70,87 ****
# [Maybe we should just remove c from $libswanted ?]
libs='-lsocket -lm'
! archobjs="os2$obj_ext"
# Run files without extension with sh - feature of patched ksh
# [???]
! NOHASHBANG=sh
# Same with newer ksh
EXECSHELL=sh
cccdlflags='-Zdll'
! dlsrc='dl_os2.xs'
ld='gcc'
- usedl='define'
#cppflags='-DDOSISH -DOS2=2 -DEMBED -I.'
--- 97,113 ----
# [Maybe we should just remove c from $libswanted ?]
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
EXECSHELL=sh
cccdlflags='-Zdll'
! dlsrc='dl_dlopen.xs'
ld='gcc'
#cppflags='-DDOSISH -DOS2=2 -DEMBED -I.'
***************
*** 123,135 ****
nm_opt='-p'
! ####### All the rest is commented
! # I do not have these:
! #dynamic_ext='Fcntl GDBM_File SDBM_File POSIX Socket UPM REXXCALL'
! #dynamic_ext='Fcntl POSIX Socket SDBM_File Devel/DProf'
! #extensions='Fcntl GDBM_File SDBM_File POSIX Socket UPM REXXCALL'
! #extensions='Fcntl SDBM_File POSIX Socket Devel/DProf'
# The next two are commented. pdksh handles #!
# sharpbang='extproc '
--- 149,160 ----
nm_opt='-p'
! ####### We define these functions ourselves
!
! d_getprior='define'
! d_setprior='define'
! ####### All the rest is commented
# The next two are commented. pdksh handles #!
# sharpbang='extproc '
#~ Recognize gcc binaries with version in name
diff -Pcr perl5_003/hints/sco.sh perl5_003_01/hints/sco.sh
*** perl5_003/hints/sco.sh Tue Feb 13 12:28:07 1996
--- perl5_003_01/hints/sco.sh Fri Jul 5 17:35:15 1996
***************
*** 30,36 ****
xlibpth=''
case "$cc" in
! gcc)
ccflags="$ccflags -U M_XENIX"
optimize="$optimize -O2"
;;
--- 30,36 ----
xlibpth=''
case "$cc" in
! *gcc*)
ccflags="$ccflags -U M_XENIX"
optimize="$optimize -O2"
;;
#~ Correct note on GCC_EXEC_PREFIX
diff -Pcr perl5_003/hints/solaris_2.sh perl5_003_01/hints/solaris_2.sh
*** perl5_003/hints/solaris_2.sh Mon Jun 24 16:07:54 1996
--- perl5_003_01/hints/solaris_2.sh Sun Jul 7 20:01:51 1996
***************
*** 3,9 ****
# Andy Dougherty <doughera@lafcol.lafayette.edu>
# Based on input from lots of folks, especially
# Dean Roehrich <roehrich@ironwood-fddi.cray.com>
!
# See man vfork.
usevfork=false
--- 3,9 ----
# Andy Dougherty <doughera@lafcol.lafayette.edu>
# Based on input from lots of folks, especially
# Dean Roehrich <roehrich@ironwood-fddi.cray.com>
!
# See man vfork.
usevfork=false
***************
*** 152,158 ****
NOTE: You are using GNU as(1). GNU as(1) will not build Perl.
You must arrange to use /usr/ccs/bin/as, perhaps by setting
! GCC_EXEC_PREFIX or by including -B/usr/ccs/bin in your cc command.
END
;;
--- 152,158 ----
NOTE: You are using GNU as(1). GNU as(1) will not build Perl.
You must arrange to use /usr/ccs/bin/as, perhaps by setting
! GCC_EXEC_PREFIX or by including -B/usr/ccs/bin/ in your cc command.
END
;;
***************
*** 166,172 ****
NOTE: You are using GNU ld(1). GNU ld(1) will not build Perl.
You must arrange to use /usr/ccs/bin/ld, perhaps by setting
! GCC_EXEC_PREFIX or by including -B/usr/ccs/bin in your cc command.
END
;;
--- 166,172 ----
NOTE: You are using GNU ld(1). GNU ld(1) will not build Perl.
You must arrange to use /usr/ccs/bin/ld, perhaps by setting
! GCC_EXEC_PREFIX or by including -B/usr/ccs/bin/ in your cc command.
END
;;
#~ Add shared hash key support
#~ Protect %SIG elements from deletion
diff -Pcr perl5_003/hv.c perl5_003_01/hv.c
*** perl5_003/hv.c Tue Jan 30 20:33:23 1996
--- perl5_003_01/hv.c Tue Jun 18 21:46:13 1996
***************
*** 25,31 ****
HE* he;
if (he_root) {
he = he_root;
! he_root = (HE*)he->hent_next;
return he;
}
return more_he();
--- 25,31 ----
HE* he;
if (he_root) {
he = he_root;
! he_root = HeNEXT(he);
return he;
}
return more_he();
***************
*** 35,41 ****
del_he(p)
HE* p;
{
! p->hent_next = (HE*)he_root;
he_root = p;
}
--- 35,41 ----
del_he(p)
HE* p;
{
! HeNEXT(p) = (HE*)he_root;
he_root = p;
}
***************
*** 48,60 ****
he = he_root;
heend = &he[1008 / sizeof(HE) - 1];
while (he < heend) {
! he->hent_next = (HE*)(he + 1);
he++;
}
! he->hent_next = 0;
return new_he();
}
SV**
hv_fetch(hv,key,klen,lval)
HV *hv;
--- 48,63 ----
he = he_root;
heend = &he[1008 / sizeof(HE) - 1];
while (he < heend) {
! HeNEXT(he) = (HE*)(he + 1);
he++;
}
! HeNEXT(he) = 0;
return new_he();
}
+ /* (klen == HEf_SVKEY) is special for MAGICAL hv entries, meaning key slot
+ * contains an SV* */
+
SV**
hv_fetch(hv,key,klen,lval)
HV *hv;
***************
*** 63,71 ****
I32 lval;
{
register XPVHV* xhv;
! register char *s;
! register I32 i;
! register I32 hash;
register HE *entry;
SV *sv;
--- 66,72 ----
I32 lval;
{
register XPVHV* xhv;
! register U32 hash;
register HE *entry;
SV *sv;
***************
*** 93,113 ****
return 0;
}
! i = klen;
! hash = 0;
! s = key;
! while (i--)
! hash = hash * 33 + *s++;
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
! for (; entry; entry = entry->hent_next) {
! if (entry->hent_hash != hash) /* strings can't be equal */
continue;
! if (entry->hent_klen != klen)
continue;
! if (bcmp(entry->hent_key,key,klen)) /* is this it? */
continue;
! return &entry->hent_val;
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
--- 94,110 ----
return 0;
}
! PERL_HASH(hash, key, klen);
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
! for (; entry; entry = HeNEXT(entry)) {
! if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
! if (HeKLEN(entry) != klen)
continue;
! if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
continue;
! return &HeVAL(entry);
}
#ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
***************
*** 127,132 ****
--- 124,208 ----
return 0;
}
+ /* returns a HE * structure with the all fields set */
+ /* note that hent_val will be a mortal sv for MAGICAL hashes */
+ HE *
+ hv_fetch_ent(hv,keysv,lval,hash)
+ HV *hv;
+ SV *keysv;
+ I32 lval;
+ register U32 hash;
+ {
+ register XPVHV* xhv;
+ register char *key;
+ STRLEN klen;
+ register HE *entry;
+ SV *sv;
+
+ if (!hv)
+ return 0;
+
+ 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);
+ sv = sv_newmortal();
+ mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
+ HeVAL(entry) = sv;
+ HeKEY(entry) = (char*)SvREFCNT_inc(keysv);
+ return entry;
+ }
+
+ key = SvPV(keysv, klen);
+
+ if (!hash)
+ PERL_HASH(hash, key, klen);
+
+ if (!xhv->xhv_array) {
+ if (lval
+ #ifdef DYNAMIC_ENV_FETCH /* if it's an %ENV lookup, we may get it on the fly */
+ || (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME))
+ #endif
+ )
+ Newz(503,xhv->xhv_array, sizeof(HE*) * (xhv->xhv_max + 1), char);
+ else
+ return 0;
+ }
+
+ 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? */
+ continue;
+ return entry;
+ }
+ #ifdef DYNAMIC_ENV_FETCH /* %ENV lookup? If so, try to fetch the value now */
+ if (HvNAME(hv) && strEQ(HvNAME(hv),ENV_HV_NAME)) {
+ char *gotenv;
+
+ gotenv = my_getenv(key);
+ if (gotenv != NULL) {
+ sv = newSVpv(gotenv,strlen(gotenv));
+ return hv_store_ent(hv,keysv,sv,hash);
+ }
+ }
+ #endif
+ if (lval) { /* gonna assign to this, so it better be there */
+ sv = NEWSV(61,0);
+ return hv_store_ent(hv,keysv,sv,hash);
+ }
+ return 0;
+ }
+
SV**
hv_store(hv,key,klen,val,hash)
HV *hv;
***************
*** 136,142 ****
register U32 hash;
{
register XPVHV* xhv;
- register char *s;
register I32 i;
register HE *entry;
register HE **oentry;
--- 212,217 ----
***************
*** 156,192 ****
return 0;
#endif /* OVERLOAD */
}
! if (!hash) {
! i = klen;
! s = key;
! while (i--)
! hash = hash * 33 + *s++;
}
if (!xhv->xhv_array)
Newz(505, xhv->xhv_array, sizeof(HE**) * (xhv->xhv_max + 1), char);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
i = 1;
! for (entry = *oentry; entry; i=0, entry = entry->hent_next) {
! if (entry->hent_hash != hash) /* strings can't be equal */
continue;
! if (entry->hent_klen != klen)
continue;
! if (bcmp(entry->hent_key,key,klen)) /* is this it? */
continue;
! SvREFCNT_dec(entry->hent_val);
! entry->hent_val = val;
! return &entry->hent_val;
}
entry = new_he();
! entry->hent_klen = klen;
! entry->hent_key = savepvn(key,klen);
! entry->hent_val = val;
! entry->hent_hash = hash;
! entry->hent_next = *oentry;
*oentry = entry;
xhv->xhv_keys++;
--- 231,340 ----
return 0;
#endif /* OVERLOAD */
}
! if (!hash)
! PERL_HASH(hash, key, klen);
!
! if (!xhv->xhv_array)
! Newz(505, xhv->xhv_array, sizeof(HE**) * (xhv->xhv_max + 1), char);
!
! oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
! i = 1;
!
! for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
! if (HeHASH(entry) != hash) /* strings can't be equal */
! continue;
! if (HeKLEN(entry) != klen)
! continue;
! if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
! continue;
! SvREFCNT_dec(HeVAL(entry));
! HeVAL(entry) = val;
! return &HeVAL(entry);
! }
!
! entry = new_he();
! HeKLEN(entry) = klen;
! if (HvSHAREKEYS(hv))
! HeKEY(entry) = sharepvn(key, klen, hash);
! else /* gotta do the real thing */
! HeKEY(entry) = savepvn(key,klen);
! HeVAL(entry) = val;
! 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(hv);
! }
!
! return &HeVAL(entry);
! }
!
! HE *
! hv_store_ent(hv,keysv,val,hash)
! HV *hv;
! SV *keysv;
! SV *val;
! register U32 hash;
! {
! register XPVHV* xhv;
! register char *key;
! STRLEN klen;
! register I32 i;
! register HE *entry;
! register HE **oentry;
!
! if (!hv)
! return 0;
!
! xhv = (XPVHV*)SvANY(hv);
! if (SvMAGICAL(hv)) {
! 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;
! #endif /* OVERLOAD */
}
+ key = SvPV(keysv, klen);
+
+ if (!hash)
+ PERL_HASH(hash, key, klen);
+
if (!xhv->xhv_array)
Newz(505, xhv->xhv_array, sizeof(HE**) * (xhv->xhv_max + 1), char);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
i = 1;
! for (entry = *oentry; entry; i=0, entry = 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? */
continue;
! SvREFCNT_dec(HeVAL(entry));
! HeVAL(entry) = val;
! return entry;
}
entry = new_he();
! HeKLEN(entry) = klen;
! if (HvSHAREKEYS(hv))
! HeKEY(entry) = sharepvn(key, klen, hash);
! else /* gotta do the real thing */
! HeKEY(entry) = savepvn(key,klen);
! HeVAL(entry) = val;
! HeHASH(entry) = hash;
! HeNEXT(entry) = *oentry;
*oentry = entry;
xhv->xhv_keys++;
***************
*** 196,202 ****
hsplit(hv);
}
! return &entry->hent_val;
}
SV *
--- 344,350 ----
hsplit(hv);
}
! return entry;
}
SV *
***************
*** 207,215 ****
I32 flags;
{
register XPVHV* xhv;
- register char *s;
register I32 i;
! register I32 hash;
register HE *entry;
register HE **oentry;
SV *sv;
--- 355,362 ----
I32 flags;
{
register XPVHV* xhv;
register I32 i;
! register U32 hash;
register HE *entry;
register HE **oentry;
SV *sv;
***************
*** 219,224 ****
--- 366,374 ----
if (SvRMAGICAL(hv)) {
sv = *hv_fetch(hv, key, klen, TRUE);
mg_clear(sv);
+ if (mg_find(sv, 's')) {
+ return Nullsv; /* %SIG elements cannot be deleted */
+ }
if (mg_find(sv, 'p')) {
sv_unmagic(sv, 'p'); /* No longer an element */
return sv;
***************
*** 227,259 ****
xhv = (XPVHV*)SvANY(hv);
if (!xhv->xhv_array)
return Nullsv;
! i = klen;
! hash = 0;
! s = key;
! while (i--)
! hash = hash * 33 + *s++;
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
entry = *oentry;
i = 1;
! for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) {
! if (entry->hent_hash != hash) /* strings can't be equal */
continue;
! if (entry->hent_klen != klen)
continue;
! if (bcmp(entry->hent_key,key,klen)) /* is this it? */
continue;
! *oentry = entry->hent_next;
if (i && !*oentry)
xhv->xhv_fill--;
if (flags & G_DISCARD)
sv = Nullsv;
else
! sv = sv_mortalcopy(entry->hent_val);
if (entry == xhv->xhv_eiter)
! entry->hent_klen = -1;
else
! he_free(entry);
--xhv->xhv_keys;
return sv;
}
--- 377,468 ----
xhv = (XPVHV*)SvANY(hv);
if (!xhv->xhv_array)
return Nullsv;
!
! PERL_HASH(hash, key, klen);
oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
entry = *oentry;
i = 1;
! for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
! if (HeHASH(entry) != hash) /* strings can't be equal */
continue;
! if (HeKLEN(entry) != klen)
continue;
! if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
continue;
! *oentry = HeNEXT(entry);
if (i && !*oentry)
xhv->xhv_fill--;
if (flags & G_DISCARD)
sv = Nullsv;
else
! sv = sv_mortalcopy(HeVAL(entry));
if (entry == xhv->xhv_eiter)
! HeKLEN(entry) = HEf_LAZYDEL;
else
! he_free(entry, HvSHAREKEYS(hv));
! --xhv->xhv_keys;
! return sv;
! }
! return Nullsv;
! }
!
! SV *
! hv_delete_ent(hv,keysv,flags,hash)
! HV *hv;
! SV *keysv;
! I32 flags;
! U32 hash;
! {
! register XPVHV* xhv;
! register I32 i;
! register char *key;
! STRLEN klen;
! register HE *entry;
! register HE **oentry;
! SV *sv;
!
! if (!hv)
! return Nullsv;
! if (SvRMAGICAL(hv)) {
! entry = hv_fetch_ent(hv, keysv, TRUE, hash);
! sv = HeVAL(entry);
! mg_clear(sv);
! if (mg_find(sv, 'p')) {
! sv_unmagic(sv, 'p'); /* No longer an element */
! return sv;
! }
! }
! xhv = (XPVHV*)SvANY(hv);
! if (!xhv->xhv_array)
! return Nullsv;
!
! key = SvPV(keysv, klen);
!
! if (!hash)
! PERL_HASH(hash, key, klen);
!
! oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
! entry = *oentry;
! i = 1;
! for (; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
! if (HeHASH(entry) != hash) /* strings can't be equal */
! continue;
! if (HeKLEN(entry) != klen)
! continue;
! if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
! continue;
! *oentry = HeNEXT(entry);
! if (i && !*oentry)
! xhv->xhv_fill--;
! if (flags & G_DISCARD)
! sv = Nullsv;
! else
! sv = sv_mortalcopy(HeVAL(entry));
! if (entry == xhv->xhv_eiter)
! HeKLEN(entry) = HEf_LAZYDEL;
! else
! he_free(entry, HvSHAREKEYS(hv));
--xhv->xhv_keys;
return sv;
}
***************
*** 267,275 ****
U32 klen;
{
register XPVHV* xhv;
! register char *s;
! register I32 i;
! register I32 hash;
register HE *entry;
SV *sv;
--- 476,482 ----
U32 klen;
{
register XPVHV* xhv;
! register U32 hash;
register HE *entry;
SV *sv;
***************
*** 289,307 ****
if (!xhv->xhv_array)
return 0;
! i = klen;
! hash = 0;
! s = key;
! while (i--)
! hash = hash * 33 + *s++;
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
! for (; entry; entry = entry->hent_next) {
! if (entry->hent_hash != hash) /* strings can't be equal */
continue;
! if (entry->hent_klen != klen)
continue;
! if (bcmp(entry->hent_key,key,klen)) /* is this it? */
continue;
return TRUE;
}
--- 496,556 ----
if (!xhv->xhv_array)
return 0;
! PERL_HASH(hash, key, klen);
!
! entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
! for (; entry; entry = HeNEXT(entry)) {
! if (HeHASH(entry) != hash) /* strings can't be equal */
! continue;
! if (HeKLEN(entry) != klen)
! continue;
! if (bcmp(HeKEY(entry),key,klen)) /* is this it? */
! continue;
! return TRUE;
! }
! return FALSE;
! }
!
!
! bool
! hv_exists_ent(hv,keysv,hash)
! HV *hv;
! SV *keysv;
! U32 hash;
! {
! register XPVHV* xhv;
! register char *key;
! STRLEN klen;
! register HE *entry;
! SV *sv;
!
! if (!hv)
! return 0;
!
! if (SvRMAGICAL(hv)) {
! if (mg_find((SV*)hv,'P')) {
! sv = sv_newmortal();
! mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
! magic_existspack(sv, mg_find(sv, 'p'));
! return SvTRUE(sv);
! }
! }
!
! xhv = (XPVHV*)SvANY(hv);
! if (!xhv->xhv_array)
! return 0;
!
! key = SvPV(keysv, klen);
! if (!hash)
! PERL_HASH(hash, key, klen);
entry = ((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
! for (; entry; entry = 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? */
continue;
return TRUE;
}
***************
*** 357,372 ****
continue;
b = a+oldsize;
for (oentry = a, entry = *a; entry; entry = *oentry) {
! if ((entry->hent_hash & newsize) != i) {
! *oentry = entry->hent_next;
! entry->hent_next = *b;
if (!*b)
xhv->xhv_fill++;
*b = entry;
continue;
}
else
! oentry = &entry->hent_next;
}
if (!*a) /* everything moved */
xhv->xhv_fill--;
--- 606,621 ----
continue;
b = a+oldsize;
for (oentry = a, entry = *a; entry; entry = *oentry) {
! if ((HeHASH(entry) & newsize) != i) {
! *oentry = HeNEXT(entry);
! HeNEXT(entry) = *b;
if (!*b)
xhv->xhv_fill++;
*b = entry;
continue;
}
else
! oentry = &HeNEXT(entry);
}
if (!*a) /* everything moved */
xhv->xhv_fill--;
***************
*** 384,389 ****
--- 633,641 ----
xhv = (XPVHV*)SvANY(hv);
SvPOK_off(hv);
SvNOK_off(hv);
+ #ifndef NODEFAULT_SHAREKEYS
+ HvSHAREKEYS_on(hv); /* key-sharing on by default */
+ #endif
xhv->xhv_max = 7; /* start with 8 buckets */
xhv->xhv_fill = 0;
xhv->xhv_pmroot = 0;
***************
*** 392,415 ****
}
void
! he_free(hent)
register HE *hent;
{
if (!hent)
return;
! SvREFCNT_dec(hent->hent_val);
! Safefree(hent->hent_key);
del_he(hent);
}
void
! he_delayfree(hent)
register HE *hent;
{
if (!hent)
return;
! sv_2mortal(hent->hent_val); /* free between statements */
! Safefree(hent->hent_key);
del_he(hent);
}
--- 644,679 ----
}
void
! he_free(hent, shared)
register HE *hent;
+ 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));
! else
! Safefree(HeKEY(hent));
del_he(hent);
}
void
! he_delayfree(hent, shared)
register HE *hent;
+ 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));
! else
! Safefree(HeKEY(hent));
del_he(hent);
}
***************
*** 440,445 ****
--- 704,710 ----
register HE *ohent = Null(HE*);
I32 riter;
I32 max;
+ I32 shared;
if (!hv)
return;
***************
*** 450,460 ****
max = HvMAX(hv);
array = HvARRAY(hv);
hent = array[0];
for (;;) {
if (hent) {
ohent = hent;
! hent = hent->hent_next;
! he_free(ohent);
}
if (!hent) {
if (++riter > max)
--- 715,726 ----
max = HvMAX(hv);
array = HvARRAY(hv);
hent = array[0];
+ shared = HvSHAREKEYS(hv);
for (;;) {
if (hent) {
ohent = hent;
! hent = HeNEXT(hent);
! he_free(ohent, shared);
}
if (!hent) {
if (++riter > max)
***************
*** 494,501 ****
{
register XPVHV* xhv = (XPVHV*)SvANY(hv);
HE *entry = xhv->xhv_eiter;
! if (entry && entry->hent_klen < 0) /* was deleted earlier? */
! he_free(entry);
xhv->xhv_riter = -1;
xhv->xhv_eiter = Null(HE*);
return xhv->xhv_fill;
--- 760,767 ----
{
register XPVHV* xhv = (XPVHV*)SvANY(hv);
HE *entry = xhv->xhv_eiter;
! if (entry && HeKLEN(entry) == HEf_LAZYDEL) /* was deleted earlier? */
! he_free(entry, HvSHAREKEYS(hv));
xhv->xhv_riter = -1;
xhv->xhv_eiter = Null(HE*);
return xhv->xhv_fill;
***************
*** 517,541 ****
if (SvRMAGICAL(hv) && (mg = mg_find((SV*)hv,'P'))) {
SV *key = sv_newmortal();
! if (entry) {
! sv_usepvn(key, entry->hent_key, entry->hent_klen);
! entry->hent_key = 0;
! }
else {
! xhv->xhv_eiter = entry = new_he();
Zero(entry, 1, HE);
}
magic_nextpack((SV*) hv,mg,key);
if (SvOK(key)) {
! STRLEN len;
! entry->hent_key = SvPV_force(key, len);
! entry->hent_klen = len;
! SvPOK_off(key);
! SvPVX(key) = 0;
! return entry;
}
! if (entry->hent_val)
! SvREFCNT_dec(entry->hent_val);
del_he(entry);
xhv->xhv_eiter = Null(HE*);
return Null(HE*);
--- 783,803 ----
if (SvRMAGICAL(hv) && (mg = mg_find((SV*)hv,'P'))) {
SV *key = sv_newmortal();
! if (entry)
! sv_setsv(key, HeSVKEY_force(entry));
else {
! xhv->xhv_eiter = entry = new_he(); /* only one HE per MAGICAL hash */
Zero(entry, 1, HE);
+ 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 */
}
! if (HeVAL(entry))
! SvREFCNT_dec(HeVAL(entry));
del_he(entry);
xhv->xhv_eiter = Null(HE*);
return Null(HE*);
***************
*** 543,563 ****
if (!xhv->xhv_array)
Newz(506,xhv->xhv_array, sizeof(HE*) * (xhv->xhv_max + 1), char);
! do {
! if (entry)
! entry = entry->hent_next;
! if (!entry) {
! ++xhv->xhv_riter;
! if (xhv->xhv_riter > xhv->xhv_max) {
! xhv->xhv_riter = -1;
! break;
! }
! entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
}
! } while (!entry);
! if (oldentry && oldentry->hent_klen < 0) /* was deleted earlier? */
! he_free(oldentry);
xhv->xhv_eiter = entry;
return entry;
--- 805,823 ----
if (!xhv->xhv_array)
Newz(506,xhv->xhv_array, sizeof(HE*) * (xhv->xhv_max + 1), char);
! if (entry)
! entry = HeNEXT(entry);
! while (!entry) {
! ++xhv->xhv_riter;
! if (xhv->xhv_riter > xhv->xhv_max) {
! xhv->xhv_riter = -1;
! break;
}
! entry = ((HE**)xhv->xhv_array)[xhv->xhv_riter];
! }
! if (oldentry && HeKLEN(oldentry) == HEf_LAZYDEL) /* was deleted earlier? */
! he_free(oldentry, HvSHAREKEYS(hv));
xhv->xhv_eiter = entry;
return entry;
***************
*** 568,575 ****
register HE *entry;
I32 *retlen;
{
! *retlen = entry->hent_klen;
! return entry->hent_key;
}
SV *
--- 828,852 ----
register HE *entry;
I32 *retlen;
{
! if (HeKLEN(entry) == HEf_SVKEY) {
! return SvPV((SV*)HeKEY(entry), *(STRLEN*)retlen);
! }
! else {
! *retlen = HeKLEN(entry);
! return HeKEY(entry);
! }
! }
!
! /* unlike hv_iterval(), this always returns a mortal copy of the key */
! SV *
! hv_iterkeysv(entry)
! register HE *entry;
! {
! if (HeKLEN(entry) == HEf_SVKEY)
! return sv_mortalcopy((SV*)HeKEY(entry));
! else
! return sv_2mortal(newSVpv((HeKLEN(entry) ? HeKEY(entry) : ""),
! HeKLEN(entry)));
}
SV *
***************
*** 580,590 ****
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv,'P')) {
SV* sv = sv_newmortal();
! mg_copy((SV*)hv, sv, entry->hent_key, entry->hent_klen);
return sv;
}
}
! return entry->hent_val;
}
SV *
--- 857,867 ----
if (SvRMAGICAL(hv)) {
if (mg_find((SV*)hv,'P')) {
SV* sv = sv_newmortal();
! mg_copy((SV*)hv, sv, HeKEY(entry), HeKLEN(entry));
return sv;
}
}
! return HeVAL(entry);
}
SV *
***************
*** 608,610 ****
--- 885,988 ----
{
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.
+ * len and hash must both be valid for str.
+ */
+ char *
+ sharepvn(str, len, hash)
+ char *str;
+ I32 len;
+ register U32 hash;
+ {
+ register XPVHV* xhv;
+ register HE *entry;
+ register HE **oentry;
+ register I32 i = 1;
+ I32 found = 0;
+
+ /* what follows is the moral equivalent of:
+
+ if (!(Svp = hv_fetch(strtab, str, len, FALSE)))
+ hv_store(strtab, str, len, Nullsv, hash);
+ */
+ xhv = (XPVHV*)SvANY(strtab);
+ /* assert(xhv_array != 0) */
+ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ for (entry = *oentry; entry; i=0, entry = HeNEXT(entry)) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != len)
+ continue;
+ if (bcmp(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);
+ }
+ }
+
+ ++HeVAL(entry); /* use value slot as REFCNT */
+ return HeKEY(entry);
+ }
+
+ /* possibly free a shared string if no one has access to it
+ * len and hash must both be valid for str.
+ */
+ void
+ unsharepvn(str, len, hash)
+ char *str;
+ I32 len;
+ register U32 hash;
+ {
+ register XPVHV* xhv;
+ register HE *entry;
+ register HE **oentry;
+ register I32 i = 1;
+ I32 found = 0;
+
+ /* what follows is the moral equivalent of:
+ if ((Svp = hv_fetch(strtab, tmpsv, FALSE, hash))) {
+ if (--*Svp == Nullsv)
+ hv_delete(strtab, str, len, G_DISCARD, hash);
+ } */
+ xhv = (XPVHV*)SvANY(strtab);
+ /* assert(xhv_array != 0) */
+ oentry = &((HE**)xhv->xhv_array)[hash & (I32) xhv->xhv_max];
+ for (entry = *oentry; entry; i=0, oentry = &HeNEXT(entry), entry = *oentry) {
+ if (HeHASH(entry) != hash) /* strings can't be equal */
+ continue;
+ if (HeKLEN(entry) != len)
+ continue;
+ if (bcmp(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");
+ }
+
#~ Add shared hash key support
diff -Pcr perl5_003/hv.h perl5_003_01/hv.h
*** perl5_003/hv.h Tue Oct 18 12:20:08 1994
--- perl5_003_01/hv.h Thu Jun 20 09:12:08 1996
***************
*** 32,37 ****
--- 32,54 ----
char *xhv_name; /* name, if a symbol table */
};
+ #define PERL_HASH(hash,str,len) \
+ STMT_START { \
+ register char *s_PeRlHaSh = str; \
+ register I32 i_PeRlHaSh = len; \
+ register U32 hash_PeRlHaSh = 0; \
+ while (i_PeRlHaSh--) \
+ hash_PeRlHaSh = hash_PeRlHaSh * 33 + *s_PeRlHaSh++; \
+ (hash) = hash_PeRlHaSh; \
+ } STMT_END
+
+
+ /* these hash entry flags ride on hent_klen */
+
+ #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) */
+
+
#define Nullhv Null(HV*)
#define HvARRAY(hv) ((HE**)((XPVHV*) SvANY(hv))->xhv_array)
#define HvFILL(hv) ((XPVHV*) SvANY(hv))->xhv_fill
***************
*** 42,47 ****
--- 59,68 ----
#define HvPMROOT(hv) ((XPVHV*) SvANY(hv))->xhv_pmroot
#define HvNAME(hv) ((XPVHV*) SvANY(hv))->xhv_name
+ #define HvSHAREKEYS(hv) (SvFLAGS(hv) & SVphv_SHAREKEYS)
+ #define HvSHAREKEYS_on(hv) (SvFLAGS(hv) |= SVphv_SHAREKEYS)
+ #define HvSHAREKEYS_off(hv) (SvFLAGS(hv) &= ~SVphv_SHAREKEYS)
+
#ifdef OVERLOAD
/* Maybe amagical: */
***************
*** 58,60 ****
--- 79,101 ----
*/
#endif /* OVERLOAD */
+
+ #define Nullhe Null(HE*)
+ #define HeNEXT(he) (he)->hent_next
+ #define HeKEY(he) (he)->hent_key
+ #define HeKLEN(he) (he)->hent_klen
+ #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))) : \
+ &sv_undef)
#~ Put cppstdin in architecture-dependent directory
#~ Make sure file permissions are set correctly on CORE headers and libperl
diff -Pcr perl5_003/installperl perl5_003_01/installperl
*** perl5_003/installperl Mon Jun 24 16:08:25 1996
--- perl5_003_01/installperl Fri Jul 5 17:40:23 1996
***************
*** 16,23 ****
umask 022;
! @scripts = qw(cppstdin
! utils/c2ph utils/h2ph utils/h2xs utils/pstruct
utils/perlbug utils/perldoc
x2p/s2p x2p/find2perl
pod/pod2man pod/pod2html pod/pod2latex pod/pod2text);
--- 16,22 ----
umask 022;
! @scripts = qw( utils/c2ph utils/h2ph utils/h2xs utils/pstruct
utils/perlbug utils/perldoc
x2p/s2p x2p/find2perl
pod/pod2man pod/pod2html pod/pod2latex pod/pod2text);
***************
*** 109,123 ****
&chmod(0755, "$installbin/a2p$exe_ext");
}
# Install scripts.
mkpath($installscript, 1, 0777);
for (@scripts) {
! if (-f $_) { # cppstdin might not exist on this system.
! &cmd("cp $_ $installscript");
! s#.*/##; &chmod(0755, "$installscript/$_");
! }
}
# Install pod pages. Where? I guess in $installprivlib/pod.
--- 108,130 ----
&chmod(0755, "$installbin/a2p$exe_ext");
}
+ # cppstdin is just a script, but it is architecture-dependent, so
+ # it can't safely be shared. Place it in $installbin.
+ # Note that Configure doesn't build cppstin if it isn't needed, so
+ # we skip this if cppstdin doesn't exist.
+ if ((-f cppstdin) && (! &samepath($installbin, '.'))) {
+ &safe_unlink("$installbin/cppstdin");
+ &cmd("cp cppstdin $installbin/cppstdin");
+ &chmod(0755, "$installbin/cppstdin");
+ }
+
# Install scripts.
mkpath($installscript, 1, 0777);
for (@scripts) {
! &cmd("cp $_ $installscript");
! s#.*/##; &chmod(0755, "$installscript/$_");
}
# Install pod pages. Where? I guess in $installprivlib/pod.
***************
*** 175,190 ****
# Install header files and libraries.
mkpath("$installarchlib/CORE", 1, 0777);
! foreach $file (<*.h libperl*.*>) {
! cp_if_diff($file,"$installarchlib/CORE/$file");
! &chmod(0444,"$installarchlib/CORE/$file");
! }
# AIX needs perl.exp installed as well.
! cp_if_diff("perl.exp" ,"$installarchlib/CORE/perl.exp") if ($^O eq 'aix');
!
# If they have built sperl.o...
! cp_if_diff("sperl.o" ,"$installarchlib/CORE/sperl.o") if (-f 'sperl.o');
!
# Offer to install perl in a "standard" location
--- 182,196 ----
# Install header files and libraries.
mkpath("$installarchlib/CORE", 1, 0777);
! @corefiles = <*.h libperl*.*>;
# AIX needs perl.exp installed as well.
! push(@corefiles,'perl.exp') if $^O eq 'aix';
# If they have built sperl.o...
! push(@corefiles,'sperl.o') if -f 'sperl.o';
! foreach $file (@corefiles) {
! cp_if_diff($file,"$installarchlib/CORE/$file");
! &chmod($file =~ /^libperl/ ? 0555 : 0444,"$installarchlib/CORE/$file");
! }
# Offer to install perl in a "standard" location
#~ Adjust per-interpreter symbols
diff -Pcr perl5_003/interp.sym perl5_003_01/interp.sym
*** perl5_003/interp.sym Fri Jan 26 18:55:16 1996
--- perl5_003_01/interp.sym Fri Jul 5 19:13:37 1996
***************
*** 18,25 ****
--- 18,27 ----
copline
curblock
curcop
+ curcopdb
curcsv
curpm
+ curstack
curstash
curstname
cxstack
***************
*** 71,76 ****
--- 73,79 ----
leftgv
lineary
localizing
+ localpatches
main_cv
main_root
main_start
***************
*** 101,108 ****
origfilename
ors
orslen
- pad
- padname
parsehook
patchlevel
perldb
--- 104,109 ----
***************
*** 128,140 ****
sortstack
sortstash
splitstr
- stack
statcache
statgv
statname
statusvalue
stdingv
strchop
sv_count
sv_objcount
sv_root
--- 129,141 ----
sortstack
sortstash
splitstr
statcache
statgv
statname
statusvalue
stdingv
strchop
+ strtab
sv_count
sv_objcount
sv_root
#~ Quote string argument in example -- necessary if using strict subs
diff -Pcr perl5_003/lib/AnyDBM_File.pm perl5_003_01/lib/AnyDBM_File.pm
*** perl5_003/lib/AnyDBM_File.pm Wed Jun 7 19:48:04 1995
--- perl5_003_01/lib/AnyDBM_File.pm Mon Jul 15 13:35:56 1996
***************
*** 39,46 ****
Having multiple DBM implementations makes it trivial to copy database formats:
use POSIX; use NDBM_File; use DB_File;
! tie %newhash, DB_File, $new_filename, O_CREAT|O_RDWR;
! tie %oldhash, NDBM_File, $old_filename, 1, 0;
%newhash = %oldhash;
=head2 DBM Comparisons
--- 39,46 ----
Having multiple DBM implementations makes it trivial to copy database formats:
use POSIX; use NDBM_File; use DB_File;
! tie %newhash, 'DB_File', $new_filename, O_CREAT|O_RDWR;
! tie %oldhash, 'NDBM_File', $old_filename, 1, 0;
%newhash = %oldhash;
=head2 DBM Comparisons
#~ Update documentation
diff -Pcr perl5_003/lib/AutoLoader.pm perl5_003_01/lib/AutoLoader.pm
*** perl5_003/lib/AutoLoader.pm Mon Feb 12 14:53:59 1996
--- perl5_003_01/lib/AutoLoader.pm Thu Jul 11 12:17:27 1996
***************
*** 15,22 ****
=head1 DESCRIPTION
! This module tells its users that functions in the FOOBAR package are to be
! autoloaded from F<auto/$AUTOLOAD.al>. See L<perlsub/"Autoloading">.
=cut
--- 15,73 ----
=head1 DESCRIPTION
! This module tells its users that functions in the FOOBAR package are
! to be autoloaded from F<auto/$AUTOLOAD.al>. See
! L<perlsub/"Autoloading"> and L<AutoSplit>.
!
! =head2 __END__
!
! The module using the autoloader should have the special marker C<__END__>
! prior to the actual subroutine declarations. All code that is before the
! marker will be loaded and compiled when the module is used. At the marker,
! perl will cease reading and parsing. See also the B<AutoSplit> module, a
! utility that automatically splits a module into a collection of files for
! autoloading.
!
! When a subroutine not yet in memory is called, the C<AUTOLOAD> function
! attempts to locate it in a directory relative to the location of the module
! file itself. As an example, assume F<POSIX.pm> is located in
! 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 Package Lexicals
!
! Package lexicals declared with C<my> in the main block of a package using
! the B<AutoLoader> will not be visible to auto-loaded functions, due to the
! fact that the given scope ends at the C<__END__> marker. A module using such
! variables as package globals will not work properly under the B<AutoLoader>.
!
! The C<vars> pragma (see L<perlmod/"vars">) may be used in such situations
! as an alternative to explicitly qualifying all globals with the package
! namespace. Variables pre-declared with this pragma will be visible to any
! autoloaded routines (but will not be invisible outside the package,
! unfortunately).
!
! =head2 AutoLoader vs. SelfLoader
!
! The B<AutoLoader> is a counterpart to the B<SelfLoader> module. Both delay
! the loading of subroutines, but the B<SelfLoader> accomplishes the goal via
! the C<__DATA__> marker rather than C<__END__>. While this avoids the use of
! a hierarchy of disk files and the associated open/close for each routine
! loaded, the B<SelfLoader> suffers a disadvantage in the one-time parsing of
! the lines after C<__DATA__>, after which routines are cached. B<SelfLoader>
! can also handle multiple packages in a file.
!
! B<AutoLoader> only reads code as it is requested, and in many cases should be
! faster, but requires a machanism like B<AutoSplit> be used to create the
! individual files.
!
! =head1 CAVEAT
!
! On systems with restrictions on file name length, the file corresponding to a
! subroutine may have a shorter name that the routine itself. This can lead to
! conflicting file names. The I<AutoSplit> package warns of these potential
! conflicts when used to split a module.
=cut
#~ Update documentation
diff -Pcr perl5_003/lib/AutoSplit.pm perl5_003_01/lib/AutoSplit.pm
*** perl5_003/lib/AutoSplit.pm Mon Mar 25 01:04:11 1996
--- perl5_003_01/lib/AutoSplit.pm Thu Jul 11 12:21:48 1996
***************
*** 16,29 ****
=head1 SYNOPSIS
! perl -e 'use AutoSplit; autosplit_modules(@ARGV)' ...
=head1 DESCRIPTION
This function will split up your program into files that the AutoLoader
! module can handle. Normally only used to build autoloading Perl library
! modules, especially extensions (like POSIX). You should look at how
! they're built out for details.
=cut
--- 16,96 ----
=head1 SYNOPSIS
! perl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
!
! use AutoSplit; autosplit($file, $dir, $keep, $check, $modtime);
!
! for perl versions 5.002 and later:
!
! perl -MAutoSplit -e 'autosplit($ARGV[0], $ARGV[1], $k, $chk, $modtime)' ...
=head1 DESCRIPTION
This function will split up your program into files that the AutoLoader
! module can handle. It is used by both the standard perl libraries and by
! the MakeMaker utility, to automatically configure libraries for autoloading.
!
! The C<autosplit> interface splits the specified file into a hierarchy
! rooted at the directory C<$dir>. It creates directories as needed to reflect
! class hierarchy, and creates the file F<autosplit.ix>. This file acts as
! both forward declaration of all package routines, and as timestamp for the
! last update of the hierarchy.
!
! The remaining three arguments to C<autosplit> govern other options to the
! autosplitter. If the third argument, I<$keep>, is false, then any pre-existing
! C<.al> files in the autoload directory are removed if they are no longer
! part of the module (obsoleted functions). The fourth argument, I<$check>,
! instructs C<autosplit> to check the module currently being split to ensure
! that it does include a C<use> specification for the AutoLoader module, and
! skips the module if AutoLoader is not detected. Lastly, the I<$modtime>
! argument specifies that C<autosplit> is to check the modification time of the
! module against that of the C<autosplit.ix> file, and only split the module
! if it is newer.
!
! Typical use of AutoSplit in the perl MakeMaker utility is via the command-line
! with:
!
! perl -e 'use AutoSplit; autosplit($ARGV[0], $ARGV[1], 0, 1, 1)'
!
! Defined as a Make macro, it is invoked with file and directory arguments;
! C<autosplit> will split the specified file into the specified directory and
! delete obsolete C<.al> files, after checking first that the module does use
! the AutoLoader, and ensuring that the module is not already currently split
! in its current form (the modtime test).
!
! The C<autosplit_lib_modules> form is used in the building of perl. It takes
! as input a list of files (modules) that are assumed to reside in a directory
! B<lib> relative to the current directory. Each file is sent to the
! autosplitter one at a time, to be split into the directory B<lib/auto>.
!
! In both usages of the autosplitter, only subroutines defined following the
! perl special marker I<__END__> are split out into separate files. Some
! routines may be placed prior to this marker to force their immediate loading
! and parsing.
!
! =head1 CAVEATS
!
! Currently, C<AutoSplit> cannot handle multiple package specifications
! within one file.
!
! =head1 DIAGNOSTICS
!
! C<AutoSplit> will inform the user if it is necessary to create the top-level
! directory specified in the invocation. It is preferred that the script or
! installation process that invokes C<AutoSplit> have created the full directory
! path ahead of time. This warning may indicate that the module is being split
! into an incorrect path.
!
! C<AutoSplit> will warn the user of all subroutines whose name causes potential
! file naming conflicts on machines with drastically limited (8 characters or
! less) file name length. Since the subroutine name is used as the file name,
! these warnings can aid in portability to such systems.
!
! Warnings are issued and the file skipped if C<AutoSplit> cannot locate either
! the I<__END__> marker or a "package Name;"-style specification.
!
! C<AutoSplit> will also emit general diagnostics for inability to create
! directories or files.
=cut
***************
*** 53,59 ****
# This function is used during perl building/installation
! # ./miniperl -e 'use AutoSplit; autosplit_modules(@ARGV)' ...
sub autosplit_lib_modules{
my(@modules) = @_; # list of Module names
--- 120,126 ----
# This function is used during perl building/installation
! # ./miniperl -e 'use AutoSplit; autosplit_lib_modules(@ARGV)' ...
sub autosplit_lib_modules{
my(@modules) = @_; # list of Module names
#~ Eliminate $& to avoid runtime penalty
#~ Consider @ISA when tracing call stack
diff -Pcr perl5_003/lib/Carp.pm perl5_003_01/lib/Carp.pm
*** perl5_003/lib/Carp.pm Wed Jan 31 13:56:10 1996
--- perl5_003_01/lib/Carp.pm Thu Jul 25 15:24:34 1996
***************
*** 47,53 ****
if ($require) {
$sub = "require $eval";
} else {
! $eval =~ s/[\\\']/\\$&/g;
if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
substr($eval,$MaxEvalLen) = '...';
}
--- 47,53 ----
if ($require) {
$sub = "require $eval";
} else {
! $eval =~ s/([\\\'])/\\$1/g;
if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
substr($eval,$MaxEvalLen) = '...';
}
***************
*** 66,85 ****
sub shortmess { # Short-circuit &longmess if called via multiple packages
my $error = $_[0]; # Instead of "shift"
! my ($curpack) = caller(1);
my $extra = $CarpLevel;
my $i = 2;
my ($pack,$file,$line);
while (($pack,$file,$line) = caller($i++)) {
! if ($pack ne $curpack) {
! if ($extra-- > 0) {
! $curpack = $pack;
! }
! else {
! return "$error at $file line $line\n";
! }
}
}
goto &longmess;
}
--- 66,105 ----
sub shortmess { # Short-circuit &longmess if called via multiple packages
my $error = $_[0]; # Instead of "shift"
! my ($prevpack) = caller(1);
my $extra = $CarpLevel;
my $i = 2;
my ($pack,$file,$line);
+ my %isa = ($prevpack,1);
+
+ @isa{@{"${prevpack}::ISA"}} = ()
+ if(defined @{"${prevpack}::ISA"});
+
while (($pack,$file,$line) = caller($i++)) {
! if(defined @{$pack . "::ISA"}) {
! my @i = @{$pack . "::ISA"};
! my %i;
! @i{@i} = ();
! @isa{@i,$pack} = ()
! if(exists $i{$prevpack} || exists $isa{$pack});
! }
!
! next
! if(exists $isa{$pack});
!
! if ($extra-- > 0) {
! %isa = ($pack,1);
! @isa{@{$pack . "::ISA"}} = ()
! if(defined @{$pack . "::ISA"});
! }
! else {
! return "$error at $file line $line\n";
}
}
+ continue {
+ $prevpack = $pack;
+ }
+
goto &longmess;
}
#~ Don't reduce '/' to empty string
#~ Improved support for Win32
diff -Pcr perl5_003/lib/Cwd.pm perl5_003_01/lib/Cwd.pm
*** perl5_003/lib/Cwd.pm Mon Mar 25 01:04:12 1996
--- perl5_003_01/lib/Cwd.pm Wed May 15 19:17:04 1996
***************
*** 121,127 ****
$cwd = "$dir/$cwd";
closedir(PARENT);
} while ($dir);
! chop($cwd); # drop the trailing /
$cwd;
}
--- 121,127 ----
$cwd = "$dir/$cwd";
closedir(PARENT);
} while ($dir);
! chop($cwd) unless $cwd eq '/'; # drop the trailing /
$cwd;
}
***************
*** 246,257 ****
*fastcwd = \&_vms_cwd;
*fastgetcwd = \&_vms_cwd;
}
! elsif ($^O eq 'NT') {
! *getcwd = \&cwd;
! *fastgetcwd = \&cwd;
}
elsif ($^O eq 'os2') {
*cwd = \&_os2_cwd;
*getcwd = \&_os2_cwd;
*fastgetcwd = \&_os2_cwd;
--- 246,260 ----
*fastcwd = \&_vms_cwd;
*fastgetcwd = \&_vms_cwd;
}
! elsif ($^O eq 'NT' or $^O eq 'MSWin32') {
! # We assume that &_NT_cwd is defined as an XSUB or in the core.
! *getcwd = \&_NT_cwd;
! *fastcwd = \&_NT_cwd;
! *fastgetcwd = \&_NT_cwd;
}
elsif ($^O eq 'os2') {
+
*cwd = \&_os2_cwd;
*getcwd = \&_os2_cwd;
*fastgetcwd = \&_os2_cwd;
#~ Add version check option
diff -Pcr perl5_003/lib/Exporter.pm perl5_003_01/lib/Exporter.pm
*** perl5_003/lib/Exporter.pm Mon Feb 12 14:54:12 1996
--- perl5_003_01/lib/Exporter.pm Tue Jun 18 22:03:00 1996
***************
*** 91,96 ****
--- 91,102 ----
@imports = @exports;
last;
}
+ # We need a way to emulate 'use Foo ()' but still
+ # allow an easy version check: "use Foo 1.23, ''";
+ if (@imports == 2 and !$imports[1]) {
+ @imports = ();
+ last;
+ }
} elsif ($sym !~ s/^&// || !$exports{$sym}) {
warn qq["$sym" is not exported by the $pkg module];
$oops++;
***************
*** 176,184 ****
sub require_version {
my($self, $wanted) = @_;
my $pkg = ref $self || $self;
! my $version = ${"${pkg}::VERSION"} || "(undef)";
! Carp::croak("$pkg $wanted required--this is only version $version")
! if $version < $wanted;
$version;
}
--- 182,194 ----
sub require_version {
my($self, $wanted) = @_;
my $pkg = ref $self || $self;
! my $version = ${"${pkg}::VERSION"};
! if (!$version or $version < $wanted) {
! $version ||= "(undef)";
! my $file = $INC{"$pkg.pm"};
! $file &&= " ($file)";
! Carp::croak("$pkg $wanted required--this is only version $version$file")
! }
$version;
}
#~ Add ExtUtils::Embed
diff -Pcr perl5_003/lib/ExtUtils/Embed.pm perl5_003_01/lib/ExtUtils/Embed.pm
*** perl5_003/lib/ExtUtils/Embed.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/lib/ExtUtils/Embed.pm Sun Jul 21 19:26:02 1996
***************
*** 0 ****
--- 1,473 ----
+ # $Id: Embed.pm,v 1.17 1996/07/02 13:48:17 dougm Exp $
+ require 5.002;
+
+ package ExtUtils::Embed;
+ require Exporter;
+ require FileHandle;
+ use Config;
+ use Getopt::Std;
+
+ #Only when we need them
+ #require ExtUtils::MakeMaker;
+ #require ExtUtils::Liblist;
+
+ use vars qw(@ISA @EXPORT $VERSION
+ @Extensions $Verbose $lib_ext
+ $opt_o $opt_s
+ );
+ use strict;
+
+ $VERSION = sprintf("%d.%02d", q$Revision: 1.17 $ =~ /(\d+)\.(\d+)/);
+ #for the namespace change
+ $Devel::embed::VERSION = "99.99";
+
+ sub Version { $VERSION; }
+
+ @ISA = qw(Exporter);
+ @EXPORT = qw(&xsinit &ldopts
+ &ccopts &ccflags &ccdlflags &perl_inc
+ &xsi_header &xsi_protos &xsi_body);
+
+ #let's have Miniperl borrow from us instead
+ #require ExtUtils::Miniperl;
+ #*canon = \&ExtUtils::Miniperl::canon;
+
+ $Verbose = 0;
+ $lib_ext = $Config{lib_ext} || '.a';
+
+ sub xsinit {
+ my($file, $std, $mods) = @_;
+ my($fh,@mods,%seen);
+ $file ||= "perlxsi.c";
+
+ if (@_) {
+ @mods = @$mods if $mods;
+ }
+ else {
+ getopts('o:s:');
+ $file = $opt_o if defined $opt_o;
+ $std = $opt_s if defined $opt_s;
+ @mods = @ARGV;
+ }
+ $std = 1 unless scalar @mods;
+
+ if ($file eq "STDOUT") {
+ $fh = \*STDOUT;
+ }
+ else {
+ $fh = new FileHandle "> $file";
+ }
+
+ push(@mods, static_ext()) if defined $std;
+ @mods = grep(!$seen{$_}++, @mods);
+
+ print $fh &xsi_header();
+ print $fh "EXTERN_C void xs_init _((void));\n\n";
+ print $fh &xsi_protos(@mods);
+
+ print $fh "\nEXTERN_C void\nxs_init()\n{\n";
+ print $fh &xsi_body(@mods);
+ print $fh "}\n";
+
+ }
+
+ sub xsi_header {
+ return <<EOF;
+ #ifdef __cplusplus
+ extern "C" {
+ #endif
+
+ #include <EXTERN.h>
+ #include <perl.h>
+
+ #ifdef __cplusplus
+ }
+ # ifndef EXTERN_C
+ # define EXTERN_C extern "C"
+ # endif
+ #else
+ # ifndef EXTERN_C
+ # define EXTERN_C extern
+ # endif
+ #endif
+
+ EOF
+ }
+
+ sub xsi_protos {
+ my(@exts) = @_;
+ my(@retval,%seen);
+
+ foreach $_ (@exts){
+ my($pname) = canon('/', $_);
+ my($mname, $cname);
+ ($mname = $pname) =~ s!/!::!g;
+ ($cname = $pname) =~ s!/!__!g;
+ my($ccode) = "EXTERN_C void boot_${cname} _((CV* cv));\n";
+ next if $seen{$ccode}++;
+ push(@retval, $ccode);
+ }
+ return join '', @retval;
+ }
+
+ sub xsi_body {
+ my(@exts) = @_;
+ my($pname,@retval,%seen);
+ my($dl) = canon('/','DynaLoader');
+ push(@retval, "\tdXSUB_SYS;\n") if $] > 5.002;
+ push(@retval, "\tchar *file = __FILE__;\n\n");
+
+ foreach $_ (@exts){
+ my($pname) = canon('/', $_);
+ my($mname, $cname, $ccode);
+ ($mname = $pname) =~ s!/!::!g;
+ ($cname = $pname) =~ s!/!__!g;
+ if ($pname eq $dl){
+ # Must NOT install 'DynaLoader::boot_DynaLoader' as 'bootstrap'!
+ # boot_DynaLoader is called directly in DynaLoader.pm
+ $ccode = "\t/* DynaLoader is a special case */\n\tnewXS(\"${mname}::boot_${cname}\", boot_${cname}, file);\n";
+ push(@retval, $ccode) unless $seen{$ccode}++;
+ } else {
+ $ccode = "\tnewXS(\"${mname}::bootstrap\", boot_${cname}, file);\n";
+ push(@retval, $ccode) unless $seen{$ccode}++;
+ }
+ }
+ return join '', @retval;
+ }
+
+ sub static_ext {
+ unless (scalar @Extensions) {
+ @Extensions = sort split /\s+/, $Config{static_ext};
+ unshift @Extensions, qw(DynaLoader);
+ }
+ @Extensions;
+ }
+
+ sub ldopts {
+ require ExtUtils::MakeMaker;
+ require ExtUtils::Liblist;
+ my($std,$mods,$link_args,$path) = @_;
+ my(@mods,@link_args,@argv);
+ my($dllib,$config_libs,@potential_libs,@path);
+ local($") = ' ' unless $" eq ' ';
+ my $MM = bless {} => 'MY';
+ if (scalar @_) {
+ @link_args = @$link_args if $link_args;
+ @mods = @$mods if $mods;
+ }
+ else {
+ @argv = @ARGV;
+ #hmm
+ while($_ = shift @argv) {
+ /^-std$/ && do { $std = 1; next; };
+ /^--$/ && do { @link_args = @argv; last; };
+ /^-I(.*)/ && do { $path = $1 || shift @argv; next; };
+ push(@mods, $_);
+ }
+ }
+ $std = 1 unless scalar @link_args;
+ @path = $path ? split(/:/, $path) : @INC;
+
+ push(@potential_libs, @link_args) if scalar @link_args;
+ push(@potential_libs, $Config{libs}) if defined $std;
+
+ push(@mods, static_ext()) if $std;
+
+ my($mod,@ns,$root,$sub,$extra,$archive,@archives);
+ print STDERR "Searching (@path) for archives\n" if $Verbose;
+ foreach $mod (@mods) {
+ @ns = split('::', $mod);
+ $sub = $ns[-1];
+ $root = $MM->catdir(@ns);
+
+ print STDERR "searching for '$sub${lib_ext}'\n" if $Verbose;
+ foreach (@path) {
+ next unless -e ($archive = $MM->catdir($_,"auto",$root,"$sub$lib_ext"));
+ push @archives, $archive;
+ if(-e ($extra = $MM->catdir($_,"auto",$root,"extralibs.ld"))) {
+ local(*FH);
+ if(open(FH, $extra)) {
+ my($libs) = <FH>; chomp $libs;
+ push @potential_libs, split /\s+/, $libs;
+ }
+ else {
+ warn "Couldn't open '$extra'";
+ }
+ }
+ last;
+ }
+ }
+ #print STDERR "\@potential_libs = @potential_libs\n";
+
+ my($extralibs, $bsloadlibs, $ldloadlibs, $ld_run_path) =
+ $MM->ext(join ' ',
+ $MM->catdir("-L$Config{archlib}", "CORE"), " -lperl",
+ @potential_libs);
+
+ my $ld_or_bs = $bsloadlibs || $ldloadlibs;
+ print STDERR "bs: $bsloadlibs ** ld: $ldloadlibs" if $Verbose;
+ my $linkage = "$Config{ldflags} @archives $ld_or_bs";
+ print STDERR "ldopts: '$linkage'\n" if $Verbose;
+
+ return $linkage if scalar @_;
+ print "$linkage\n";
+ }
+
+ sub ccflags {
+ print " $Config{ccflags} ";
+ }
+
+ sub ccdlflags {
+ print " $Config{ccdlflags} ";
+ }
+
+ sub perl_inc {
+ print " -I $Config{archlib}/CORE ";
+ }
+
+ sub ccopts {
+ ccflags;
+ ccdlflags;
+ perl_inc;
+ }
+
+ sub canon {
+ my($as, @ext) = @_;
+ foreach(@ext) {
+ # might be X::Y or lib/auto/X/Y/Y.a
+ next if s!::!/!g;
+ s:^(lib|ext)/(auto/)?::;
+ s:/\w+\.\w+$::;
+ }
+ grep(s:/:$as:, @ext) if ($as ne '/');
+ @ext;
+ }
+
+ __END__
+
+ =head1 NAME
+
+ ExtUtils::Embed - Utilities for embedding Perl in C/C++ applications
+
+ =head1 SYNOPSIS
+
+
+ perl -MExtUtils::Embed -e xsinit
+ perl -MExtUtils::Embed -e ldopts
+
+ =head1 DESCRIPTION
+
+ ExtUtils::Embed provides utility functions for embedding a Perl interpreter
+ and extensions in your C/C++ applications.
+ Typically, an application B<Makefile> will invoke ExtUtils::Embed
+ functions while building your application.
+
+ =head1 @EXPORT
+
+ ExtUtils::Embed exports the following functions:
+
+ L<xsinit()>, L<ldopts()>, L<ccopts()>, L<perl_inc()>, L<ccflags()>,
+ L<ccdlflags()>, L<xsi_header()>, L<xsi_protos()>, L<xsi_body()>
+
+ =head1 FUNCTIONS
+
+ =item xsinit()
+
+ Generate C/C++ code for the XS intializer 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 STDOUT> will print to STDOUT.
+
+ B<-std> (Write code for extensions that are linked with the current Perl.)
+
+ Any additional arguments are expected to be names of modules
+ to generate code for.
+
+ When invoked with parameters the following are accepted and optional:
+
+ C<xsinit($filename,$std,[@modules])>
+
+ Where,
+
+ B<$filename> is equivalent to the B<-o> option.
+
+ B<$std> is boolean, equivalent to the B<-std> option.
+
+ B<[@modules]> is an array ref, same as additional arguments mentioned above.
+
+ =item Examples
+
+
+ perl -MExtUtils::Embed -e xsinit -- -o xsinit.c Socket
+
+
+ This will generate code with an B<xs_init> function that glues the perl B<Socket::bootstrap> function
+ to the C B<boot_Socket> function and writes it to a file named "xsinit.c".
+
+ Note that B<DynaLoader> is a special case where it must call B<boot_DynaLoader> directly.
+
+ perl -MExtUtils::Embed -e xsinit
+
+
+ This will generate code for linking with B<DynaLoader> and
+ each static extension found in B<$Config{static_ext}>.
+ The code is written to the default file name B<perlxsi.c>.
+
+
+ perl -MExtUtils::Embed -e xsinit -- -o xsinit.c -std DBI DBD::Oracle
+
+
+ Here, code is written for all the currently linked extensions along with code
+ for B<DBI> and B<DBD::Oracle>.
+
+ If you have a working B<DynaLoader> then there is rarely any need to statically link in any
+ other extensions.
+
+ =item ldopts()
+
+ Output arguments for linking the Perl library and extensions to your
+ application.
+
+ When invoked as C<`perl -MExtUtils::Embed -e ldopts --`>
+ the following options are recognized:
+
+ B<-std>
+
+ Output arguments for linking the Perl library and any extensions linked
+ with the current Perl.
+
+ B<-I> <path1:path2>
+
+ Search path for ModuleName.a archives.
+ Default path is B<@INC>.
+ Library archives are expected to be found as
+ B</some/path/auto/ModuleName/ModuleName.a>
+ For example, when looking for B<Socket.a> relative to a search path,
+ we should find B<auto/Socket/Socket.a>
+
+ When looking for B<DBD::Oracle> relative to a search path,
+ we should find B<auto/DBD/Oracle/Oracle.a>
+
+ Keep in mind, you can always supply B</my/own/path/ModuleName.a>
+ as an additional linker argument.
+
+ B<--> <list of linker args>
+
+ Additional linker arguments to be considered.
+
+ Any additional arguments found before the B<--> token
+ are expected to be names of modules to generate code for.
+
+ When invoked with parameters the following are accepted and optional:
+
+ C<ldopts($std,[@modules],[@link_args],$path)>
+
+ Where,
+
+ B<$std> is boolean, equivalent to the B<-std> option.
+
+ B<[@modules]> is equivalent to additional arguments found before the B<--> token.
+
+ B<[@link_args]> is equivalent to arguments found after the B<--> token.
+
+ B<$path> is equivalent to the B<-I> option.
+
+ In addition, when ldopts is called with parameters, it will return the argument string
+ rather than print it to STDOUT.
+
+ =item Examples
+
+
+ perl -MExtUtils::Embed -e ldopts
+
+
+ This will print arguments for linking with B<libperl.a>, B<DynaLoader> and
+ extensions found in B<$Config{static_ext}>. This includes libraries
+ found in B<$Config{libs}> and the first ModuleName.a library
+ for each extension that is found by searching B<@INC> or the path
+ specifed by the B<-I> option.
+ In addition, when ModuleName.a is found, additional linker arguments
+ are picked up from the B<extralibs.ld> file in the same directory.
+
+
+ perl -MExtUtils::Embed -e ldopts -- -std Socket
+
+
+ This will do the same as the above example, along with printing additional arguments for linking with the B<Socket> extension.
+
+
+ perl -MExtUtils::Embed -e ldopts -- DynaLoader
+
+
+ This will print arguments for linking with just the B<DynaLoader> extension
+ and B<libperl.a>.
+
+
+ perl -MExtUtils::Embed -e ldopts -- -std Msql -- -L/usr/msql/lib -lmsql
+
+
+ Any arguments after the second '--' token are additional linker
+ arguments that will be examined for potential conflict. If there is no
+ conflict, the additional arguments will be part of the output.
+
+
+ =item perl_inc()
+
+ For including perl header files this function simply prints:
+
+ -I $Config{archlib}/CORE
+
+ So, rather than having to say:
+
+ perl -MConfig -e 'print "-I $Config{archlib}/CORE"'
+
+ Just say:
+
+ perl -MExtUtils::Embed -e perl_inc
+
+ =item ccflags(), ccdlflags()
+
+ These functions simply print $Config{ccflags} and $Config{ccdlflags}
+
+ =item ccopts()
+
+ This function combines perl_inc(), ccflags() and ccdlflags() into one.
+
+ =item xsi_header()
+
+ This function simply returns a string defining the same B<EXTERN_C> macro as
+ B<perlmain.c> along with #including B<perl.h> and B<EXTERN.h>.
+
+ =item xsi_protos(@modules)
+
+ This function returns a string of B<boot_$ModuleName> prototypes for each @modules.
+
+ =item xsi_body(@modules)
+
+ This function returns a string of calls to B<newXS()> that glue the module B<bootstrap>
+ function to B<boot_ModuleName> for each @modules.
+
+ B<xsinit()> uses the xsi_* functions to generate most of it's code.
+
+ =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.
+
+ =head1 SEE ALSO
+
+ the I<perlembed> man page
+
+ =head1 AUTHOR
+
+ Doug MacEachern <dougm@osf.org>
+
+ 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.
+
+ =cut
+
#~ NeXT-specific support
diff -Pcr perl5_003/lib/ExtUtils/Liblist.pm perl5_003_01/lib/ExtUtils/Liblist.pm
*** perl5_003/lib/ExtUtils/Liblist.pm Sun Jun 23 20:52:37 1996
--- perl5_003_01/lib/ExtUtils/Liblist.pm Thu Jul 11 12:31:00 1996
***************
*** 2,8 ****
# Broken out of MakeMaker from version 4.11
! $ExtUtils::Liblist::VERSION = substr q$Revision: 1.19 $, 10;
use Config;
use Cwd 'cwd';
--- 2,8 ----
# Broken out of MakeMaker from version 4.11
! $ExtUtils::Liblist::VERSION = substr q$Revision: 1.20 $, 10;
use Config;
use Cwd 'cwd';
***************
*** 135,149 ****
# Do not add it into the list if it is already linked in
# with the main perl executable.
! # We have to special-case the NeXT, because all the math
! # is also in libsys_s
unless ($in_perl ||
! ($^O eq 'next' && $thislib eq 'm') ){
push(@extralibs, "-l$thislib");
}
# We might be able to load this archive file dynamically
! if ( $Config{'dlsrc'} =~ /dl_next|dl_dld/){
# We push -l$thislib instead of $fullname because
# it avoids hardwiring a fixed path into the .bs file.
# Mkbootstrap will automatically add dl_findfile() to
--- 135,152 ----
# Do not add it into the list if it is already linked in
# with the main perl executable.
! # We have to special-case the NeXT, because math and ndbm
! # are both in libsys_s
unless ($in_perl ||
! ($Config{'osname'} eq 'next' &&
! ($thislib eq 'm' || $thislib eq 'ndbm')) ){
push(@extralibs, "-l$thislib");
}
# We might be able to load this archive file dynamically
! if ( ($Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0')
! || ($Config{'dlsrc'} =~ /dl_dld/) )
! {
# We push -l$thislib instead of $fullname because
# it avoids hardwiring a fixed path into the .bs file.
# Mkbootstrap will automatically add dl_findfile() to
#~ Use negative substr position argument for efficiency
#~ SelfLoad most routines so they're not loaded if overridden
#~ Add MAB support for NeXT
#~ Store INST_*DIR macros in $self hash, so they can be used in overrides
#~ Skip all symlinks, not just directories, in libscan
#~ Use case-insensitive pattern when trimming $striplibpath
#~ Substitute '.' for empty components of PATH
#~ Remove $(INST_STATIC) only if we rebuild it
diff -Pcr perl5_003/lib/ExtUtils/MM_Unix.pm perl5_003_01/lib/ExtUtils/MM_Unix.pm
*** perl5_003/lib/ExtUtils/MM_Unix.pm Mon Jun 24 16:14:28 1996
--- perl5_003_01/lib/ExtUtils/MM_Unix.pm Wed Jul 24 13:28:53 1996
***************
*** 1,7 ****
package ExtUtils::MM_Unix;
! $VERSION = substr q$Revision: 1.101 $, 10;
! # $Id: MM_Unix.pm,v 1.101 1996/06/23 20:51:18 k Exp k $
require Exporter;
use Config;
--- 1,7 ----
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 Config;
***************
*** 97,108 ****
my @args = @_;
for (@args) {
# append a slash to each argument unless it has one there
! $_ .= "/" unless substr($_,length($_)-1,1) eq "/";
}
my $result = join('', @args);
# remove a trailing slash unless we are root
! substr($result,length($result)-1,1) = ""
! if length($result) > 1 && substr($result,length($result)-1,1) eq "/";
$result;
}
--- 97,108 ----
my @args = @_;
for (@args) {
# append a slash to each argument unless it has one there
! $_ .= "/" if $_ eq '' or substr($_,-1) ne "/";
}
my $result = join('', @args);
# remove a trailing slash unless we are root
! substr($result,-1) = ""
! if length($result) > 1 && substr($result,-1) eq "/";
$result;
}
***************
*** 227,236 ****
package ExtUtils::MM_Unix;
! #use SelfLoader;
1;
! #__DATA__
=head2 SelfLoaded methods
--- 227,237 ----
package ExtUtils::MM_Unix;
! use SelfLoader;
1;
!
! __DATA__
=head2 SelfLoaded methods
***************
*** 249,255 ****
my(@m);
push @m, '
.c$(OBJ_EXT):
! $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
.C$(OBJ_EXT):
$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.C
--- 250,256 ----
my(@m);
push @m, '
.c$(OBJ_EXT):
! $(CCCMD) $(MAB) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
.C$(OBJ_EXT):
$(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.C
***************
*** 564,579 ****
# Where is the Config information that we are using/depend on
CONFIGDEP = \$(PERL_ARCHLIB)/Config.pm \$(PERL_INC)/config.h
- };
- my @parentdir = split(/::/, $self->{PARENT_NAME});
- push @m, q{
# Where to put things:
! INST_LIBDIR = }. $self->catdir('$(INST_LIB)',@parentdir) .q{
! INST_ARCHLIBDIR = }. $self->catdir('$(INST_ARCHLIB)',@parentdir) .q{
! INST_AUTODIR = }. $self->catdir('$(INST_LIB)','auto','$(FULLEXT)') .q{
! INST_ARCHAUTODIR = }. $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)') .q{
};
if ($self->has_link_code()) {
--- 565,577 ----
# Where is the Config information that we are using/depend on
CONFIGDEP = \$(PERL_ARCHLIB)/Config.pm \$(PERL_INC)/config.h
# Where to put things:
! INST_LIBDIR = $self->{INST_LIBDIR}
! INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR}
! INST_AUTODIR = $self->{INST_AUTODIR}
! INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR}
};
if ($self->has_link_code()) {
***************
*** 991,997 ****
}
$ldfrom = "-all $ldfrom -none" if ($^O eq 'dec_osf');
push(@m,' LD_RUN_PATH="$(LD_RUN_PATH)" $(LD) -o $@ $(LDDLFLAGS) '.$ldfrom.
! ' $(OTHERLDFLAGS) $(MYEXTLIB) $(PERL_ARCHIVE) $(LDLOADLIBS) $(EXPORT_LIST)');
push @m, '
$(CHMOD) 755 $@
';
--- 989,995 ----
}
$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)');
push @m, '
$(CHMOD) 755 $@
';
***************
*** 1149,1156 ****
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);
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/;
--- 1147,1154 ----
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){
$dir{$name} = $name if (-f $self->catfile($name,"Makefile.PL"));
} elsif ($name =~ /\.xs$/){
my($c); ($c = $name) =~ s/\.xs$/.c/;
***************
*** 1224,1230 ****
}
my($path, $prefix) = ($File::Find::name, '$(INST_LIBDIR)');
my($striplibpath,$striplibname);
! $prefix = '$(INST_LIB)' if (($striplibpath = $path) =~ s:^(\W*)lib\W:$1:);
($striplibname,$striplibpath) = fileparse($striplibpath);
my($inst) = $self->catfile($prefix,$striplibpath,$striplibname);
local($_) = $inst; # for backwards compatibility
--- 1222,1228 ----
}
my($path, $prefix) = ($File::Find::name, '$(INST_LIBDIR)');
my($striplibpath,$striplibname);
! $prefix = '$(INST_LIB)' if (($striplibpath = $path) =~ s:^(\W*)lib\W:$1:i);
($striplibname,$striplibpath) = fileparse($striplibpath);
my($inst) = $self->catfile($prefix,$striplibpath,$striplibname);
local($_) = $inst; # for backwards compatibility
***************
*** 1476,1481 ****
--- 1474,1486 ----
$self->{INST_ARCHLIB} ||= $self->catdir($self->curdir,"blib","arch");
$self->{INST_BIN} ||= $self->catdir($self->curdir,'blib','bin');
+ # We need to set up INST_LIBDIR before init_libscan() for VMS
+ my @parentdir = split(/::/, $self->{PARENT_NAME});
+ $self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)',@parentdir);
+ $self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)',@parentdir);
+ $self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)','auto','$(FULLEXT)');
+ $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)','auto','$(FULLEXT)');
+
# INST_EXE is deprecated, should go away March '97
$self->{INST_EXE} ||= $self->catdir($self->curdir,'blib','script');
$self->{INST_SCRIPT} ||= $self->catdir($self->curdir,'blib','script');
***************
*** 1965,1970 ****
--- 1970,1976 ----
$linkcmd = join ' ', "\$(CC)",
grep($_, @Config{qw(large split ldflags ccdlflags)});
$linkcmd =~ s/\s+/ /g;
+ $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,;
# Which *.a files could we make use of...
local(%static);
***************
*** 2366,2371 ****
--- 2372,2379 ----
my $path = $ENV{PATH};
$path =~ s:\\:/:g if $Is_OS2;
my @path = split $path_sep, $path;
+ foreach(@path) { $_ = '.' if $_ eq '' }
+ @path;
}
=item perl_script
***************
*** 2601,2614 ****
my(@m);
push(@m, <<'END');
$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)/.exists
- $(RM_RF) $@
END
# If this extension has it's own library (eg SDBM_File)
# then copy that to $(INST_STATIC) and add $(OBJECT) into it.
push(@m, "\t$self->{CP} \$(MYEXTLIB) \$\@\n") if $self->{MYEXTLIB};
push @m,
! q{ $(AR) $(AR_STATIC_ARGS) $@ $(OBJECT) && $(RANLIB) $@
}.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld
$(CHMOD) 755 $@
};
--- 2609,2622 ----
my(@m);
push(@m, <<'END');
$(INST_STATIC): $(OBJECT) $(MYEXTLIB) $(INST_ARCHAUTODIR)/.exists
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) $@
}.$self->{NOECHO}.q{echo "$(EXTRALIBS)" > $(INST_ARCHAUTODIR)/extralibs.ld
$(CHMOD) 755 $@
};
***************
*** 3102,3108 ****
'
.xs$(OBJ_EXT):
$(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) $(XSUBPP) $(XSPROTOARG) $(XSUBPPARGS) $*.xs >xstmp.c && mv xstmp.c $*.c
! $(CCCMD) $(CCCDLFLAGS) -I$(PERL_INC) $(DEFINE) $*.c
';
}
--- 3110,3116 ----
'
.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
';
}
#~ Fixed bugs in path cleanup functions
#~ Correct sort routine in find_perl(), and reduce log messages for $Verbose=1
#~ Eliminate @ from NOOP macro; it's already supplied by NOECHO
#~ Eliminate redundant \t from UMASK_NULL
#~ Don't conflate /Include qualifiers; it's not necessary
#~ Separate directory from non-directory macros, and clean up directories
#~ Store INST_*DIR macros in $self hash, so they can be used in path fixups
#~ Improve timestamp handling in pm_to_blib
#~ Use $(NOECHO) macro throughout, to allow for easier override
#~ Eliminate repeated declaration or my() variable.
diff -Pcr perl5_003/lib/ExtUtils/MM_VMS.pm perl5_003_01/lib/ExtUtils/MM_VMS.pm
*** perl5_003/lib/ExtUtils/MM_VMS.pm Mon Jun 24 17:56:22 1996
--- perl5_003_01/lib/ExtUtils/MM_VMS.pm Wed Jul 24 13:33:31 1996
***************
*** 6,12 ****
# Author: Charles Bailey bailey@genetics.upenn.edu
package ExtUtils::MM_VMS;
! $ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.35 (23-Jun-1996)';
unshift @MM::ISA, 'ExtUtils::MM_VMS';
use Config;
--- 6,12 ----
# Author: Charles Bailey bailey@genetics.upenn.edu
package ExtUtils::MM_VMS;
! $ExtUtils::MM_VMS::Revision=$ExtUtils::MM_VMS::Revision = '5.36 (10-Jul-1996)';
unshift @MM::ISA, 'ExtUtils::MM_VMS';
use Config;
***************
*** 92,98 ****
}
}
elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) {
! my($vmspre) = vmspath($self->{$prefix}) || ''; # is it a dir or just a name?
$fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
$fixedpath = vmspath($fixedpath) if $force_path;
}
--- 92,98 ----
}
}
elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#)) && $self->{$prefix}) {
! my($vmspre) = vmspath($self->eliminate_macros("\$($prefix)")) || ''; # is it a dir or just a name?
$fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name;
$fixedpath = vmspath($fixedpath) if $force_path;
}
***************
*** 123,131 ****
my($spath,$sdir) = ($path,$dir);
$spath =~ s/.dir$//; $sdir =~ s/.dir$//;
$sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
! $rslt = vmspath($self->eliminate_macros($spath)."/$sdir");
}
- else { $rslt = vmspath($dir); }
print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
$rslt;
}
--- 123,134 ----
my($spath,$sdir) = ($path,$dir);
$spath =~ s/.dir$//; $sdir =~ s/.dir$//;
$sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/;
! $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1);
! }
! else {
! if ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; }
! else { $rslt = vmspath($dir); }
}
print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3;
$rslt;
}
***************
*** 317,328 ****
=cut
! sub find_perl{
my($self, $ver, $names, $dirs, $trace) = @_;
my($name,$dir,$vmsfile,@sdirs,@snames,@cand);
# Check in relative directories first, so we pick up the current
# version of Perl if we're running MakeMaker as part of the main build.
! @sdirs = sort { my($absb) = file_name_is_absolute($a);
my($absb) = file_name_is_absolute($b);
if ($absa && $absb) { return $a cmp $b }
else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); }
--- 320,331 ----
=cut
! sub find_perl {
my($self, $ver, $names, $dirs, $trace) = @_;
my($name,$dir,$vmsfile,@sdirs,@snames,@cand);
# 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);
if ($absa && $absb) { return $a cmp $b }
else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); }
***************
*** 334,340 ****
my($bb) = $b =~ m!([^:>\]/]+)$!;
substr($ba,0,1) cmp substr($bb,0,1)
or -1*(length($ba) <=> length($bb)) } @$names;
! if ($trace){
print "Looking for perl $ver by these names:\n";
print "\t@snames,\n";
print "in these dirs:\n";
--- 337,343 ----
my($bb) = $b =~ m!([^:>\]/]+)$!;
substr($ba,0,1) cmp substr($bb,0,1)
or -1*(length($ba) <=> length($bb)) } @$names;
! if ($trace >= 2){
print "Looking for perl $ver by these names:\n";
print "\t@snames,\n";
print "in these dirs:\n";
***************
*** 483,489 ****
sub init_others {
my($self) = @_;
! $self->{NOOP} = "\t@ Continue";
$self->{FIRST_MAKEFILE} ||= 'Descrip.MMS';
$self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS';
$self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
--- 486,492 ----
sub init_others {
my($self) = @_;
! $self->{NOOP} = 'Continue';
$self->{FIRST_MAKEFILE} ||= 'Descrip.MMS';
$self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS';
$self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE};
***************
*** 494,500 ****
$self->{CHMOD} = '$(PERL) -e "chmod @ARGV"'; # expect Unix syntax from MakeMaker
$self->{CP} = 'Copy/NoConfirm';
$self->{MV} = 'Rename/NoConfirm';
! $self->{UMASK_NULL} = "\t!";
&ExtUtils::MM_Unix::init_others;
}
--- 497,503 ----
$self->{CHMOD} = '$(PERL) -e "chmod @ARGV"'; # expect Unix syntax from MakeMaker
$self->{CP} = 'Copy/NoConfirm';
$self->{MV} = 'Rename/NoConfirm';
! $self->{UMASK_NULL} = '! ';
&ExtUtils::MM_Unix::init_others;
}
***************
*** 526,542 ****
}
$self->{LDFROM} = join(' ',map($self->fixpath($_),split(/,?\s+/,$self->{LDFROM})));
- if ($self->{'INC'} && $self->{INC} !~ m!/Include=!i) {
- my(@val) = ( '/Include=(' );
- my(@includes) = split(/\s+/,$self->{INC});
- my($plural);
- foreach (@includes) {
- s/^-I//;
- push @val,', ' if $plural++;
- push @val,$self->fixpath($_,1);
- }
- $self->{INC} = join('',@val,')');
- }
# Fix up directory specs
$self->{ROOTEXT} = $self->{ROOTEXT} ? $self->fixpath($self->{ROOTEXT},1)
--- 529,534 ----
***************
*** 593,600 ****
];
for $tmp (qw/
! FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT
! LDFROM LINKTYPE
/ ) {
next unless defined $self->{$tmp};
push @m, "$tmp = $self->{$tmp}\n";
--- 585,598 ----
];
for $tmp (qw/
! FULLEXT VERSION_FROM OBJECT LDFROM
! / ) {
! next unless defined $self->{$tmp};
! push @m, "$tmp = ",$self->fixpath($self->{$tmp}),"\n";
! }
!
! for $tmp (qw/
! BASEEXT PARENT_NAME DLBASE INC DEFINE LINKTYPE
/ ) {
next unless defined $self->{$tmp};
push @m, "$tmp = $self->{$tmp}\n";
***************
*** 644,655 ****
CONFIGDEP = \$(PERL_ARCHLIB)Config.pm, \$(PERL_INC)config.h \$(VERSION_FROM)
# Where to put things:
! INST_LIBDIR = ",($self->{'INST_LIBDIR'} = $self->catdir($self->{INST_LIB},$self->{ROOTEXT})),"
! INST_ARCHLIBDIR = ",($self->{'INST_ARCHLIBDIR'} = $self->catdir($self->{INST_ARCHLIB},$self->{ROOTEXT})),"
! INST_AUTODIR = ",($self->{'INST_AUTODIR'} = $self->catdir($self->{INST_LIB},'auto',$self->{FULLEXT})),'
! INST_ARCHAUTODIR = ',($self->{'INST_ARCHAUTODIR'} = $self->catdir($self->{INST_ARCHLIB},'auto',$self->{FULLEXT})),'
! ';
if ($self->has_link_code()) {
push @m,'
--- 642,653 ----
CONFIGDEP = \$(PERL_ARCHLIB)Config.pm, \$(PERL_INC)config.h \$(VERSION_FROM)
# Where to put things:
! INST_LIBDIR = $self->{INST_LIBDIR}
! INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR}
! INST_AUTODIR = $self->{INST_AUTODIR}
! INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR}
! ";
if ($self->has_link_code()) {
push @m,'
***************
*** 686,692 ****
=cut
! sub const_loadlibs{
my($self) = @_;
my (@m);
push @m, "
--- 684,690 ----
=cut
! sub const_loadlibs {
my($self) = @_;
my (@m);
push @m, "
***************
*** 733,741 ****
Bypass shell script and produce qualifiers for CC directly (but warn
user if a shell script for this extension exists). Fold multiple
! /Defines into one, and do the same with /Includes, since some C
! compilers pay attention to only one instance of these qualifiers
! on the command line.
=cut
--- 731,738 ----
Bypass shell script and produce qualifiers for CC directly (but warn
user if a shell script for this extension exists). Fold multiple
! /Defines into one, since some C compilers pay attention to only one
! instance of this qualifier on the command line.
=cut
***************
*** 780,789 ****
$incstr .= ', '.$self->fixpath($_,1);
}
}
! if ($quals =~ m:(.*)/include=\(?([^\(\/\)\s]+)\)?(.*):i) {
! $quals = "$1$incstr,$2)$3";
! }
! else { $quals .= "$incstr)"; }
$optimize = '/Debug/NoOptimize'
if ($self->{OPTIMIZE} =~ /-g/ or $self->{OPTIMIZE} =~ m!/Debug!i);
--- 777,783 ----
$incstr .= ', '.$self->fixpath($_,1);
}
}
! $quals .= "$incstr)";
$optimize = '/Debug/NoOptimize'
if ($self->{OPTIMIZE} =~ /-g/ or $self->{OPTIMIZE} =~ m!/Debug!i);
***************
*** 851,875 ****
my(@files) = @{$self->{PM_TO_BLIB}};
push @m, q{
# As always, keep under DCL's 255-char limit
! pm_to_blib : $(TO_INST_PM)
! },$self->{NOECHO},q{$(PERL) -e "print '},shift(@files),q{ },shift(@files),q{'" >.MM_tmp
};
$line = ''; # avoid uninitialized var warning
while ($from = shift(@files),$to = shift(@files)) {
$line .= " $from $to";
if (length($line) > 128) {
! push(@m,"\t$self->{NOECHO}\$(PERL) -e \"print '$line'\" >>.MM_tmp\n");
$line = '';
}
}
! push(@m,"\t$self->{NOECHO}\$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $line;
push(@m,q[ $(PERL) "-I$(PERL_LIB)" "-MExtUtils::Install" -e "pm_to_blib({split(' ',<STDIN>)},'].$autodir.q[')" <.MM_tmp]);
push(@m,qq[
! $self->{NOECHO}Delete/NoLog/NoConfirm .MM_tmp;
! $self->{NOECHO}\$(TOUCH) pm_to_blib.ts
]);
join('',@m);
--- 845,875 ----
my(@files) = @{$self->{PM_TO_BLIB}};
push @m, q{
+
+ # Dummy target to match Unix target name; we use pm_to_blib.ts as
+ # timestamp file to avoid repeated invocations under VMS
+ pm_to_blib : pm_to_blib.ts
+ $(NOECHO) $(NOOP)
+
# As always, keep under DCL's 255-char limit
! pm_to_blib.ts : $(TO_INST_PM)
! $(NOECHO) $(PERL) -e "print '},shift(@files),q{ },shift(@files),q{'" >.MM_tmp
};
$line = ''; # avoid uninitialized var warning
while ($from = shift(@files),$to = shift(@files)) {
$line .= " $from $to";
if (length($line) > 128) {
! push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n");
$line = '';
}
}
! push(@m,"\t\$(NOECHO) \$(PERL) -e \"print '$line'\" >>.MM_tmp\n") if $line;
push(@m,q[ $(PERL) "-I$(PERL_LIB)" "-MExtUtils::Install" -e "pm_to_blib({split(' ',<STDIN>)},'].$autodir.q[')" <.MM_tmp]);
push(@m,qq[
! \$(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
! \$(NOECHO) \$(TOUCH) pm_to_blib.ts
]);
join('',@m);
***************
*** 1036,1041 ****
--- 1036,1042 ----
RM_RF = $self->{RM_RF}
UMASK_NULL = $self->{UMASK_NULL}
NOOP = $self->{NOOP}
+ NOECHO = $self->{NOECHO}
MKPATH = Create/Directory
EQUALIZE_TIMESTAMP = \$(PERL) -we "open F,qq{>\$ARGV[1]};close F;utime(0,(stat(\$ARGV[0]))[9]+1,\$ARGV[1])"
!. ($self->{PARENT} ? '' :
***************
*** 1130,1156 ****
my(@m);
push @m, '
all :: pure_all manifypods
! $(NOOP)
pure_all :: config pm_to_blib subdirs linkext
! $(NOOP)
subdirs :: $(MYEXTLIB)
! $(NOOP)
config :: $(MAKEFILE) $(INST_LIBDIR).exists
! $(NOOP)
config :: $(INST_ARCHAUTODIR).exists
! $(NOOP)
config :: $(INST_AUTODIR).exists
! $(NOOP)
';
push @m, q{
config :: Version_check
! $(NOOP)
} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC};
--- 1131,1157 ----
my(@m);
push @m, '
all :: pure_all manifypods
! $(NOECHO) $(NOOP)
pure_all :: config pm_to_blib subdirs linkext
! $(NOECHO) $(NOOP)
subdirs :: $(MYEXTLIB)
! $(NOECHO) $(NOOP)
config :: $(MAKEFILE) $(INST_LIBDIR).exists
! $(NOECHO) $(NOOP)
config :: $(INST_ARCHAUTODIR).exists
! $(NOECHO) $(NOOP)
config :: $(INST_AUTODIR).exists
! $(NOECHO) $(NOOP)
';
push @m, q{
config :: Version_check
! $(NOECHO) $(NOOP)
} unless $self->{PARENT} or ($self->{PERL_SRC} && $self->{INSTALLDIRS} eq "perl") or $self->{NO_VC};
***************
*** 1159,1172 ****
if (%{$self->{MAN1PODS}}) {
push @m, q[
config :: $(INST_MAN1DIR).exists
! $(NOOP)
];
push @m, $self->dir_target(qw[$(INST_MAN1DIR)]);
}
if (%{$self->{MAN3PODS}}) {
push @m, q[
config :: $(INST_MAN3DIR).exists
! $(NOOP)
];
push @m, $self->dir_target(qw[$(INST_MAN3DIR)]);
}
--- 1160,1173 ----
if (%{$self->{MAN1PODS}}) {
push @m, q[
config :: $(INST_MAN1DIR).exists
! $(NOECHO) $(NOOP)
];
push @m, $self->dir_target(qw[$(INST_MAN1DIR)]);
}
if (%{$self->{MAN3PODS}}) {
push @m, q[
config :: $(INST_MAN3DIR).exists
! $(NOECHO) $(NOOP)
];
push @m, $self->dir_target(qw[$(INST_MAN3DIR)]);
}
***************
*** 1182,1188 ****
push @m, q{
Version_check :
! },$self->{NOECHO},q{$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -
"-MExtUtils::MakeMaker=Version_check" -e "&Version_check('$(MM_VERSION)')"
};
--- 1183,1189 ----
push @m, q{
Version_check :
! $(NOECHO) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -
"-MExtUtils::MakeMaker=Version_check" -e "&Version_check('$(MM_VERSION)')"
};
***************
*** 1210,1221 ****
unless ($self->{SKIPHASH}{'dynamic'}) {
push(@m,'
dynamic :: rtls.opt $(INST_ARCHAUTODIR)$(BASEEXT).opt
! $(NOOP)
');
if ($srcdir) {
my($popt) = $self->catfile($srcdir,'perlshr.opt');
my($lopt) = $self->catfile($srcdir,'crtl.opt');
! push(@m,"# Depend on $(BASEEXT).opt to insure we copy here *after* autogenerating (wrong) rtls.opt in Mksymlists
rtls.opt : $popt $lopt \$(BASEEXT).opt
Copy/Log $popt Sys\$Disk:[]rtls.opt
Append/Log $lopt Sys\$Disk:[]rtls.opt
--- 1211,1222 ----
unless ($self->{SKIPHASH}{'dynamic'}) {
push(@m,'
dynamic :: rtls.opt $(INST_ARCHAUTODIR)$(BASEEXT).opt
! $(NOECHO) $(NOOP)
');
if ($srcdir) {
my($popt) = $self->catfile($srcdir,'perlshr.opt');
my($lopt) = $self->catfile($srcdir,'crtl.opt');
! push(@m,"# Depend on \$(BASEEXT).opt to insure we copy here *after* autogenerating (wrong) rtls.opt in Mksymlists
rtls.opt : $popt $lopt \$(BASEEXT).opt
Copy/Log $popt Sys\$Disk:[]rtls.opt
Append/Log $lopt Sys\$Disk:[]rtls.opt
***************
*** 1232,1238 ****
push(@m,'
static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
! $(NOOP)
') unless $self->{SKIPHASH}{'static'};
push(@m,'
--- 1233,1239 ----
push(@m,'
static :: $(INST_ARCHAUTODIR)$(BASEEXT).opt
! $(NOECHO) $(NOOP)
') unless $self->{SKIPHASH}{'static'};
push(@m,'
***************
*** 1272,1278 ****
";
push @m, '
$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt rtls.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
! ',$self->{NOECHO},'$(MKPATH) $(INST_ARCHAUTODIR)
Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,rtls.opt/Option,$(PERL_INC)perlshr_attr.opt/Option
';
--- 1273,1280 ----
";
push @m, '
$(INST_DYNAMIC) : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt rtls.opt $(INST_ARCHAUTODIR).exists $(EXPORT_LIST) $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP)
! $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR)
! $(NOECHO) If F$TrnLNm("PerlShr").eqs."" Then Define/NoLog/User PerlShr Sys$Share:PerlShr.Exe
Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) $(BASEEXT).opt/Option,rtls.opt/Option,$(PERL_INC)perlshr_attr.opt/Option
';
***************
*** 1298,1310 ****
# we use touch to prevent make continually trying to remake it.
# The DynaLoader only reads a non-empty file.
$(BOOTSTRAP) : $(MAKEFILE) '."$self->{BOOTDEP}".' $(INST_ARCHAUTODIR).exists
! '.$self->{NOECHO}.'Write Sys$Output "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))"
! '.$self->{NOECHO}.'$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -
-e "use ExtUtils::Mkbootstrap; Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');"
! '.$self->{NOECHO}.' $(TOUCH) $(MMS$TARGET)
$(INST_BOOT) : $(BOOTSTRAP) $(INST_ARCHAUTODIR).exists
! '.$self->{NOECHO}.'$(RM_RF) $(INST_BOOT)
- $(CP) $(BOOTSTRAP) $(INST_BOOT)
';
}
--- 1300,1312 ----
# we use touch to prevent make continually trying to remake it.
# The DynaLoader only reads a non-empty file.
$(BOOTSTRAP) : $(MAKEFILE) '."$self->{BOOTDEP}".' $(INST_ARCHAUTODIR).exists
! $(NOECHO) Write Sys$Output "Running mkbootstrap for $(NAME) ($(BSLOADLIBS))"
! $(NOECHO) $(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -
-e "use ExtUtils::Mkbootstrap; Mkbootstrap(\'$(BASEEXT)\',\'$(BSLOADLIBS)\');"
! $(NOECHO) $(TOUCH) $(MMS$TARGET)
$(INST_BOOT) : $(BOOTSTRAP) $(INST_ARCHAUTODIR).exists
! $(NOECHO) $(RM_RF) $(INST_BOOT)
- $(CP) $(BOOTSTRAP) $(INST_BOOT)
';
}
***************
*** 1321,1327 ****
return '
$(INST_STATIC) :
! $(NOOP)
' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB});
my(@m);
--- 1323,1329 ----
return '
$(INST_STATIC) :
! $(NOECHO) $(NOOP)
' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB});
my(@m);
***************
*** 1338,1344 ****
push(@m,'
If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)
Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)
! ',$self->{NOECHO},'$(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq[$(EXTRALIBS)\n];close F;"
');
push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
join('',@m);
--- 1340,1346 ----
push(@m,'
If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)
Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)
! $(NOECHO) $(PERL) -e "open F,\'>>$(INST_ARCHAUTODIR)extralibs.ld\';print F qq[$(EXTRALIBS)\n];close F;"
');
push @m, $self->dir_target('$(INST_ARCHAUTODIR)');
join('',@m);
***************
*** 1358,1365 ****
#
# push(@m, "
# $inst : $dist \$(MAKEFILE) ${instdir}.exists \$(INST_ARCHAUTODIR).exists
! # ",' ',$self->{NOECHO},'$(RM_F) $(MMS$TARGET)
! # ',$self->{NOECHO},'$(CP) ',"$dist $inst",'
# $(CHMOD) 644 $(MMS$TARGET)
# ');
# push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ',
--- 1360,1367 ----
#
# push(@m, "
# $inst : $dist \$(MAKEFILE) ${instdir}.exists \$(INST_ARCHAUTODIR).exists
! # ",' $(NOECHO) $(RM_F) $(MMS$TARGET)
! # $(NOECHO) $(CP) ',"$dist $inst",'
# $(CHMOD) 644 $(MMS$TARGET)
# ');
# push(@m, ' $(AUTOSPLITFILE) $(MMS$TARGET) ',
***************
*** 1380,1386 ****
sub manifypods {
my($self, %attribs) = @_;
! return "\nmanifypods :\n\t\$(NOOP)\n" unless %{$self->{MAN3PODS}} or %{$self->{MAN1PODS}};
my($dist);
my($pod2man_exe);
if (defined $self->{PERL_SRC}) {
--- 1382,1388 ----
sub manifypods {
my($self, %attribs) = @_;
! return "\nmanifypods :\n\t\$(NOECHO) \$(NOOP)\n" unless %{$self->{MAN3PODS}} or %{$self->{MAN1PODS}};
my($dist);
my($pod2man_exe);
if (defined $self->{PERL_SRC}) {
***************
*** 1436,1442 ****
foreach $plfile (sort keys %{$self->{PL_FILES}}) {
push @m, "
all :: $self->{PL_FILES}->{$plfile}
! \$(NOOP)
$self->{PL_FILES}->{$plfile} :: $plfile
",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $plfile
--- 1438,1444 ----
foreach $plfile (sort keys %{$self->{PL_FILES}}) {
push @m, "
all :: $self->{PL_FILES}->{$plfile}
! \$(NOECHO) \$(NOOP)
$self->{PL_FILES}->{$plfile} :: $plfile
",' $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" '," $plfile
***************
*** 1470,1476 ****
EXE_FILES = @{$self->{EXE_FILES}}
all :: @to
! \$(NOOP)
realclean ::
";
--- 1472,1478 ----
EXE_FILES = @{$self->{EXE_FILES}}
all :: @to
! \$(NOECHO) \$(NOOP)
realclean ::
";
***************
*** 1541,1547 ****
push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)") Then \\',"\n\t",
'$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS) clean`;"',"\n");
}
! push @m, ' $(RM_F) *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *$(OBJ_EXT) *$(LIB_EXT) *.Opt $(BOOTSTRAP) $(BASEEXT).bso
';
my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files
--- 1543,1549 ----
push( @m, ' If F$Search("'.$vmsdir.'$(MAKEFILE)") Then \\',"\n\t",
'$(PERL) -e "chdir ',"'$vmsdir'",'; print `$(MMS) clean`;"',"\n");
}
! push @m, ' $(RM_F) *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *$(OBJ_EXT) *$(LIB_EXT) *.Opt $(BOOTSTRAP) $(BASEEXT).bso .MM_Tmp
';
my(@otherfiles) = values %{$self->{XS}}; # .c files from *.xs files
***************
*** 1558,1564 ****
}
else { $line .= " $file"; }
}
! push @m, "\t\$(RM_RF) $line\n" if line;
push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP};
join('', @m);
}
--- 1560,1566 ----
}
else { $line .= " $file"; }
}
! push @m, "\t\$(RM_RF) $line\n" if $line;
push(@m, " $attribs{POSTOP}\n") if $attribs{POSTOP};
join('', @m);
}
***************
*** 1630,1636 ****
my($self) = @_;
'
distclean :: realclean distcheck
! $(NOOP)
distcheck :
$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&fullcheck\'; fullcheck()"
--- 1632,1638 ----
my($self) = @_;
'
distclean :: realclean distcheck
! $(NOECHO) $(NOOP)
distcheck :
$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" -e "use ExtUtils::Manifest \'&fullcheck\'; fullcheck()"
***************
*** 1654,1663 ****
my($self) = @_;
q[
dist : $(DIST_DEFAULT)
! ].$self->{NOECHO}.q[$(PERL) -le "print 'Warning: $m older than $vf' if -e ($vf = '$(VERSION_FROM)') && -M $vf < -M ($m = '$(MAKEFILE)'"
zipdist : $(DISTVNAME).zip
! $(NOOP)
$(DISTVNAME).zip : distdir
$(PREOP)
--- 1656,1665 ----
my($self) = @_;
q[
dist : $(DIST_DEFAULT)
! $(NOECHO) $(PERL) -le "print 'Warning: $m older than $vf' if -e ($vf = '$(VERSION_FROM)') && -M $vf < -M ($m = '$(MAKEFILE)'"
zipdist : $(DISTVNAME).zip
! $(NOECHO) $(NOOP)
$(DISTVNAME).zip : distdir
$(PREOP)
***************
*** 1744,1827 ****
push @m, q[
install :: all pure_install doc_install
! $(NOOP)
install_perl :: all pure_perl_install doc_perl_install
! $(NOOP)
install_site :: all pure_site_install doc_site_install
! $(NOOP)
install_ :: install_site
! ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
pure_install :: pure_$(INSTALLDIRS)_install
! $(NOOP)
doc_install :: doc_$(INSTALLDIRS)_install
! ],$self->{NOECHO},q[Write Sys$Output "Appending installation info to $(INST_ARCHLIB)perllocal.pod"
pure__install : pure_site_install
! ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
doc__install : doc_site_install
! ],$self->{NOECHO},q[Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
# This hack brought to you by DCL's 255-character command line limit
pure_perl_install ::
! ].$self->{NOECHO}.q[$(PERL) -e "print 'read ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print 'write ].$self->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_LIB) $(INSTALLPRIVLIB) '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLARCHLIB) '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp
$(MOD_INSTALL) <.MM_tmp
! ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp;
! ].$self->{NOECHO}.q[$(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[
# Likewise
pure_site_install ::
! ].$self->{NOECHO}.q[$(PERL) -e "print 'read ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print 'write ].$self->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_LIB) $(INSTALLSITELIB) '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLSITEARCH) '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp
$(MOD_INSTALL) <.MM_tmp
! ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp;
! ].$self->{NOECHO}.q[$(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[
# Ditto
doc_perl_install ::
! ].$self->{NOECHO}.q[$(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLPRIVLIB)|'" >.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|'" >>.MM_tmp
! ],@docfiles,q[ $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
! ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp;
# And again
doc_site_install ::
! ].$self->{NOECHO}.q[$(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLSITELIB)|'" >.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|'" >>.MM_tmp
! ],@docfiles,q[ $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
! ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp;
];
push @m, q[
uninstall :: uninstall_from_$(INSTALLDIRS)dirs
! $(NOOP)
uninstall_from_perldirs ::
! ].$self->{NOECHO}.q[$(UNINSTALL) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[
uninstall_from_sitedirs ::
! ].$self->{NOECHO}.q[$(UNINSTALL) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist')."\n";
join('',@m);
}
--- 1746,1839 ----
push @m, q[
install :: all pure_install doc_install
! $(NOECHO) $(NOOP)
install_perl :: all pure_perl_install doc_perl_install
! $(NOECHO) $(NOOP)
install_site :: all pure_site_install doc_site_install
! $(NOECHO) $(NOOP)
install_ :: install_site
! $(NOECHO) Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
pure_install :: pure_$(INSTALLDIRS)_install
! $(NOECHO) $(NOOP)
doc_install :: doc_$(INSTALLDIRS)_install
! $(NOECHO) Write Sys$Output "Appending installation info to $(INST_ARCHLIB)perllocal.pod"
pure__install : pure_site_install
! $(NOECHO) Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
doc__install : doc_site_install
! $(NOECHO} Write Sys$Output "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
# This hack brought to you by DCL's 255-character command line limit
pure_perl_install ::
! $(NOECHO) $(PERL) -e "print 'read ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp
! $(NOECHO) $(PERL) -e "print 'write ].$self->catfile('$(INSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_LIB) $(INSTALLPRIVLIB) '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLARCHLIB) '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp
$(MOD_INSTALL) <.MM_tmp
! $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
! $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[
# Likewise
pure_site_install ::
! $(NOECHO) $(PERL) -e "print 'read ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q[ '" >.MM_tmp
! $(NOECHO) $(PERL) -e "print 'write ].$self->catfile('$(INSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q[ '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_LIB) $(INSTALLSITELIB) '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_ARCHLIB) $(INSTALLSITEARCH) '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_BIN) $(INSTALLBIN) '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_SCRIPT) $(INSTALLSCRIPT) '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_MAN1DIR) $(INSTALLMAN1DIR) '" >>.MM_tmp
! $(NOECHO) $(PERL) -e "print '$(INST_MAN3DIR) $(INSTALLMAN3DIR) '" >>.MM_tmp
$(MOD_INSTALL) <.MM_tmp
! $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
! $(NOECHO) $(WARN_IF_OLD_PACKLIST) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[
# Ditto
doc_perl_install ::
! $(NOECHO) $(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLPRIVLIB)|'" >.MM_tmp
! $(NOECHO) $(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.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
! $(NOECHO) $(PERL) -e "print q[while(($key=shift) && ($val=shift)) ]" >>.MM2_tmp
! $(NOECHO) $(PERL) -e "print q[{print qq[=item *\\n\\nC<$key: $val>\\n\\n];}print qq[=back\\n\\n];]" >>.MM2_tmp
! $(NOECHO) $(PERL) .MM2_tmp <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
! $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;,.MM2_tmp;
# And again
doc_site_install ::
! $(NOECHO) $(PERL) -e "print 'Module $(NAME)|installed into|$(INSTALLSITELIB)|'" >.MM_tmp
! $(NOECHO) $(PERL) -e "print 'LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|'" >>.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
! $(NOECHO) $(PERL) -e "print q[while(($key=shift) && ($val=shift)) ]" >>.MM2_tmp
! $(NOECHO) $(PERL) -e "print q[{print qq[=item *\\n\\nC<$key: $val>\\n\\n];}print qq[=back\\n\\n];]" >>.MM2_tmp
! $(NOECHO) $(PERL) .MM2_tmp <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
! $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;,.MM2_tmp;
];
push @m, q[
uninstall :: uninstall_from_$(INSTALLDIRS)dirs
! $(NOECHO) $(NOOP)
uninstall_from_perldirs ::
! $(NOECHO) $(UNINSTALL) ].$self->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q[
uninstall_from_sitedirs ::
! $(NOECHO) $(UNINSTALL) ].$self->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist')."\n";
join('',@m);
}
***************
*** 1866,1876 ****
# An out of date config.h is not fatal but complains loudly!
#$(PERL_INC)config.h : $(PERL_SRC)config.sh
$(PERL_INC)config.h : $(PERL_VMS)config.vms
! ],$self->{NOECHO},q[Write Sys$Error "Warning: $(PERL_INC)config.h out of date with $(PERL_VMS)config.vms"
#$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
$(PERL_ARCHLIB)Config.pm : $(PERL_VMS)config.vms $(PERL_VMS)genconfig.pl
! ],$self->{NOECHO},q[Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.vms or genconfig.pl"
olddef = F$Environment("Default")
Set Default $(PERL_SRC)
$(MMS)],$mmsquals,q[ $(MMS$TARGET)
--- 1878,1888 ----
# An out of date config.h is not fatal but complains loudly!
#$(PERL_INC)config.h : $(PERL_SRC)config.sh
$(PERL_INC)config.h : $(PERL_VMS)config.vms
! $(NOECHO) Write Sys$Error "Warning: $(PERL_INC)config.h out of date with $(PERL_VMS)config.vms"
#$(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh
$(PERL_ARCHLIB)Config.pm : $(PERL_VMS)config.vms $(PERL_VMS)genconfig.pl
! $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.vms or genconfig.pl"
olddef = F$Environment("Default")
Set Default $(PERL_SRC)
$(MMS)],$mmsquals,q[ $(MMS$TARGET)
***************
*** 1904,1916 ****
# We take a very conservative approach here, but it\'s worth it.
# We move $(MAKEFILE) to $(MAKEFILE)_old here to avoid gnu make looping.
$(MAKEFILE) : Makefile.PL $(CONFIGDEP)
! ],$self->{NOECHO},q[Write Sys$Output "$(MAKEFILE) out-of-date with respect to $(MMS$SOURCE_LIST)"
! ],$self->{NOECHO},q[Write Sys$Output "Cleaning current config before rebuilding $(MAKEFILE) ..."
- $(MV) $(MAKEFILE) $(MAKEFILE)_old
- $(MMS) $(USEMAKEFILE)$(MAKEFILE)_old clean
$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL ],join(' ',map(qq["$_"],@ARGV)),q[
! ],$self->{NOECHO},q[Write Sys$Output "$(MAKEFILE) has been rebuilt."
! ],$self->{NOECHO},q[Write Sys$Output "Please run $(MMS) to build the extension."
];
join('',@m);
--- 1916,1928 ----
# We take a very conservative approach here, but it\'s worth it.
# We move $(MAKEFILE) to $(MAKEFILE)_old here to avoid gnu make looping.
$(MAKEFILE) : Makefile.PL $(CONFIGDEP)
! $(NOECHO) Write Sys$Output "$(MAKEFILE) out-of-date with respect to $(MMS$SOURCE_LIST)"
! $(NOECHO) Write Sys$Output "Cleaning current config before rebuilding $(MAKEFILE) ..."
- $(MV) $(MAKEFILE) $(MAKEFILE)_old
- $(MMS) $(USEMAKEFILE)$(MAKEFILE)_old clean
$(PERL) "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" Makefile.PL ],join(' ',map(qq["$_"],@ARGV)),q[
! $(NOECHO) Write Sys$Output "$(MAKEFILE) has been rebuilt."
! $(NOECHO) Write Sys$Output "Please run $(MMS) to build the extension."
];
join('',@m);
***************
*** 1933,1942 ****
TESTDB_SW = -d
test :: \$(TEST_TYPE)
! \$(NOOP)
testdb :: testdb_\$(LINKTYPE)
! \$(NOOP)
";
foreach(@{$self->{DIR}}){
--- 1945,1954 ----
TESTDB_SW = -d
test :: \$(TEST_TYPE)
! \$(NOECHO) \$(NOOP)
testdb :: testdb_\$(LINKTYPE)
! \$(NOECHO) \$(NOOP)
";
foreach(@{$self->{DIR}}){
***************
*** 1944,1957 ****
push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'",
'; print `$(MMS) $(PASTHRU2) test`'."\n");
}
! push(@m, "\t$self->{NOECHO}Write Sys\$Output \"No tests defined for \$(NAME) extension.\"\n")
unless $tests or -f "test.pl" or @{$self->{DIR}};
push(@m, "\n");
push(@m, "test_dynamic :: pure_all\n");
push(@m, $self->test_via_harness('$(FULLPERL)', $tests)) if $tests;
push(@m, $self->test_via_script('$(FULLPERL)', 'test.pl')) if -f "test.pl";
! push(@m, " \$(NOOP)\n") if (!$tests && ! -f "test.pl");
push(@m, "\n");
push(@m, "testdb_dynamic :: pure_all\n");
--- 1956,1969 ----
push(@m, ' If F$Search("',$vmsdir,'$(MAKEFILE)").nes."" Then $(PERL) -e "chdir ',"'$vmsdir'",
'; print `$(MMS) $(PASTHRU2) test`'."\n");
}
! push(@m, "\t\$(NOECHO) Write Sys\$Output \"No tests defined for \$(NAME) extension.\"\n")
unless $tests or -f "test.pl" or @{$self->{DIR}};
push(@m, "\n");
push(@m, "test_dynamic :: pure_all\n");
push(@m, $self->test_via_harness('$(FULLPERL)', $tests)) if $tests;
push(@m, $self->test_via_script('$(FULLPERL)', 'test.pl')) if -f "test.pl";
! push(@m, "\t\$(NOECHO) \$(NOOP)\n") if (!$tests && ! -f "test.pl");
push(@m, "\n");
push(@m, "testdb_dynamic :: pure_all\n");
***************
*** 1971,1978 ****
push(@m, "\n");
}
else {
! push @m, "test_static :: test_dynamic\n\t$self->{NOECHO}\$(NOOP)\n\n";
! push @m, "testdb_static :: testdb_dynamic\n\t$self->{NOECHO}\$(NOOP)\n";
}
join('',@m);
--- 1983,1990 ----
push(@m, "\n");
}
else {
! push @m, "test_static :: test_dynamic\n\t\$(NOECHO) \$(NOOP)\n\n";
! push @m, "testdb_static :: testdb_dynamic\n\t\$(NOECHO) \$(NOOP)\n";
}
join('',@m);
***************
*** 2027,2034 ****
unless ($self->{MAKEAPERL}) {
push @m, q{
$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
! },$self->{NOECHO},q{Write Sys$Output "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
! },$self->{NOECHO},q{$(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \
Makefile.PL DIR=}, $dir, q{ \
MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
MAKEAPERL=1 NORECURS=1
--- 2039,2046 ----
unless ($self->{MAKEAPERL}) {
push @m, q{
$(MAKE_APERL_FILE) : $(FIRST_MAKEFILE)
! $(NOECHO) Write Sys$Output "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)"
! $(NOECHO) $(PERL) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" "-I$(PERL_ARCHLIB)" "-I$(PERL_LIB)" \
Makefile.PL DIR=}, $dir, q{ \
MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \
MAKEAPERL=1 NORECURS=1
***************
*** 2043,2049 ****
}
! my($linkcmd,@staticopts,@staticpkgs,$extralist,$target,$targdir,$libperldir);
# The front matter of the linkcommand...
$linkcmd = join ' ', $Config{'ld'},
--- 2055,2061 ----
}
! my($linkcmd,@staticopts,@staticpkgs,$extralist,$targdir,$libperldir);
# The front matter of the linkcommand...
$linkcmd = join ' ', $Config{'ld'},
***************
*** 2179,2215 ****
$(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_OPTS), $(MAP_EXTRA), $(MAP_LIBPERL) ',"${libperldir}Perlshr_Attr.Opt",'
$(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt",'
$(MAP_LINKCMD) ',"${tmp}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option
! ',$self->{NOECHO},'Write Sys$Output "To install the new ""$(MAP_TARGET)"" binary, say"
! ',$self->{NOECHO},'Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
! ',$self->{NOECHO},'Write Sys$Output "To remove the intermediate files, say
! ',$self->{NOECHO},'Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) map_clean"
';
push @m,'
',"${tmp}perlmain.c",' : $(MAKEFILE)
! ',$self->{NOECHO},'$(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET)
';
push @m, q[
# More from the 255-char line length limit
doc_inst_perl :
! ].$self->{NOECHO}.q[$(PERL) -e "print 'Perl binary $(MAP_TARGET)|'" >.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print 'MAP_STATIC|$(MAP_STATIC)|'" >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
! ].$self->{NOECHO}.q[$(PERL) -e "print 'MAP_LIBPERL|$(MAP_LIBPERL)|'" >>.MM_tmp
$(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
! ].$self->{NOECHO}.q[Delete/NoLog/NoConfirm .MM_tmp;
];
push @m, "
inst_perl : pure_inst_perl doc_inst_perl
! \$(NOOP)
pure_inst_perl : \$(MAP_TARGET)
$self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1),"
$self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1),"
clean :: map_clean
! \$(NOOP)
map_clean :
\$(RM_F) ${tmp}perlmain\$(OBJ_EXT) ${tmp}perlmain.c \$(MAKEFILE)
--- 2191,2227 ----
$(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_OPTS), $(MAP_EXTRA), $(MAP_LIBPERL) ',"${libperldir}Perlshr_Attr.Opt",'
$(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmp}perlmain\$(OBJ_EXT) ${tmp}PerlShr.Opt",'
$(MAP_LINKCMD) ',"${tmp}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option
! $(NOECHO) Write Sys$Output "To install the new ""$(MAP_TARGET)"" binary, say"
! $(NOECHO) Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)"
! $(NOECHO) Write Sys$Output "To remove the intermediate files, say
! $(NOECHO) Write Sys$Output " $(MMS)$(USEMAKEFILE)$(MAKEFILE) map_clean"
';
push @m,'
',"${tmp}perlmain.c",' : $(MAKEFILE)
! $(NOECHO) $(PERL) $(MAP_PERLINC) -e "use ExtUtils::Miniperl; writemain(qw|',@staticpkgs,'|)" >$(MMS$TARGET)
';
push @m, q[
# More from the 255-char line length limit
doc_inst_perl :
! $(NOECHO) $(PERL) -e "print 'Perl binary $(MAP_TARGET)|'" >.MM_tmp
! $(NOECHO) $(PERL) -e "print 'MAP_STATIC|$(MAP_STATIC)|'" >>.MM_tmp
! $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp
! $(NOECHO) $(PERL) -e "print 'MAP_LIBPERL|$(MAP_LIBPERL)|'" >>.MM_tmp
$(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(INSTALLARCHLIB)','perllocal.pod').q[
! $(NOECHO) Delete/NoLog/NoConfirm .MM_tmp;
];
push @m, "
inst_perl : pure_inst_perl doc_inst_perl
! \$(NOECHO) \$(NOOP)
pure_inst_perl : \$(MAP_TARGET)
$self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1),"
$self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1),"
clean :: map_clean
! \$(NOECHO) \$(NOOP)
map_clean :
\$(RM_F) ${tmp}perlmain\$(OBJ_EXT) ${tmp}perlmain.c \$(MAKEFILE)
#~ Add MAB support for NeXT
#~ Minimize methods loaded at startup, and SelfLoad the rest as needed
#~ Eliminate colliding declarations of my() variables
diff -Pcr perl5_003/lib/ExtUtils/MakeMaker.pm perl5_003_01/lib/ExtUtils/MakeMaker.pm
*** perl5_003/lib/ExtUtils/MakeMaker.pm Sun Jun 23 20:52:43 1996
--- perl5_003_01/lib/ExtUtils/MakeMaker.pm Thu Jul 11 12:27:02 1996
***************
*** 2,11 ****
package ExtUtils::MakeMaker;
! $Version = $VERSION = "5.34";
$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.202 $, 10)) =~ s/\s+$//;
--- 2,11 ----
package ExtUtils::MakeMaker;
! $Version = $VERSION = "5.36";
$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+$//;
***************
*** 152,158 ****
sub ExtUtils::MakeMaker::prompt ;
1;
! #__DATA__
package ExtUtils::MakeMaker;
sub WriteMakefile {
--- 152,160 ----
sub ExtUtils::MakeMaker::prompt ;
1;
!
! __DATA__
!
package ExtUtils::MakeMaker;
sub WriteMakefile {
***************
*** 297,303 ****
@Get_from_Config =
qw(
ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc
! lib_ext obj_ext ranlib sitelibexp sitearchexp so
);
my $item;
--- 299,305 ----
@Get_from_Config =
qw(
ar cc cccdlflags ccdlflags dlext dlsrc ld lddlflags ldflags libc
! lib_ext mab obj_ext ranlib sitelibexp sitearchexp so
);
my $item;
***************
*** 411,424 ****
$self->{Correct_relativ_directories}=0;
}
! my $class = ++$PACKNAME;
{
# no strict;
! print "Blessing Object into class [$class]\n" if $Verbose>=2;
! mv_all_methods("MY",$class);
! bless $self, $class;
push @Parent, $self;
! @{"$class\:\:ISA"} = 'MM';
}
if (defined $Parent[-2]){
--- 413,426 ----
$self->{Correct_relativ_directories}=0;
}
! my $newclass = ++$PACKNAME;
{
# no strict;
! print "Blessing Object into class [$newclass]\n" if $Verbose>=2;
! mv_all_methods("MY",$newclass);
! bless $self, $newclass;
push @Parent, $self;
! @{"$newclass\:\:ISA"} = 'MM';
}
if (defined $Parent[-2]){
***************
*** 430,436 ****
$self->{$key} = $self->catdir("..",$self->{$key})
unless $self->file_name_is_absolute($self->{$key});
}
! $self->{PARENT}->{CHILDREN}->{$class} = $self if $self->{PARENT};
} else {
parse_args($self,@ARGV);
}
--- 432,438 ----
$self->{$key} = $self->catdir("..",$self->{$key})
unless $self->file_name_is_absolute($self->{$key});
}
! $self->{PARENT}->{CHILDREN}->{$newclass} = $self if $self->{PARENT};
} else {
parse_args($self,@ARGV);
}
#~ Move documentation to end
#~ Avoid once-used warnings
diff -Pcr perl5_003/lib/ExtUtils/Mkbootstrap.pm perl5_003_01/lib/ExtUtils/Mkbootstrap.pm
*** perl5_003/lib/ExtUtils/Mkbootstrap.pm Mon Mar 25 01:04:20 1996
--- perl5_003_01/lib/ExtUtils/Mkbootstrap.pm Fri Jun 21 18:49:53 1996
***************
*** 1,47 ****
package ExtUtils::Mkbootstrap;
use Config;
use Exporter;
@ISA=('Exporter');
@EXPORT='&Mkbootstrap';
- $Version=2.0; # just to start somewhere
sub Mkbootstrap {
-
- =head1 NAME
-
- ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader
-
- =head1 SYNOPSIS
-
- C<mkbootstrap>
-
- =head1 DESCRIPTION
-
- Mkbootstrap typically gets called from an extension Makefile.
-
- There is no C<*.bs> file supplied with the extension. Instead a
- C<*_BS> file which has code for the special cases, like posix for
- berkeley db on the NeXT.
-
- This file will get parsed, and produce a maybe empty
- C<@DynaLoader::dl_resolve_using> array for the current architecture.
- That will be extended by $BSLOADLIBS, which was computed by
- ExtUtils::Liblist::ext(). If this array still is empty, we do nothing,
- else we write a .bs file with an C<@DynaLoader::dl_resolve_using>
- array.
-
- The C<*_BS> file can put some code into the generated C<*.bs> file by
- placing it in C<$bscode>. This is a handy 'escape' mechanism that may
- prove useful in complex situations.
-
- If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then
- Mkbootstrap will automatically add a dl_findfile() call to the
- generated C<*.bs> file.
-
- =cut
-
my($baseext, @bsloadlibs)=@_;
-
@bsloadlibs = grep($_, @bsloadlibs); # strip empty libs
print STDOUT " bsloadlibs=@bsloadlibs\n" if $Verbose;
--- 1,15 ----
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 $
+
use Config;
use Exporter;
@ISA=('Exporter');
@EXPORT='&Mkbootstrap';
sub Mkbootstrap {
my($baseext, @bsloadlibs)=@_;
@bsloadlibs = grep($_, @bsloadlibs); # strip empty libs
print STDOUT " bsloadlibs=@bsloadlibs\n" if $Verbose;
***************
*** 58,63 ****
--- 26,33 ----
if (-f "${baseext}_BS"){
$_ = "${baseext}_BS";
package DynaLoader; # execute code as if in DynaLoader
+ local($osname, $dlsrc) = (); # avoid warnings
+ ($osname, $dlsrc) = @Config::Config{qw(osname dlsrc)};
$bscode = "";
unshift @INC, ".";
require $_;
***************
*** 95,97 ****
--- 65,103 ----
}
}
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader
+
+ =head1 SYNOPSIS
+
+ C<mkbootstrap>
+
+ =head1 DESCRIPTION
+
+ Mkbootstrap typically gets called from an extension Makefile.
+
+ There is no C<*.bs> file supplied with the extension. Instead a
+ C<*_BS> file which has code for the special cases, like posix for
+ berkeley db on the NeXT.
+
+ This file will get parsed, and produce a maybe empty
+ C<@DynaLoader::dl_resolve_using> array for the current architecture.
+ That will be extended by $BSLOADLIBS, which was computed by
+ ExtUtils::Liblist::ext(). If this array still is empty, we do nothing,
+ else we write a .bs file with an C<@DynaLoader::dl_resolve_using>
+ array.
+
+ The C<*_BS> file can put some code into the generated C<*.bs> file by
+ placing it in C<$bscode>. This is a handy 'escape' mechanism that may
+ prove useful in complex situations.
+
+ If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then
+ Mkbootstrap will automatically add a dl_findfile() call to the
+ generated C<*.bs> file.
+
+ =cut
#~ Add version variable
diff -Pcr perl5_003/lib/ExtUtils/testlib.pm perl5_003_01/lib/ExtUtils/testlib.pm
*** perl5_003/lib/ExtUtils/testlib.pm Mon Mar 25 01:04:32 1996
--- perl5_003_01/lib/ExtUtils/testlib.pm Fri Jun 21 18:50:58 1996
***************
*** 1,4 ****
--- 1,7 ----
package ExtUtils::testlib;
+ $VERSION = substr q$Revision: 1.11 $, 10;
+ # $Id: testlib.pm,v 1.11 1996/05/31 08:27:07 k Exp $
+
use lib qw(blib/arch blib/lib);
1;
__END__
#~ Update to version 1.937
#~ Cosmetic changes for easier EMACS editing
#~ First pass at correcting return type for void XSUBs
diff -Pcr perl5_003/lib/ExtUtils/xsubpp perl5_003_01/lib/ExtUtils/xsubpp
*** perl5_003/lib/ExtUtils/xsubpp Mon Mar 25 01:04:37 1996
--- perl5_003_01/lib/ExtUtils/xsubpp Thu Jul 11 10:20:32 1996
***************
*** 76,82 ****
=cut
# Global Constants
! $XSUBPP_version = "1.935";
require 5.002;
use vars '$cplusplus';
--- 76,82 ----
=cut
# Global Constants
! $XSUBPP_version = "1.937";
require 5.002;
use vars '$cplusplus';
***************
*** 183,189 ****
$type = TidyType($type) ;
$type_kind{$type} = $kind ;
# prototype defaults to '$'
! $proto = '$' unless $proto ;
warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
unless ValidProtoString($proto) ;
$proto_letter{$type} = C_string($proto) ;
--- 183,189 ----
$type = TidyType($type) ;
$type_kind{$type} = $kind ;
# prototype defaults to '$'
! $proto = "\$" unless $proto ;
warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
unless ValidProtoString($proto) ;
$proto_letter{$type} = C_string($proto) ;
***************
*** 570,576 ****
{
my ($type) = @_ ;
! $proto_letter{$type} or '$' ;
}
sub check_cpp {
--- 570,576 ----
{
my ($type) = @_ ;
! $proto_letter{$type} or "\$" ;
}
sub check_cpp {
***************
*** 608,614 ****
print <<EOM ;
/*
* This file was generated automatically by xsubpp version $XSUBPP_version from the
! * contents of $filename. Don't edit this file, edit $filename instead.
*
* ANY CHANGES MADE HERE WILL BE LOST!
*
--- 608,614 ----
print <<EOM ;
/*
* This file was generated automatically by xsubpp version $XSUBPP_version from the
! * contents of $filename. Do not edit this file, edit $filename instead.
*
* ANY CHANGES MADE HERE WILL BE LOST!
*
***************
*** 802,808 ****
$defaults{$args[$i]} = $2;
$defaults{$args[$i]} =~ s/"/\\"/g;
}
! $proto_arg[$i+1] = '$' ;
}
if (defined($class)) {
$func_args = join(", ", @args[1..$#args]);
--- 802,808 ----
$defaults{$args[$i]} = $2;
$defaults{$args[$i]} =~ s/"/\\"/g;
}
! $proto_arg[$i+1] = "\$" ;
}
if (defined($class)) {
$func_args = join(", ", @args[1..$#args]);
***************
*** 812,817 ****
--- 812,818 ----
@args_match{@args} = 1..@args;
$PPCODE = grep(/^\s*PPCODE\s*:/, @line);
+ $CODE = grep(/^\s*CODE\s*:/, @line);
$ALIAS = grep(/^\s*ALIAS\s*:/, @line);
# print function header
***************
*** 979,987 ****
# croak(errbuf);
EOF
! print Q<<EOF unless $PPCODE;
# XSRETURN(1);
EOF
print Q<<EOF;
#]]
--- 980,994 ----
# croak(errbuf);
EOF
! if ($ret_type ne "void" or $CODE) {
! print Q<<EOF unless $PPCODE;
# XSRETURN(1);
EOF
+ } else {
+ print Q<<EOF unless $PPCODE;
+ # XSRETURN_EMPTY;
+ EOF
+ }
print Q<<EOF;
#]]
***************
*** 1137,1143 ****
$subexpr =~ s/ntype/subtype/g;
$subexpr =~ s/\$arg/ST(ix_$var)/g;
$subexpr =~ s/\n\t/\n\t\t/g;
! $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
$subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
$expr =~ s/DO_ARRAY_ELEM/$subexpr/;
}
--- 1144,1150 ----
$subexpr =~ s/ntype/subtype/g;
$subexpr =~ s/\$arg/ST(ix_$var)/g;
$subexpr =~ s/\n\t/\n\t\t/g;
! $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
$subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
$expr =~ s/DO_ARRAY_ELEM/$subexpr/;
}
***************
*** 1186,1192 ****
eval "print qq\a$expr\a";
}
elsif ($var eq 'RETVAL') {
! if ($expr =~ /^\t\$arg = /) {
eval "print qq\a$expr\a";
print "\tsv_2mortal(ST(0));\n";
}
--- 1193,1203 ----
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 = /) {
eval "print qq\a$expr\a";
print "\tsv_2mortal(ST(0));\n";
}
#~ Add Fatal library module
diff -Pcr perl5_003/lib/Fatal.pm perl5_003_01/lib/Fatal.pm
*** perl5_003/lib/Fatal.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/lib/Fatal.pm Wed May 15 19:46:05 1996
***************
*** 0 ****
--- 1,82 ----
+ package Fatal;
+
+ use Carp;
+ use strict;
+ use vars qw( $AUTOLOAD $Debug );
+
+ $Debug = 0;
+
+ sub import {
+ my $self = shift(@_);
+ my($sym, $pkg);
+ $pkg = (caller)[0];
+ foreach $sym (@_) {
+ &_make_fatal($sym, $pkg);
+ }
+ };
+
+ sub AUTOLOAD {
+ my $cmd = $AUTOLOAD;
+ $cmd =~ s/.*:://;
+ &_make_fatal($cmd, (caller)[0]);
+ goto &$AUTOLOAD;
+ }
+
+ sub _make_fatal {
+ my($sub, $pkg) = @_;
+ my($name, $code, $sref);
+
+ $sub = "${pkg}::$sub" unless $sub =~ /::/;
+ $name = $sub;
+ $name =~ s/.*::// or $name =~ s/^&//;
+ print "# _make_fatal: sub=$sub pkg=$pkg name=$name\n" if $Debug;
+ croak "Bad subroutine name for Fatal: $name" unless $name =~ /^\w+$/;
+ $code = "sub $name {\n\tlocal(\$\", \$!) = (', ', 0);\n";
+ if (defined(&$sub)) {
+ # user subroutine
+ $sref = \&$sub;
+ $code .= "\t&\$sref";
+ } else {
+ # CORE subroutine
+ $code .= "\tCORE::$name";
+ }
+ $code .= "\(\@_\) || croak \"Can't $name\(\@_\): \$!\";\n}\n";
+ print $code if $Debug;
+ eval($code);
+ die($@) if $@;
+ local($^W) = 0; # to avoid: Subroutine foo redefined ...
+ no strict 'refs'; # to avoid: Can't use string (...) as a symbol ref ...
+ *{$sub} = \&{"Fatal::$name"};
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Fatal - replace functions with equivalents which succeed or die
+
+ =head1 SYNOPSIS
+
+ use Fatal qw(open print close);
+
+ sub juggle { . . . }
+ import Fatal 'juggle';
+
+ =head1 DESCRIPTION
+
+ C<Fatal> provides a way to conveniently replace functions which normally
+ return a false value when they fail with equivalents which halt execution
+ if they are not successful. This lets you use these functions without
+ having to test their return values explicitly on each call. Errors are
+ reported via C<die>, so you can trap them using C<$SIG{__DIE__}> if you
+ wish to take some action before the program exits.
+
+ The do-or-die equivalents are set up simply by calling Fatal's C<import>
+ routine, passing it the names of the functions to be replaced. You may
+ wrap both user-defined functions and CORE operators in this way.
+
+ =head1 AUTHOR
+
+ Lionel.Cons@cern.ch
#~ Relax reversibility of fileparse() from same string to same file
#~ Don't return VMS default directory from fileparse() if it's not in input
#~ Add VERSION
#~ Correct documentation and remove redundant comments
#~ Fix handling of MSDOS file syntax
#~ Correct recognition of MacOS name, so it doesn't collide with MachTen
#~ Eliminate use of &` to avoid runtime penalty
#~ Don't convert single-char path (root dir) into empty string
diff -Pcr perl5_003/lib/File/Basename.pm perl5_003_01/lib/File/Basename.pm
*** perl5_003/lib/File/Basename.pm Mon Mar 25 01:04:37 1996
--- perl5_003_01/lib/File/Basename.pm Wed Jul 10 11:27:39 1996
***************
*** 61,68 ****
C<@suffixlist>, you can remove file types or versions for examination.
You are guaranteed that if you concatenate B<path>, B<name>, and
! B<suffix> together in that order, the result will be identical to the
! input file specification.
=back
--- 61,68 ----
C<@suffixlist>, you can remove file types or versions for examination.
You are guaranteed that if you concatenate B<path>, B<name>, and
! B<suffix> together in that order, the result will denote the same
! file as the input file specification.
=back
***************
*** 70,82 ****
Using UNIX file syntax:
! ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
'\.book\d+');
would yield
$base eq 'draft'
! $path eq '/virgil/aeneid',
$tail eq '.book7'
Similarly, using VMS syntax:
--- 70,82 ----
Using UNIX file syntax:
! ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
'\.book\d+');
would yield
$base eq 'draft'
! $path eq '/virgil/aeneid/',
$tail eq '.book7'
Similarly, using VMS syntax:
***************
*** 101,107 ****
The dirname() routine returns the directory portion of the input file
specification. When using VMS or MacOS syntax, this is identical to the
second element of the list produced by calling fileparse() with the same
! input file specification. When using UNIX or MSDOS syntax, the return
value conforms to the behavior of the UNIX shell command dirname(1). This
is usually the same as the behavior of fileparse(), but differs in some
cases. For example, for the input file specification F<lib/>, fileparse()
--- 101,109 ----
The dirname() routine returns the directory portion of the input file
specification. When using VMS or MacOS syntax, this is identical to the
second element of the list produced by calling fileparse() with the same
! input file specification. (Under VMS, if there is no directory information
! in the input file specification, then the current default device and
! directory are returned.) When using UNIX or MSDOS syntax, the return
value conforms to the behavior of the UNIX shell command dirname(1). This
is usually the same as the behavior of fileparse(), but differs in some
cases. For example, for the input file specification F<lib/>, fileparse()
***************
*** 114,119 ****
--- 116,125 ----
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
+ #use strict;
+ #use vars qw($VERSION $Fileparse_fstype);
+ $VERSION = "2.3";
+
# fileparse_set_fstype() - specify OS-based rules used in future
# calls to routines in this package
***************
*** 129,190 ****
# fileparse() - parse file specification
#
! # calling sequence:
! # ($filename,$prefix,$tail) = &basename_pat($filespec,@excludelist);
! # where $filespec is the file specification to be parsed, and
! # @excludelist is a list of patterns which should be removed
! # from the end of $filename.
! # $filename is the part of $filespec after $prefix (i.e. the
! # name of the file). The elements of @excludelist
! # are compared to $filename, and if an
! # $prefix is the path portion $filespec, up to and including
! # the end of the last directory name
! # $tail any characters removed from $filename because they
! # matched an element of @excludelist.
! #
! # fileparse() first removes the directory specification from $filespec,
! # according to the syntax of the OS (code is provided below to handle
! # VMS, Unix, MSDOS and MacOS; you can pick the one you want using
! # fileparse_set_fstype(), or you can accept the default, which is
! # based on the information in the builtin variable $^O). It then compares
! # each element of @excludelist to $filename, and if that element is a
! # suffix of $filename, it is removed from $filename and prepended to
! # $tail. By specifying the elements of @excludelist in the right order,
! # you can 'nibble back' $filename to extract the portion of interest
! # to you.
! #
! # For example, on a system running Unix,
! # ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
! # '\.book\d+');
! # would yield $base == 'draft',
! # $path == '/virgil/aeneid/' (note trailing slash)
! # $tail == '.book7'.
! # Similarly, on a system running VMS,
! # ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh','\..*');
! # would yield $name == 'Rhetoric';
! # $dir == 'Doc_Root:[Help]', and
! # $type == '.Rnh'.
! #
! # Version 2.2 13-Oct-1994 Charles Bailey bailey@genetics.upenn.edu
sub fileparse {
my($fullname,@suffices) = @_;
my($fstype) = $Fileparse_fstype;
! my($dirpath,$tail,$suffix);
if ($fstype =~ /^VMS/i) {
if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation
else {
($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
- $dirpath = $ENV{'DEFAULT'} unless $dirpath;
}
}
if ($fstype =~ /^MSDOS/i) {
! ($dirpath,$basename) = ($fullname =~ /(.*\\)?(.*)/);
! $dirpath = '.\\' unless $dirpath;
}
! elsif ($fstype =~ /^MAC/i) {
($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
}
elsif ($fstype !~ /^VMS/i) { # default to Unix
--- 135,159 ----
# fileparse() - parse file specification
#
! # Version 2.3 4-Jul-1996 Charles Bailey bailey@genetics.upenn.edu
sub fileparse {
my($fullname,@suffices) = @_;
my($fstype) = $Fileparse_fstype;
! my($dirpath,$tail,$suffix,$basename);
if ($fstype =~ /^VMS/i) {
if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation
else {
($dirpath,$basename) = ($fullname =~ /(.*[:>\]])?(.*)/);
}
}
if ($fstype =~ /^MSDOS/i) {
! ($dirpath,$basename) = ($fullname =~ /(.*[:\\])?(.*)/);
! $dirpath .= '.\\' unless $dirpath =~ /\\$/;
}
! elsif ($fstype =~ /^MacOS/i) {
($dirpath,$basename) = ($fullname =~ /(.*:)?(.*)/);
}
elsif ($fstype !~ /^VMS/i) { # default to Unix
***************
*** 195,203 ****
if (@suffices) {
$tail = '';
foreach $suffix (@suffices) {
! if ($basename =~ /($suffix)$/) {
! $tail = $1 . $tail;
! $basename = $`;
}
}
}
--- 164,172 ----
if (@suffices) {
$tail = '';
foreach $suffix (@suffices) {
! if ($basename =~ /([\x00-\xff]*?)($suffix)$/) {
! $tail = $2 . $tail;
! $basename = $1;
}
}
}
***************
*** 213,219 ****
my($name) = shift;
(fileparse($name, map("\Q$_\E",@_)))[0];
}
!
# dirname() - returns device and directory portion of file specification
# Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS
--- 182,188 ----
my($name) = shift;
(fileparse($name, map("\Q$_\E",@_)))[0];
}
!
# dirname() - returns device and directory portion of file specification
# Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS
***************
*** 228,247 ****
if ($fstype =~ /VMS/i) {
if ($_[0] =~ m#/#) { $fstype = '' }
! else { return $dirname }
}
if ($fstype =~ /MacOS/i) { return $dirname }
elsif ($fstype =~ /MSDOS/i) {
if ( $dirname =~ /:\\$/) { return $dirname }
chop $dirname;
! $dirname =~ s:[^\\]+$:: unless $basename;
! $dirname = '.' unless $dirname;
}
else {
! if ( $dirname eq '/') { return $dirname }
chop $dirname;
! $dirname =~ s:[^/]+$:: unless $basename;
! $dirname = '.' unless $dirname;
}
$dirname;
--- 197,217 ----
if ($fstype =~ /VMS/i) {
if ($_[0] =~ m#/#) { $fstype = '' }
! else { return $dirname || $ENV{DEFAULT} }
}
if ($fstype =~ /MacOS/i) { return $dirname }
elsif ($fstype =~ /MSDOS/i) {
if ( $dirname =~ /:\\$/) { return $dirname }
chop $dirname;
! $dirname =~ s:[^\\]+$:: unless length($basename);
! $dirname = '.' unless length($dirname);
}
else {
! if ( $dirname =~ m:^/+$:) { return '/'; }
chop $dirname;
! $dirname =~ s:[^/]+$:: unless length($basename);
! $dirname =~ s:/+$:: ;
! $dirname = '.' unless length($dirname);
}
$dirname;
#~ Change handling of $\ to avoid uninitializd variable warning when
#~ it was undefined
diff -Pcr perl5_003/lib/File/Copy.pm perl5_003_01/lib/File/Copy.pm
*** perl5_003/lib/File/Copy.pm Mon Mar 25 01:04:42 1996
--- perl5_003_01/lib/File/Copy.pm Mon Jul 15 15:22:03 1996
***************
*** 31,43 ****
my $from = shift;
my $to = shift;
- my $recsep = $\;
my $closefrom=0;
my $closeto=0;
my ($size, $status, $r, $buf);
local(*FROM, *TO);
!
! $\ = '';
if (ref(\$from) eq 'GLOB') {
*FROM = $from;
--- 31,41 ----
my $from = shift;
my $to = shift;
my $closefrom=0;
my $closeto=0;
my ($size, $status, $r, $buf);
local(*FROM, *TO);
! local($\) = '';
if (ref(\$from) eq 'GLOB') {
*FROM = $from;
***************
*** 81,87 ****
goto fail_inner unless(defined($r));
close(TO) || goto fail_open2 if $closeto;
close(FROM) || goto fail_open1 if $closefrom;
! $\ = $recsep;
return 1;
# All of these contortions try to preserve error messages...
--- 79,85 ----
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.
return 1;
# All of these contortions try to preserve error messages...
***************
*** 100,106 ****
$! = $status unless $!;
}
fail_open1:
- $\ = $recsep;
return 0;
}
--- 98,103 ----
#~ Clip off '\dir' suffix under Win32
#~ Fix inversion in recording return values from fileparse()
diff -Pcr perl5_003/lib/File/Find.pm perl5_003_01/lib/File/Find.pm
*** perl5_003/lib/File/Find.pm Mon Mar 25 01:04:43 1996
--- perl5_003_01/lib/File/Find.pm Tue Jun 18 20:33:04 1996
***************
*** 82,88 ****
&$wanted;
my $fixtopdir = $topdir;
$fixtopdir =~ s,/$,, ;
! $fixtopdir =~ s/\.dir$// if $Is_VMS; ;
&finddir($wanted,$fixtopdir,$topnlink);
}
else {
--- 82,89 ----
&$wanted;
my $fixtopdir = $topdir;
$fixtopdir =~ s,/$,, ;
! $fixtopdir =~ s/\.dir$// if $Is_VMS;
! $fixtopdir =~ s/\\dir$// if $Is_NT;
&finddir($wanted,$fixtopdir,$topnlink);
}
else {
***************
*** 90,96 ****
}
}
else {
! unless (($dir,$_) = File::Basename::fileparse($topdir)) {
($dir,$_) = ('.', $topdir);
}
$name = $topdir;
--- 91,97 ----
}
}
else {
! unless (($_,$dir) = File::Basename::fileparse($topdir)) {
($dir,$_) = ('.', $topdir);
}
$name = $topdir;
***************
*** 142,147 ****
--- 143,149 ----
if (!$prune && chdir $_) {
$name =~ s/\.dir$// if $Is_VMS;
+ $name =~ s/\\dir$// if $Is_NT;
&finddir($wanted,$name,$nlink);
chdir '..';
}
***************
*** 167,172 ****
--- 169,175 ----
my $fixtopdir = $topdir;
$fixtopdir =~ s,/$,, ;
$fixtopdir =~ s/\.dir$// if $Is_VMS;
+ $fixtopdir =~ s/\\dir$// if $Is_NT;
&finddepthdir($wanted,$fixtopdir,$topnlink);
($dir,$_) = ($fixtopdir,'.');
$name = $fixtopdir;
***************
*** 177,183 ****
}
}
else {
! unless (($dir,$_) = File::Basename::fileparse($topdir)) {
($dir,$_) = ('.', $topdir);
}
chdir $dir && &$wanted;
--- 180,186 ----
}
}
else {
! unless (($_,$dir) = File::Basename::fileparse($topdir)) {
($dir,$_) = ('.', $topdir);
}
chdir $dir && &$wanted;
***************
*** 225,230 ****
--- 228,234 ----
if (chdir $_) {
$name =~ s/\.dir$// if $Is_VMS;
+ $name =~ s/\\dir$// if $Is_NT;
&finddepthdir($wanted,$name,$nlink);
chdir '..';
}
***************
*** 247,255 ****
$Is_VMS = 1;
$dont_use_nlink = 1;
}
$dont_use_nlink = 1 if $^O eq 'os2';
- $dont_use_nlink = 1 if $^O =~ m:^mswin32$:i ;
1;
--- 251,262 ----
$Is_VMS = 1;
$dont_use_nlink = 1;
}
+ if ($^O =~ m:^mswin32:i) {
+ $Is_NT = 1;
+ $dont_use_nlink = 1;
+ }
$dont_use_nlink = 1 if $^O eq 'os2';
1;
#~ Add FindBin library module
diff -Pcr perl5_003/lib/FindBin.pm perl5_003_01/lib/FindBin.pm
*** perl5_003/lib/FindBin.pm Wed Dec 31 19:00:00 1969
--- perl5_003_01/lib/FindBin.pm Fri Jun 21 15:27:09 1996
***************
*** 0 ****
--- 1,232 ----
+ # FindBin.pm
+ #
+ # Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
+ # This program is free software; you can redistribute it and/or modify it
+ # under the same terms as Perl itself.
+
+ =head1 NAME
+
+ FindBin - Locate directory of original perl script
+
+ =head1 SYNOPSIS
+
+ use FindBin;
+ BEGIN { unshift(@INC,"$FindBin::Bin/../lib") }
+
+ or
+
+ use FindBin qw($Bin);
+ BEGIN { unshift(@INC,"$Bin/../lib") }
+
+ =head1 DESCRIPTION
+
+ Locates the full path to the script bin directory to allow the use
+ of paths relative to the bin directory.
+
+ This allows a user to setup a directory tree for some software with
+ directories <root>/bin and <root>/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
+ C<STDIN> then FindBin sets both C<$Bin> and C<$RealBin> to the current
+ directory.
+
+ =head1 EXPORTABLE VARIABLES
+
+ $Bin - path to bin directory from where script was invoked
+ $Script - basename of script from which perl was invoked
+ $RealBin - $Bin with all links resolved
+ $RealScript - $Script with all links resolved
+
+ =head1 KNOWN BUGS
+
+ if perl is invoked as
+
+ perl filename
+
+ and I<filename> does not have executable rights and a program called I<filename>
+ exists in the users C<$ENV{PATH}> which satisfies both -x and -T then FindBin
+ assumes that it was invoked via the C<$ENV{PATH}>.
+
+ Workaround is to invoke perl as
+
+ perl ./filename
+
+ =head1 AUTHORS
+
+ Graham Barr <bodg@tiuk.ti.com>
+ Nick Ing-Simmons <nik@tiuk.ti.com>
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 1995 Graham Barr & Nick Ing-Simmons. All rights reserved.
+ This program is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.
+
+ =head1 REVISION
+
+ $Revision: 1.4 $
+
+ =cut
+
+ package FindBin;
+ use Carp;
+ require 5.000;
+ require Exporter;
+ use Cwd qw(getcwd);
+
+ @EXPORT_OK = qw($Bin $Script $RealBin $RealScript $Dir $RealDir);
+ %EXPORT_TAGS = (ALL => [qw($Bin $Script $RealBin $RealScript $Dir $RealDir)]);
+ @ISA = qw(Exporter);
+
+ $VERSION = $VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/);
+
+ # Taken from Cwd.pm It is really getcwd with an optional
+ # parameter instead of '.'
+ #
+ # another way would be:
+ #
+ #sub abs_path
+ #{
+ # my $cwd = getcwd();
+ # chdir(shift || '.');
+ # my $realpath = getcwd();
+ # chdir($cwd);
+ # $realpath;
+ #}
+
+ sub abs_path
+ {
+ my $start = shift || '.';
+ my($dotdots, $cwd, @pst, @cst, $dir, @tst);
+
+ unless (@cst = stat( $start ))
+ {
+ warn "stat($start): $!";
+ return '';
+ }
+ $cwd = '';
+ $dotdots = $start;
+ do
+ {
+ $dotdots .= '/..';
+ @pst = @cst;
+ unless (opendir(PARENT, $dotdots))
+ {
+ warn "opendir($dotdots): $!";
+ return '';
+ }
+ unless (@cst = stat($dotdots))
+ {
+ warn "stat($dotdots): $!";
+ closedir(PARENT);
+ return '';
+ }
+ if ($pst[0] == $cst[0] && $pst[1] == $cst[1])
+ {
+ $dir = '';
+ }
+ else
+ {
+ do
+ {
+ unless (defined ($dir = readdir(PARENT)))
+ {
+ warn "readdir($dotdots): $!";
+ closedir(PARENT);
+ return '';
+ }
+ $tst[0] = $pst[0]+1 unless (@tst = lstat("$dotdots/$dir"))
+ }
+ while ($dir eq '.' || $dir eq '..' || $tst[0] != $pst[0] ||
+ $tst[1] != $pst[1]);
+ }
+ $cwd = "$dir/$cwd";
+ closedir(PARENT);
+ } while ($dir);
+ chop($cwd); # drop the trailing /
+ $cwd;
+ }
+
+
+ BEGIN
+ {
+ *Dir = \$Bin;
+ *RealDir = \$RealBin;
+
+ if($0 eq '-e' || $0 eq '-')
+ {
+ # perl invoked with -e or script is on C<STDIN>
+
+ $Script = $RealScript = $0;
+ $Bin = $RealBin = getcwd();
+ }
+ else
+ {
+ my $script = $0;
+
+ if ($^O eq 'VMS')
+ {
+ ($Bin,$Script) = VMS::Filespec::rmsexpand($0) =~ /(.*\])(.*)/;
+ ($RealBin,$RealScript) = ($Bin,$Script);
+ }
+ else
+ {
+ unless($script =~ m#/# && -f $script)
+ {
+ my $dir;
+
+ foreach $dir (split(/:/,$ENV{PATH}))
+ {
+ if(-x "$dir/$script")
+ {
+ $script = "$dir/$script";
+
+ if (-f $0)
+ {
+ # $script has been found via PATH but perl could have
+ # been invoked as 'perl file'. Do a dumb check to see
+ # if $script is a perl program, if not then $script = $0
+ #
+ # well we actually only check that it is an ASCII file
+ # we know its executable so it is probably a script
+ # of some sort.
+
+ $script = $0 unless(-T $script);
+ }
+ last;
+ }
+ }
+ }
+
+ croak("Cannot find current script '$0'") unless(-f $script);
+
+ # Ensure $script contains the complete path incase we C<chdir>
+
+ $script = getcwd() . "/" . $script unless($script =~ m,^/,);
+
+ ($Bin,$Script) = $script =~ m,^(.*?)/+([^/]+)$,;
+
+ # Resolve $script if it is a link
+ while(1)
+ {
+ my $linktext = readlink($script);
+
+ ($RealBin,$RealScript) = $script =~ m,^(.*?)/+([^/]+)$,;
+ last unless defined $linktext;
+
+ $script = ($linktext =~ m,^/,)
+ ? $linktext
+ : $RealBin . "/" . $linktext;
+ }
+
+ # Get absolute paths to directories
+ $Bin = abs_path($Bin) if($Bin);
+ $RealBin = abs_path($RealBin) if($RealBin);
+ }
+ }
+ }
+
+ 1; # Keep require happy
+
#~ Update to version 2.3
diff -Pcr perl5_003/lib/Getopt/Long.pm perl5_003_01/lib/Getopt/Long.pm
*** perl5_003/lib/Getopt/Long.pm Mon Mar 25 01:04:44 1996
--- perl5_003_01/lib/Getopt/Long.pm Wed Jul 10 10:46:03 1996
***************
*** 1,11 ****
# GetOpt::Long.pm -- POSIX compatible options parsing
! # RCS Status : $Id: GetoptLong.pm,v 2.1 1996/02/02 20:24:35 jv Exp $
# Author : Johan Vromans
# Created On : Tue Sep 11 15:00:12 1990
# Last Modified By: Johan Vromans
! # Last Modified On: Fri Feb 2 21:24:32 1996
! # Update Count : 347
# Status : Released
package Getopt::Long;
--- 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 $
# 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
# Status : Released
package Getopt::Long;
***************
*** 14,20 ****
@ISA = qw(Exporter);
@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
! $VERSION = sprintf("%d.%02d", q$Revision: 2.1 $ =~ /(\d+)\.(\d+)/);
use strict;
=head1 NAME
--- 14,23 ----
@ISA = qw(Exporter);
@EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER);
! $VERSION = sprintf("%d.%02d", '$Revision: 2.3 $ ' =~ /(\d+)\.(\d+)/);
! use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order
! $error $debug $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER
! $VERSION $major_version $minor_version);
use strict;
=head1 NAME
***************
*** 32,40 ****
GetOptions(). This function adheres to the POSIX syntax for command
line options, with GNU extensions. In general, this means that options
have long names instead of single letters, and are introduced with a
! double dash "--". There is no bundling of command line options, as was
! the case with the more traditional single-letter approach. For
! example, the UNIX "ps" command can be given the command line "option"
-vax
--- 35,44 ----
GetOptions(). This function adheres to the POSIX syntax for command
line options, with GNU extensions. In general, this means that options
have long names instead of single letters, and are introduced with a
! double dash "--". Support for bundling of command line options, as was
! the case with the more traditional single-letter approach, is provided
! but not enabled by default. For example, the UNIX "ps" command can be
! given the command line "option"
-vax
***************
*** 366,374 ****
$RETURN_IN_ORDER is not supported by GetOptions().
! =item $Getopt::Long::ignorecase
! Ignore case when matching options. Default is 1.
=item $Getopt::Long::VERSION
--- 370,408 ----
$RETURN_IN_ORDER is not supported by GetOptions().
! =item $Getopt::Long::bundling
! Setting this variable to a non-zero value will allow single-character
! options to be bundled. To distinguish bundles from long option names,
! long options must be introduced with B<--> and single-character
! options (and bundles) with B<->. For example,
!
! ps -vax --vax
!
! would be equivalent to
!
! ps -v -a -x --vax
!
! provided "vax", "v", "a" and "x" have been defined to be valid
! options.
!
! Bundled options can also include a value in the bundle; this value has
! to be the last part of the bundle, e.g.
!
! scale -h24 -w80
!
! is equivalent to
!
! scale -h 24 -w 80
!
! B<Note:> Using option bundling can easily lead to unexpected results,
! especially when mixing long options and bundles. Caveat emptor.
!
! =item $Getopt::Long::ignorecase
!
! 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::VERSION
***************
*** 396,406 ****
################ Introduction ################
#
- # This package implements an extended getopt function. This function
- # adheres to the new syntax (long option names, no bundling). It tries
- # to implement the better functionality of traditional, GNU and POSIX
- # getopt functions.
- #
# This program is Copyright 1990,1996 by Johan Vromans.
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
--- 430,435 ----
***************
*** 416,465 ****
# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
# MA 02139, USA.
- ################ History ################
- #
- # 13-Jan-1996 Johan Vromans
- # Generalized the linkage interface.
- # Eliminated the linkage argument.
- # Add code references as a possible value for the option linkage.
- # Add option specifier <> to have a call-back for non-options.
- #
- # 26-Dec-1995 Johan Vromans
- # Import from netgetopt.pl.
- # Turned into a decent module.
- # Added linkage argument.
-
################ Configuration Section ################
# Values for $order. See GNU getopt.c for details.
! ($Getopt::Long::REQUIRE_ORDER,
! $Getopt::Long::PERMUTE,
! $Getopt::Long::RETURN_IN_ORDER) = (0..2);
my $gen_prefix; # generic prefix (option starters)
# Handle POSIX compliancy.
if ( defined $ENV{"POSIXLY_CORRECT"} ) {
! $gen_prefix = "(--|-)";
! $Getopt::Long::autoabbrev = 0; # no automatic abbrev of options
! $Getopt::Long::getopt_compat = 0; # disallow '+' to start options
! $Getopt::Long::order = $Getopt::Long::REQUIRE_ORDER;
}
else {
! $gen_prefix = "(--|-|\\+)";
! $Getopt::Long::autoabbrev = 1; # automatic abbrev of options
! $Getopt::Long::getopt_compat = 1; # allow '+' to start options
! $Getopt::Long::order = $Getopt::Long::PERMUTE;
}
# Other configurable settings.
! $Getopt::Long::debug = 0; # for debugging
! $Getopt::Long::error = 0; # error tally
! $Getopt::Long::ignorecase = 1; # ignore case when matching options
! ($Getopt::Long::version,
! $Getopt::Long::major_version,
! $Getopt::Long::minor_version) = '$Revision: 2.1 $ ' =~ /: ((\d+)\.(\d+))/;
! $Getopt::Long::version .= '*' if length('$Locker: $ ') > 12;
################ Subroutines ################
--- 445,478 ----
# the Free Software Foundation, Inc., 675 Mass Ave, Cambridge,
# MA 02139, USA.
################ Configuration Section ################
# Values for $order. See GNU getopt.c for details.
! ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2);
my $gen_prefix; # generic prefix (option starters)
# Handle POSIX compliancy.
if ( defined $ENV{"POSIXLY_CORRECT"} ) {
! $gen_prefix = "--|-";
! $autoabbrev = 0; # no automatic abbrev of options
! $bundling = 0; # no bundling of single letter switches
! $getopt_compat = 0; # disallow '+' to start options
! $order = $REQUIRE_ORDER;
}
else {
! $gen_prefix = "--|-|\\+";
! $autoabbrev = 1; # automatic abbrev of options
! $bundling = 0; # bundling off by default
! $getopt_compat = 1; # allow '+' to start options
! $order = $PERMUTE;
}
# Other configurable settings.
! $debug = 0; # for debugging
! $error = 0; # error tally
! $ignorecase = 1; # ignore case when matching options
! ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/;
################ Subroutines ################
***************
*** 467,492 ****
my @optionlist = @_; # local copy of the option descriptions
my $argend = '--'; # option list terminator
! my %opctl; # table of arg.specs
my $pkg = (caller)[0]; # current context
# Needed if linkage is omitted.
my %aliases; # alias table
my @ret = (); # accum for non-options
my %linkage; # linkage
my $userlinkage; # user supplied HASH
- my $debug = $Getopt::Long::debug; # convenience
my $genprefix = $gen_prefix; # so we can call the same module more
# than once in differing environments
! $Getopt::Long::error = 0;
! print STDERR ("GetOptions $Getopt::Long::version",
! " [GetOpt::Long $Getopt::Long::VERSION] -- ",
"called from package \"$pkg\".\n",
! " autoabbrev=$Getopt::Long::autoabbrev".
! ",getopt_compat=$Getopt::Long::getopt_compat",
",genprefix=\"$genprefix\"",
! ",order=$Getopt::Long::order",
! ",ignorecase=$Getopt::Long::ignorecase",
".\n")
if $debug;
--- 480,506 ----
my @optionlist = @_; # local copy of the option descriptions
my $argend = '--'; # option list terminator
! my %opctl; # table of arg.specs (long and abbrevs)
! my %bopctl; # table of arg.specs (bundles)
my $pkg = (caller)[0]; # current context
# Needed if linkage is omitted.
my %aliases; # alias table
my @ret = (); # accum for non-options
my %linkage; # linkage
my $userlinkage; # user supplied HASH
my $genprefix = $gen_prefix; # so we can call the same module more
# than once in differing environments
! $error = 0;
! print STDERR ('GetOptions $Revision: 2.3 $ ',
! "[GetOpt::Long $Getopt::Long::VERSION] -- ",
"called from package \"$pkg\".\n",
! " autoabbrev=$autoabbrev".
! ",bundling=$bundling",
! ",getopt_compat=$getopt_compat",
",genprefix=\"$genprefix\"",
! ",order=$order",
! ",ignorecase=$ignorecase",
".\n")
if $debug;
***************
*** 507,517 ****
# Verify correctness of optionlist.
%opctl = ();
while ( @optionlist > 0 ) {
my $opt = shift (@optionlist);
# Strip leading prefix so people can specify "-foo=i" if they like.
! $opt = $' if $opt =~ /^($genprefix)+/;
if ( $opt eq '<>' ) {
if ( (defined $userlinkage)
--- 521,532 ----
# Verify correctness of optionlist.
%opctl = ();
+ %bopctl = ();
while ( @optionlist > 0 ) {
my $opt = shift (@optionlist);
# Strip leading prefix so people can specify "-foo=i" if they like.
! $opt = $2 if $opt =~ /^($genprefix)+([\x00-\xff]*)/;
if ( $opt eq '<>' ) {
if ( (defined $userlinkage)
***************
*** 523,557 ****
unless ( @optionlist > 0
&& ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
warn ("Option spec <> requires a reference to a subroutine\n");
! $Getopt::Long::error++;
next;
}
$linkage{'<>'} = shift (@optionlist);
next;
}
- $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase;
if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
warn ("Error in option spec: \"", $opt, "\"\n");
! $Getopt::Long::error++;
next;
}
my ($o, $c, $a) = ($1, $2);
if ( ! defined $o ) {
# empty -> '-' option
! $opctl{$o = ''} = defined $c ? $c : '';
}
else {
# Handle alias names
my @o = split (/\|/, $o);
$o = $o[0];
foreach ( @o ) {
! if ( defined $c && $c eq '!' ) {
! $opctl{"no$_"} = $c;
! $c = '';
}
- $opctl{$_} = defined $c ? $c : '';
if ( defined $a ) {
# Note alias.
$aliases{$_} = $a;
--- 538,589 ----
unless ( @optionlist > 0
&& ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) {
warn ("Option spec <> requires a reference to a subroutine\n");
! $error++;
next;
}
$linkage{'<>'} = shift (@optionlist);
next;
}
if ( $opt !~ /^(\w+[-\w|]*)?(!|[=:][infse]@?)?$/ ) {
warn ("Error in option spec: \"", $opt, "\"\n");
! $error++;
next;
}
my ($o, $c, $a) = ($1, $2);
+ $c = '' unless defined $c;
if ( ! defined $o ) {
# empty -> '-' option
! $opctl{$o = ''} = $c;
}
else {
# Handle alias names
my @o = split (/\|/, $o);
$o = $o[0];
+ $o = lc ($o)
+ if $ignorecase > 1
+ || ($ignorecase
+ && ($bundling ? length($o) > 1 : 1));
+
foreach ( @o ) {
! if ( $bundling && length($_) == 1 ) {
! $_ = lc ($_) if $ignorecase > 1;
! if ( $c eq '!' ) {
! $opctl{"no$_"} = $c;
! warn ("Ignoring '!' modifier for short option $_\n");
! $c = '';
! }
! $bopctl{$_} = $c;
! }
! else {
! $_ = lc ($_) if $ignorecase;
! if ( $c eq '!' ) {
! $opctl{"no$_"} = $c;
! $c = '';
! }
! $opctl{$_} = $c;
}
if ( defined $a ) {
# Note alias.
$aliases{$_} = $a;
***************
*** 584,597 ****
if ( @optionlist > 0 && ref($optionlist[0]) ) {
print STDERR ("=> link \"$o\" to $optionlist[0]\n")
if $debug;
! if ( ref($optionlist[0]) eq 'SCALAR'
! || ref($optionlist[0]) eq 'ARRAY'
! || ref($optionlist[0]) eq 'CODE' ) {
$linkage{$o} = shift (@optionlist);
}
else {
warn ("Invalid option linkage for \"", $opt, "\"\n");
! $Getopt::Long::error++;
}
}
else {
--- 616,627 ----
if ( @optionlist > 0 && ref($optionlist[0]) ) {
print STDERR ("=> link \"$o\" to $optionlist[0]\n")
if $debug;
! if ( ref($optionlist[0]) =~ /^(SCALAR|ARRAY|CODE)$/ ) {
$linkage{$o} = shift (@optionlist);
}
else {
warn ("Invalid option linkage for \"", $opt, "\"\n");
! $error++;
}
}
else {
***************
*** 599,605 ****
# Make sure a valid perl identifier results.
my $ov = $o;
$ov =~ s/\W/_/g;
! if ( $c && $c =~ /@/ ) {
print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
if $debug;
eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
--- 629,635 ----
# Make sure a valid perl identifier results.
my $ov = $o;
$ov =~ s/\W/_/g;
! if ( defined($c) && $c =~ /@/ ) {
print STDERR ("=> link \"$o\" to \@$pkg","::opt_$ov\n")
if $debug;
eval ("\$linkage{\$o} = \\\@".$pkg."::opt_$ov;");
***************
*** 613,624 ****
}
# Bail out if errors found.
! return 0 if $Getopt::Long::error;
! # Sort the possible option names.
! my @opctl = sort(keys (%opctl)) if $Getopt::Long::autoabbrev;
! # Show if debugging.
if ( $debug ) {
my ($arrow, $k, $v);
$arrow = "=> ";
--- 643,654 ----
}
# Bail out if errors found.
! return 0 if $error;
! # Sort the possible long option names.
! my @opctl = sort(keys (%opctl)) if $autoabbrev;
! # Show the options tables if debugging.
if ( $debug ) {
my ($arrow, $k, $v);
$arrow = "=> ";
***************
*** 626,635 ****
print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
$arrow = " ";
}
}
my $opt; # current option
! my $arg; # current option value
my $array; # current option is array typed
# Process argument list
--- 656,670 ----
print STDERR ($arrow, "\$opctl{\"$k\"} = \"$v\"\n");
$arrow = " ";
}
+ $arrow = "=> ";
+ while ( ($k,$v) = each(%bopctl) ) {
+ print STDERR ($arrow, "\$bopctl{\"$k\"} = \"$v\"\n");
+ $arrow = " ";
+ }
}
my $opt; # current option
! my $arg; # current option value, if any
my $array; # current option is array typed
# Process argument list
***************
*** 639,647 ****
#### Get next argument ####
$opt = shift (@ARGV);
$arg = undef;
- my $optarg = undef;
$array = 0;
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
--- 674,685 ----
#### 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;
print STDERR ("=> option \"", $opt, "\"\n") if $debug;
***************
*** 651,668 ****
if ( $opt eq $argend ) {
# Finish. Push back accumulated arguments and return.
unshift (@ARGV, @ret)
! if $Getopt::Long::order == $Getopt::Long::PERMUTE;
! return ($Getopt::Long::error == 0);
}
! if ( $opt =~ /^$genprefix/ ) {
# Looks like an option.
! $opt = $'; # option name (w/o prefix)
! # If it is a long opt, it may include the value.
! if (($& eq "--" || ($Getopt::Long::getopt_compat && $& eq "+"))
! && $opt =~ /^([^=]+)=/ ) {
$opt = $1;
! $optarg = $';
print STDERR ("=> option \"", $opt,
"\", optarg = \"$optarg\"\n") if $debug;
}
--- 689,709 ----
if ( $opt eq $argend ) {
# Finish. Push back accumulated arguments and return.
unshift (@ARGV, @ret)
! if $order == $PERMUTE;
! 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;
}
***************
*** 670,682 ****
}
# Not an option. Save it if we $PERMUTE and don't have a <>.
! elsif ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) {
# Try non-options call-back.
my $cb;
if ( (defined ($cb = $linkage{'<>'})) ) {
&$cb($opt);
}
else {
push (@ret, $opt);
}
next;
--- 711,725 ----
}
# Not an option. Save it if we $PERMUTE and don't have a <>.
! elsif ( $order == $PERMUTE ) {
# Try non-options call-back.
my $cb;
if ( (defined ($cb = $linkage{'<>'})) ) {
&$cb($opt);
}
else {
+ print STDERR ("=> saving \"$opt\" ",
+ "(not an option, may permute)\n") if $debug;
push (@ret, $opt);
}
next;
***************
*** 686,714 ****
else {
# Push this one back and exit.
unshift (@ARGV, $opt);
! return ($Getopt::Long::error == 0);
}
#### Look it up ###
! $opt =~ tr/A-Z/a-z/ if $Getopt::Long::ignorecase;
!
! my $tryopt = $opt;
! if ( $Getopt::Long::autoabbrev ) {
! my $pat;
# Turn option name into pattern.
! ($pat = $opt) =~ s/(\W)/\\$1/g;
# Look up in option names.
my @hits = grep (/^$pat/, @opctl);
! print STDERR ("=> ", 0+@hits, " hits (@hits) with \"$pat\" ",
! "out of ", 0+@opctl, "\n") if $debug;
# Check for ambiguous results.
unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) {
print STDERR ("Option ", $opt, " is ambiguous (",
join(", ", @hits), ")\n");
! $Getopt::Long::error++;
next;
}
--- 729,769 ----
else {
# Push this one back and exit.
unshift (@ARGV, $opt);
! 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) ) {
print STDERR ("Option ", $opt, " is ambiguous (",
join(", ", @hits), ")\n");
! $error++;
next;
}
***************
*** 720,731 ****
}
}
! my $type;
! unless ( defined ( $type = $opctl{$tryopt} ) ) {
! print STDERR ("Unknown option: ", $opt, "\n");
! $Getopt::Long::error++;
next;
}
$opt = $tryopt;
print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
--- 775,788 ----
}
}
! # Check validity by fetching the info.
! my $type = $optbl->{$tryopt};
! unless ( defined $type ) {
! warn ("Unknown option: ", $opt, "\n");
! $error++;
next;
}
+ # Apparently valid.
$opt = $tryopt;
print STDERR ("=> found \"$type\" for ", $opt, "\n") if $debug;
***************
*** 735,741 ****
if ( $type eq '' || $type eq '!' ) {
if ( defined $optarg ) {
print STDERR ("Option ", $opt, " does not take an argument\n");
! $Getopt::Long::error++;
}
elsif ( $type eq '' ) {
$arg = 1; # supply explicit value
--- 792,798 ----
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
***************
*** 744,749 ****
--- 801,808 ----
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;
}
***************
*** 752,763 ****
($mand, $type, $array) = $type =~ /^(.)(.)(@?)$/;
# Check if there is an option argument available.
! if ( defined $optarg ? ($optarg eq '') : (@ARGV <= 0) ) {
!
# Complain if this option needs an argument.
if ( $mand eq "=" ) {
print STDERR ("Option ", $opt, " requires an argument\n");
! $Getopt::Long::error++;
}
if ( $mand eq ":" ) {
$arg = $type eq "s" ? '' : 0;
--- 811,822 ----
($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;
***************
*** 766,772 ****
}
# Get (possibly optional) argument.
! $arg = defined $optarg ? $optarg : shift (@ARGV);
#### Check if the argument is valid for this option ####
--- 825,832 ----
}
# Get (possibly optional) argument.
! $arg = (defined $rest ? $rest
! : (defined $optarg ? $optarg : shift (@ARGV)));
#### Check if the argument is valid for this option ####
***************
*** 775,782 ****
next if $mand eq "=";
# An optional string takes almost anything.
! next if defined $optarg;
! next if $arg eq "-";
# Check for option or option list terminator.
if ($arg eq $argend ||
--- 835,842 ----
next if $mand eq "=";
# An optional string takes almost anything.
! next if defined $optarg || defined $rest;
! next if $arg eq "-"; # ??
# Check for option or option list terminator.
if ($arg eq $argend ||
***************
*** 794,805 ****
if ( defined $optarg || $mand eq "=" ) {
print STDERR ("Value \"", $arg, "\" invalid for option ",
$opt, " (number expected)\n");
! $Getopt::Long::error++;
undef $arg; # don't assign it
}
else {
# Push back.
! unshift (@ARGV, $arg);
# Supply default value.
$arg = 0;
}
--- 854,867 ----
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;
}
***************
*** 812,823 ****
if ( defined $optarg || $mand eq "=" ) {
print STDERR ("Value \"", $arg, "\" invalid for option ",
$opt, " (real number expected)\n");
! $Getopt::Long::error++;
undef $arg; # don't assign it
}
else {
# Push back.
! unshift (@ARGV, $arg);
# Supply default value.
$arg = 0.0;
}
--- 874,887 ----
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;
}
***************
*** 877,891 ****
}
# Finish.
! if ( $Getopt::Long::order == $Getopt::Long::PERMUTE ) {
# Push back accumulated arguments
unshift (@ARGV, @ret) if @ret > 0;
}
! return ($Getopt::Long::error == 0);
}
################ Package return ################
! # Returning 1 is so boring...
! $Getopt::Long::major_version * 1000 + $Getopt::Long::minor_version;
--- 941,956 ----
}
# 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);
}
################ Package return ################
! 1;
#~ Eliminate $& to avoid runtime penalty
diff -Pcr perl5_003/lib/IPC/Open2.pm perl5_003_01/lib/IPC/Open2.pm
*** perl5_003/lib/IPC/Open2.pm Mon Jan 29 17:49:57 1996
--- perl5_003_01/lib/IPC/Open2.pm Wed May 1 17:10:17 1996
***************
*** 80,87 ****
# force unqualified filehandles into callers' package
local($package) = caller;
! $dad_rdr =~ s/^[^']+$/$package'$&/ unless ref $dad_rdr;
! $dad_wtr =~ s/^[^']+$/$package'$&/ unless ref $dad_wtr;
local($kid_rdr) = ++$fh;
local($kid_wtr) = ++$fh;
--- 80,87 ----
# force unqualified filehandles into callers' package
local($package) = caller;
! $dad_rdr =~ s/^([^']+$)/$package'$1/ unless ref $dad_rdr;
! $dad_wtr =~ s/^([^']+$)/$package'$1/ unless ref $dad_wtr;
local($kid_rdr) = ++$fh;
local($kid_wtr) = ++$fh;
#~ Eliminate $& to avoid runtime penalty
diff -Pcr perl5_003/lib/IPC/Open3.pm perl5_003_01/lib/IPC/Open3.pm
*** perl5_003/lib/IPC/Open3.pm Mon Jan 29 17:50:03 1996
--- perl5_003_01/lib/IPC/Open3.pm Wed May 1 17:10:19 1996
***************
*** 83,91 ****
# force unqualified filehandles into callers' package
my($package) = caller;
! $dad_wtr =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_wtr;
! $dad_rdr =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_rdr;
! $dad_err =~ s/^[^:]+$/$package\:\:$&/ unless ref $dad_err;
my($kid_rdr) = ++$fh;
my($kid_wtr) = ++$fh;
--- 83,91 ----
# force unqualified filehandles into callers' package
my($package) = caller;
! $dad_wtr =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_wtr;
! $dad_rdr =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_rdr;
! $dad_err =~ s/^([^:]+$)/$package\:\:$1/ unless ref $dad_err;
my($kid_rdr) = ++$fh;
my($kid_wtr) = ++$fh;
#~ Extend to handle 8-bit characters in input
diff -Pcr perl5_003/lib/Pod/Text.pm perl5_003_01/lib/Pod/Text.pm
*** perl5_003/lib/Pod/Text.pm Mon Mar 25 01:04:47 1996
--- perl5_003_01/lib/Pod/Text.pm Thu Jul 4 14:50:29 1996
***************
*** 357,365 ****
sub init_noremap {
die "unmatched init" if $mapready++;
! if ( /[\200-\377]/ ) {
! warn "hit bit char in input stream";
! }
}
sub clear_noremap {
--- 357,364 ----
sub init_noremap {
die "unmatched init" if $mapready++;
! #mask off high bit characters in input stream
! s/([\200-\377])/"E<".ord($1).">"/ge;
}
sub clear_noremap {
***************
*** 370,382 ****
# otherwise the interative \w<> processing would have
# been hosed by the E<gt>
s {
! E<
! ( [A-Za-z]+ )
>
} {
do {
! defined $HTML_Escapes{$1}
! ? do { $HTML_Escapes{$1} }
: do {
warn "Unknown escape: $& in $_";
"E<$1>";
--- 369,387 ----
# otherwise the interative \w<> processing would have
# been hosed by the E<gt>
s {
! E<
! (
! ( \d+ )
! | ( [A-Za-z]+ )
! )
>
} {
do {
! defined $2
! ? chr($2)
! :
! defined $HTML_Escapes{$3}
! ? do { $HTML_Escapes{$3} }
: do {
warn "Unknown escape: $& in $_";
"E<$1>";
#~ Update docs
diff -Pcr perl5_003/lib/SelfLoader.pm perl5_003_01/lib/SelfLoader.pm
*** perl5_003/lib/SelfLoader.pm Mon Jan 22 20:43:10 1996
--- perl5_003_01/lib/SelfLoader.pm Thu Jul 11 12:22:46 1996
***************
*** 119,235 ****
=head1 DESCRIPTION
This module tells its users that functions in the FOOBAR package are to be
! autoloaded from after the __DATA__ token. See also L<perlsub/"Autoloading">.
=head2 The __DATA__ token
! The __DATA__ token tells the perl compiler that the perl code
! for compilation is finished. Everything after the __DATA__ token
is available for reading via the filehandle FOOBAR::DATA,
! where FOOBAR is the name of the current package when the __DATA__
! token is reached. This works just the same as __END__ does in
! package 'main', but for other modules data after __END__ is not
! automatically retreivable , whereas data after __DATA__ is.
! The __DATA__ token is not recognized in versions of perl prior to
5.001m.
! Note that it is possible to have __DATA__ tokens in the same package
! in multiple files, and that the last __DATA__ token in a given
package that is encountered by the compiler is the one accessible
! by the filehandle. This also applies to __END__ and main, i.e. if
! the 'main' program has an __END__, but a module 'require'd (_not_ 'use'd)
! by that program has a 'package main;' declaration followed by an '__DATA__',
! then the DATA filehandle is set to access the data after the __DATA__
! in the module, _not_ the data after the __END__ token in the 'main'
program, since the compiler encounters the 'require'd file later.
=head2 SelfLoader autoloading
! The SelfLoader works by the user placing the __DATA__
! token _after_ perl code which needs to be compiled and
! run at 'require' time, but _before_ subroutine declarations
that can be loaded in later - usually because they may never
be called.
! The SelfLoader will read from the FOOBAR::DATA filehandle to
! load in the data after __DATA__, and load in any subroutine
when it is called. The costs are the one-time parsing of the
! data after __DATA__, and a load delay for the _first_
call of any autoloaded function. The benefits (hopefully)
are a speeded up compilation phase, with no need to load
functions which are never used.
! The SelfLoader will stop reading from __DATA__ if
! it encounters the __END__ token - just as you would expect.
! If the __END__ token is present, and is followed by the
! token DATA, then the SelfLoader leaves the FOOBAR::DATA
filehandle open on the line after that token.
! The SelfLoader exports the AUTOLOAD subroutine to the
! package using the SelfLoader, and this loads the called
subroutine when it is first called.
There is no advantage to putting subroutines which will _always_
! be called after the __DATA__ token.
=head2 Autoloading and package lexicals
A 'my $pack_lexical' statement makes the variable $pack_lexical
! local _only_ to the file up to the __DATA__ token. Subroutines
declared elsewhere _cannot_ see these types of variables,
just as if you declared subroutines in the package but in another
file, they cannot see these variables.
So specifically, autoloaded functions cannot see package
! lexicals (this applies to both the SelfLoader and the Autoloader).
=head2 SelfLoader and AutoLoader
! The SelfLoader can replace the AutoLoader - just change 'use AutoLoader'
! to 'use SelfLoader' (though note that the SelfLoader exports
the AUTOLOAD function - but if you have your own AUTOLOAD and
are using the AutoLoader too, you probably know what you're doing),
! and the __END__ token to __DATA__. You will need perl version 5.001m
or later to use this (version 5.001 with all patches up to patch m).
! There is no need to inherit from the SelfLoader.
! The SelfLoader works similarly to the AutoLoader, but picks up the
! subs from after the __DATA__ instead of in the 'lib/auto' directory.
There is a maintainance gain in not needing to run AutoSplit on the module
at installation, and a runtime gain in not needing to keep opening and
closing files to load subs. There is a runtime loss in needing
! to parse the code after the __DATA__.
=head2 __DATA__, __END__, and the FOOBAR::DATA filehandle.
This section is only relevant if you want to use
! the FOOBAR::DATA together with the SelfLoader.
! Data after the __DATA__ token in a module is read using the
! FOOBAR::DATA filehandle. __END__ can still be used to denote the end
! of the __DATA__ section if followed by the token DATA - this is supported
! by the SelfLoader. The FOOBAR::DATA filehandle is left open if an __END__
! followed by a DATA is found, with the filehandle positioned at the start
! of the line after the __END__ token. If no __END__ token is present,
! or an __END__ token with no DATA token on the same line, then the filehandle
! is closed.
!
! The SelfLoader reads from wherever the current
! position of the FOOBAR::DATA filehandle is, until the
! EOF or __END__. This means that if you want to use
that filehandle (and ONLY if you want to), you should either
1. Put all your subroutine declarations immediately after
! the __DATA__ token and put your own data after those
! declarations, using the __END__ token to mark the end
! of subroutine declarations. You must also ensure that the SelfLoader
reads first by calling 'SelfLoader->load_stubs();', or by using a
function which is selfloaded;
or
! 2. You should read the FOOBAR::DATA filehandle first, leaving
the handle open and positioned at the first line of subroutine
declarations.
--- 119,241 ----
=head1 DESCRIPTION
This module tells its users that functions in the FOOBAR package are to be
! autoloaded from after the C<__DATA__> token. See also
! L<perlsub/"Autoloading">.
=head2 The __DATA__ token
! The C<__DATA__> token tells the perl compiler that the perl code
! for compilation is finished. Everything after the C<__DATA__> token
is available for reading via the filehandle FOOBAR::DATA,
! where FOOBAR is the name of the current package when the C<__DATA__>
! token is reached. This works just the same as C<__END__> does in
! package 'main', but for other modules data after C<__END__> is not
! automatically retreivable , whereas data after C<__DATA__> is.
! The C<__DATA__> token is not recognized in versions of perl prior to
5.001m.
! Note that it is possible to have C<__DATA__> tokens in the same package
! in multiple files, and that the last C<__DATA__> token in a given
package that is encountered by the compiler is the one accessible
! by the filehandle. This also applies to C<__END__> and main, i.e. if
! the 'main' program has an C<__END__>, but a module 'require'd (_not_ 'use'd)
! by that program has a 'package main;' declaration followed by an 'C<__DATA__>',
! then the C<DATA> filehandle is set to access the data after the C<__DATA__>
! in the module, _not_ the data after the C<__END__> token in the 'main'
program, since the compiler encounters the 'require'd file later.
=head2 SelfLoader autoloading
! The B<SelfLoader> works by the user placing the C<__DATA__>
! token I<after> perl code which needs to be compiled and
! run at 'require' time, but I<before> subroutine declarations
that can be loaded in later - usually because they may never
be called.
! The B<SelfLoader> will read from the FOOBAR::DATA filehandle to
! load in the data after C<__DATA__>, and load in any subroutine
when it is called. The costs are the one-time parsing of the
! data after C<__DATA__>, and a load delay for the _first_
call of any autoloaded function. The benefits (hopefully)
are a speeded up compilation phase, with no need to load
functions which are never used.
! The B<SelfLoader> will stop reading from C<__DATA__> if
! it encounters the C<__END__> token - just as you would expect.
! If the C<__END__> token is present, and is followed by the
! token DATA, then the B<SelfLoader> leaves the FOOBAR::DATA
filehandle open on the line after that token.
! The B<SelfLoader> exports the C<AUTOLOAD> subroutine to the
! package using the B<SelfLoader>, and this loads the called
subroutine when it is first called.
There is no advantage to putting subroutines which will _always_
! be called after the C<__DATA__> token.
=head2 Autoloading and package lexicals
A 'my $pack_lexical' statement makes the variable $pack_lexical
! local _only_ to the file up to the C<__DATA__> token. Subroutines
declared elsewhere _cannot_ see these types of variables,
just as if you declared subroutines in the package but in another
file, they cannot see these variables.
So specifically, autoloaded functions cannot see package
! lexicals (this applies to both the B<SelfLoader> and the Autoloader).
! The C<vars> pragma provides an alternative to defining package-level
! globals that will be visible to autoloaded routines. See the documentation
! on B<vars> in the pragma section of L<perlmod>.
=head2 SelfLoader and AutoLoader
! The B<SelfLoader> can replace the AutoLoader - just change 'use AutoLoader'
! to 'use SelfLoader' (though note that the B<SelfLoader> exports
the AUTOLOAD function - but if you have your own AUTOLOAD and
are using the AutoLoader too, you probably know what you're doing),
! and the C<__END__> token to C<__DATA__>. You will need perl version 5.001m
or later to use this (version 5.001 with all patches up to patch m).
! There is no need to inherit from the B<SelfLoader>.
! The B<SelfLoader> works similarly to the AutoLoader, but picks up the
! subs from after the C<__DATA__> instead of in the 'lib/auto' directory.
There is a maintainance gain in not needing to run AutoSplit on the module
at installation, and a runtime gain in not needing to keep opening and
closing files to load subs. There is a runtime loss in needing
! to parse the code after the C<__DATA__>. Details of the B<AutoLoader> and
! another view of these distinctions can be found in that module's
! documentation.
=head2 __DATA__, __END__, and the FOOBAR::DATA filehandle.
This section is only relevant if you want to use
! the C<FOOBAR::DATA> together with the B<SelfLoader>.
! Data after the C<__DATA__> token in a module is read using the
! FOOBAR::DATA filehandle. C<__END__> can still be used to denote the end
! of the C<__DATA__> section if followed by the token DATA - this is supported
! by the B<SelfLoader>. The C<FOOBAR::DATA> filehandle is left open if an
! C<__END__> followed by a DATA is found, with the filehandle positioned at
! the start of the line after the C<__END__> token. If no C<__END__> token is
! present, or an C<__END__> token with no DATA token on the same line, then
! the filehandle is closed.
!
! The B<SelfLoader> reads from wherever the current
! position of the C<FOOBAR::DATA> filehandle is, until the
! EOF or C<__END__>. This means that if you want to use
that filehandle (and ONLY if you want to), you should either
1. Put all your subroutine declarations immediately after
! the C<__DATA__> token and put your own data after those
! declarations, using the C<__END__> token to mark the end
! of subroutine declarations. You must also ensure that the B<SelfLoader>
reads first by calling 'SelfLoader->load_stubs();', or by using a
function which is selfloaded;
or
! 2. You should read the C<FOOBAR::DATA> filehandle first, leaving
the handle open and positioned at the first line of subroutine
declarations.
***************
*** 255,262 ****
adding the statement 'SelfLoader->load_stubs();' to the module to do
this.
! The alternative is to put the stubs in before the __DATA__ token BEFORE
! releasing the module, and for this purpose the Devel::SelfStubber
module is available. However this does require the extra step of ensuring
that the stubs are in the module. If this is done I strongly recommend
that this is done BEFORE releasing the module - it should NOT be done
--- 261,268 ----
adding the statement 'SelfLoader->load_stubs();' to the module to do
this.
! The alternative is to put the stubs in before the C<__DATA__> token BEFORE
! releasing the module, and for this purpose the C<Devel::SelfStubber>
module is available. However this does require the extra step of ensuring
that the stubs are in the module. If this is done I strongly recommend
that this is done BEFORE releasing the module - it should NOT be done
***************
*** 265,274 ****
=head1 Multiple packages and fully qualified subroutine names
Subroutines in multiple packages within the same file are supported - but you
! should note that this requires exporting the SelfLoader::AUTOLOAD to
every package which requires it. This is done automatically by the
! SelfLoader when it first loads the subs into the cache, but you should
! really specify it in the initialization before the __DATA__ by putting
a 'use SelfLoader' statement in each package.
Fully qualified subroutine names are also supported. For example,
--- 271,280 ----
=head1 Multiple packages and fully qualified subroutine names
Subroutines in multiple packages within the same file are supported - but you
! should note that this requires exporting the C<SelfLoader::AUTOLOAD> to
every package which requires it. This is done automatically by the
! B<SelfLoader> when it first loads the subs into the cache, but you should
! really specify it in the initialization before the C<__DATA__> by putting
a 'use SelfLoader' statement in each package.
Fully qualified subroutine names are also supported. For example,
***************
*** 278,285 ****
package baz;
sub dob {32}
! will all be loaded correctly by the SelfLoader, and the SelfLoader
will ensure that the packages 'foo' and 'baz' correctly have the
! SelfLoader AUTOLOAD method when the data after __DATA__ is first parsed.
=cut
--- 284,292 ----
package baz;
sub dob {32}
! will all be loaded correctly by the B<SelfLoader>, and the B<SelfLoader>
will ensure that the packages 'foo' and 'baz' correctly have the
! B<SelfLoader> C<AUTOLOAD> method when the data after C<__DATA__> is first
! parsed.
=cut
#~ Incorporate new "use <version>" syntax
diff -Pcr perl5_003/lib/Symbol.pm perl5_003_01/lib/Symbol.pm
*** perl5_003/lib/Symbol.pm Mon Jun 24 16:07:54 1996
--- perl5_003_01/lib/Symbol.pm Sun Jul 7 20:02:46 1996
***************
*** 46,52 ****
=cut
! BEGIN { require 5.002; }
require Exporter;
@ISA = qw(Exporter);
--- 46,52 ----
=cut
! use 5.002;
require Exporter;
@ISA = qw(Exporter);
#~ Fix VMS test to eliminate void context warning
diff -Pcr perl5_003/lib/Sys/Hostname.pm perl5_003_01/lib/Sys/Hostname.pm
*** perl5_003/lib/Sys/Hostname.pm Mon Mar 25 01:04:48 1996
--- perl5_003_01/lib/Sys/Hostname.pm Tue May 14 21:53:41 1996
***************
*** 39,45 ****
if ($^O eq 'VMS') {
# method 2 - no sockets ==> return DECnet node name
! eval {gethostbyname('me')};
if ($@) { return $host = $ENV{'SYS$NODE'}; }
# method 3 - has someone else done the job already? It's common for the
--- 39,45 ----
if ($^O eq 'VMS') {
# method 2 - no sockets ==> return DECnet node name
! eval {my($test) = gethostbyname('me')}; # returns 'me' on most systems
if ($@) { return $host = $ENV{'SYS$NODE'}; }
# method 3 - has someone else done the job already? It's common for the
#~ Correct documentation for calling sequence of syslog() function
#~ Move call to hostname() into connect() function, and eliminate domain suffix
diff -Pcr perl5_003/lib/Sys/Syslog.pm perl5_003_01/lib/Sys/Syslog.pm
*** perl5_003/lib/Sys/Syslog.pm Mon Mar 25 01:04:48 1996
--- perl5_003_01/lib/Sys/Syslog.pm Tue Jun 18 20:30:13 1996
***************
*** 23,29 ****
use Sys::Syslog;
openlog $ident, $logopt, $facility;
! syslog $priority, $mask, $format, @args;
$oldmask = setlogmask $mask_priority;
closelog;
--- 23,29 ----
use Sys::Syslog;
openlog $ident, $logopt, $facility;
! syslog $priority, $format, @args;
$oldmask = setlogmask $mask_priority;
closelog;
***************
*** 43,51 ****
I<$logopt> contains one or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>.
I<$facility> specifies the part of the system
! =item syslog $priority, $mask, $format, @args
! If I<$priority> and I<$mask> permit, logs I<($format, @args)>
printed as by C<printf(3V)>, with the addition that I<%m>
is replaced with C<"$!"> (the latest error message).
--- 43,51 ----
I<$logopt> contains one or more of the words I<pid>, I<ndelay>, I<cons>, I<nowait>.
I<$facility> specifies the part of the system
! =item syslog $priority, $format, @args
! If I<$priority> permits, logs I<($format, @args)>
printed as by C<printf(3V)>, with the addition that I<%m>
is replaced with C<"$!"> (the latest error message).
***************
*** 89,96 ****
=cut
- $host = hostname() unless $host; # set $Syslog::host to change
-
require 'syslog.ph';
$maskpri = &LOG_UPTO(&LOG_DEBUG);
--- 89,94 ----
***************
*** 201,207 ****
sub connect {
unless ($host) {
require Sys::Hostname;
! $host = Sys::Hostname::hostname();
}
my $udp = getprotobyname('udp');
my $syslog = getservbyname('syslog','udp');
--- 199,206 ----
sub connect {
unless ($host) {
require Sys::Hostname;
! my($host_uniq) = Sys::Hostname::hostname();
! ($host) = $host_uniq =~ /(\w+)/;
}
my $udp = getprotobyname('udp');
my $syslog = getservbyname('syslog','udp');
#~ Incorporate new "use <version>" syntax
#~ Update to version 1.12, providing improved "skipped" message and
#~ first-pass Unix support for Devel::CoreStack
diff -Pcr perl5_003/lib/Test/Harness.pm perl5_003_01/lib/Test/Harness.pm
*** perl5_003/lib/Test/Harness.pm Mon Feb 12 14:55:52 1996
--- perl5_003_01/lib/Test/Harness.pm Tue Jul 9 12:22:00 1996
***************
*** 1,13 ****
package Test::Harness;
use Exporter;
use Benchmark;
use Config;
use FileHandle;
! use vars qw($VERSION $verbose $switches);
! require 5.002;
! $VERSION = "1.07";
@ISA=('Exporter');
@EXPORT= qw(&runtests);
--- 1,14 ----
package Test::Harness;
+ use 5.002;
use Exporter;
use Benchmark;
use Config;
use FileHandle;
! use vars qw($VERSION $verbose $switches $have_devel_corestack);
! $have_devel_corestack = 0;
! $VERSION = "1.12";
@ISA=('Exporter');
@EXPORT= qw(&runtests);
***************
*** 41,80 ****
if( $verbose ){
print $_;
}
! unless (/^\s*\#/) {
! if (/^1\.\.([0-9]+)/) {
! $max = $1;
! $totmax += $max;
! $files++;
! $next = 1;
! } elsif ($max && /^(not\s+)?ok\b/) {
! my $this = $next;
! if (/^not ok\s*(\d*)/){
! $this = $1 if $1 > 0;
! push @failed, $this;
! } elsif (/^ok\s*(\d*)/) {
! $this = $1 if $1 > 0;
! $ok++;
! $totok++;
! }
! if ($this > $next) {
! # warn "Test output counter mismatch [test $this]\n";
! # no need to warn probably
! push @failed, $next..$this-1;
! } elsif ($this < $next) {
! #we have seen more "ok" lines than the number suggests
! warn "Aborting test: output counter mismatch [test $this answered when test $next expected]\n";
! last;
! }
! $next = $this + 1;
}
}
}
$fh->close; # must close to reap child resource values
my $wstatus = $?;
! my $estatus = $wstatus >> 8;
! if ($ok == $max && $next == $max+1 && ! $estatus) {
! print "ok\n";
$good++;
} elsif ($max) {
if ($next <= $max) {
--- 42,93 ----
if( $verbose ){
print $_;
}
! if (/^1\.\.([0-9]+)/) {
! $max = $1;
! $totmax += $max;
! $files++;
! $next = 1;
! } elsif ($max && /^(not\s+)?ok\b/) {
! my $this = $next;
! if (/^not ok\s*(\d*)/){
! $this = $1 if $1 > 0;
! push @failed, $this;
! } elsif (/^ok\s*(\d*)/) {
! $this = $1 if $1 > 0;
! $ok++;
! $totok++;
}
+ if ($this > $next) {
+ # warn "Test output counter mismatch [test $this]\n";
+ # no need to warn probably
+ push @failed, $next..$this-1;
+ } elsif ($this < $next) {
+ #we have seen more "ok" lines than the number suggests
+ warn "Confused test output: test $this answered after test ", $next-1, "\n";
+ $next = $this;
+ }
+ $next = $this + 1;
}
}
$fh->close; # must close to reap child resource values
my $wstatus = $?;
! my $estatus = $^O eq 'VMS' ? $wstatus : $wstatus >> 8;
! if ($^O eq 'VMS' ? !($wstatus & 1) : $wstatus) {
! print "dubious\n\tTest returned status $estatus (wstat $wstatus)\n";
! if (corestatus($wstatus)) { # until we have a wait module
! if ($have_devel_corestack) {
! Devel::CoreStack::stack($^X);
! } else {
! print "\ttest program seems to have generated a core\n";
! }
! }
! $bad++;
! } elsif ($ok == $max && $next == $max+1) {
! if ($max) {
! print "ok\n";
! } else {
! print "skipping test on this platform\n";
! }
$good++;
} elsif ($max) {
if ($next <= $max) {
***************
*** 83,98 ****
if (@failed) {
print canonfailed($max,@failed);
} else {
! print "Don't know which tests failed for some reason\n";
}
$bad++;
} elsif ($next == 0) {
print "FAILED before any test output arrived\n";
$bad++;
}
- if ($wstatus) {
- print "\tTest returned status $estatus (wstat $wstatus)\n";
- }
}
my $t_total = timediff(new Benchmark, $t_start);
--- 96,108 ----
if (@failed) {
print canonfailed($max,@failed);
} else {
! print "Don't know which tests failed: got $ok ok, expected $max\n";
}
$bad++;
} elsif ($next == 0) {
print "FAILED before any test output arrived\n";
$bad++;
}
}
my $t_total = timediff(new Benchmark, $t_start);
***************
*** 102,108 ****
die "FAILED--no tests were run for some reason.\n";
} elsif ($totmax==0) {
my $blurb = $total==1 ? "script" : "scripts";
! die "FAILED--$total test $blurb could be run, alas -- no output ever seen\n";
} else {
$pct = sprintf("%.2f", $good / $total * 100);
my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
--- 112,118 ----
die "FAILED--no tests were run for some reason.\n";
} elsif ($totmax==0) {
my $blurb = $total==1 ? "script" : "scripts";
! die "FAILED--$total test $blurb could be run, alas--no output ever seen\n";
} else {
$pct = sprintf("%.2f", $good / $total * 100);
my $subpct = sprintf " %d/%d subtests failed, %.2f%% okay.",
***************
*** 116,121 ****
--- 126,150 ----
printf("Files=%d, Tests=%d, %s\n", $files, $totmax, timestr($t_total, 'nop'));
}
+ sub corestatus {
+ my($st) = @_;
+ my($ret);
+
+ eval {require 'wait.ph'};
+ if ($@) {
+ SWITCH: {
+ $ret = ($st & 0200); # Tim says, this is for 90%
+ }
+ } else {
+ $ret = WCOREDUMP($st);
+ }
+
+ eval {require Devel::CoreStack};
+ $have_devel_corestack++ unless $@;
+
+ $ret;
+ }
+
sub canonfailed ($@) {
my($max,@failed) = @_;
my %seen;
***************
*** 165,186 ****
Perl test scripts print to standard output C<"ok N"> for each single
test, where C<N> is an increasing sequence of integers. The first line
! output by a standard test scxript is C<"1..M"> with C<M> being the
number of tests that should be run within the test
! script. Test::Harness::runscripts(@tests) runs all the testscripts
named as arguments and checks standard output for the expected
C<"ok N"> strings.
! After all tests have been performed, runscripts() prints some
performance statistics that are computed by the Benchmark module.
=head2 The test script output
Any output from the testscript to standard error is ignored and
bypassed, thus will be seen by the user. Lines written to standard
! output that look like perl comments (start with C</^\s*\#/>) are
! discarded. Lines containing C</^(not\s+)?ok\b/> are interpreted as
! feedback for runtests().
It is tolerated if the test numbers after C<ok> are omitted. In this
case Test::Harness maintains temporarily its own counter until the
--- 194,214 ----
Perl test scripts print to standard output C<"ok N"> for each single
test, where C<N> is an increasing sequence of integers. The first line
! output by a standard test script is C<"1..M"> with C<M> being the
number of tests that should be run within the test
! script. Test::Harness::runtests(@tests) runs all the testscripts
named as arguments and checks standard output for the expected
C<"ok N"> strings.
! After all tests have been performed, runtests() prints some
performance statistics that are computed by the Benchmark module.
=head2 The test script output
Any output from the testscript to standard error is ignored and
bypassed, thus will be seen by the user. Lines written to standard
! output containing C</^(not\s+)?ok\b/> are interpreted as feedback for
! runtests(). All other lines are discarded.
It is tolerated if the test numbers after C<ok> are omitted. In this
case Test::Harness maintains temporarily its own counter until the
***************
*** 201,212 ****
Failed 3/6 tests, 50.00% okay
The global variable $Test::Harness::verbose is exportable and can be
! used to let runscripts() display the standard output of the script
without altering the behavior otherwise.
=head1 EXPORT
! C<&runscripts> is exported by Test::Harness per default.
=head1 DIAGNOSTICS
--- 229,240 ----
Failed 3/6 tests, 50.00% okay
The global variable $Test::Harness::verbose is exportable and can be
! used to let runtests() display the standard output of the script
without altering the behavior otherwise.
=head1 EXPORT
! C<&runtests> is exported by Test::Harness per default.
=head1 DIAGNOSTICS
#~ Allow for "0" as a word
diff -Pcr perl5_003/lib/Text/ParseWords.pm perl5_003_01/lib/Text/ParseWords.pm
*** perl5_003/lib/Text/ParseWords.pm Mon Mar 25 01:04:52 1996
--- perl5_003_01/lib/Text/ParseWords.pm Wed May 1 15:03:41 1996
***************
*** 92,98 ****
local(@words,$snippet,$field,$_);
$_ = join('', @lines);
! while ($_) {
$field = '';
for (;;) {
$snippet = '';
--- 92,98 ----
local(@words,$snippet,$field,$_);
$_ = join('', @lines);
! while (length($_)) {
$field = '';
for (;;) {
$snippet = '';
***************
*** 111,121 ****
$snippet = $1;
$snippet = "\\$snippet" if ($keep);
}
! elsif (!$_ || s/^$delim//) {
last;
}
else {
! while ($_ && !(/^$delim/ || /^['"\\]/)) {
$snippet .= substr($_, 0, 1);
substr($_, 0, 1) = '';
}
--- 111,121 ----
$snippet = $1;
$snippet = "\\$snippet" if ($keep);
}
! elsif (!length($_) || s/^$delim//) {
last;
}
else {
! while (length($_) && !(/^$delim/ || /^['"\\]/)) {
$snippet .= substr($_, 0, 1);
substr($_, 0, 1) = '';
}
#~ Update to version 96.051501
diff -Pcr perl5_003/lib/Text/Tabs.pm perl5_003_01/lib/Text/Tabs.pm
*** perl5_003/lib/Text/Tabs.pm Mon Jan 22 20:45:13 1996
--- perl5_003_01/lib/Text/Tabs.pm Mon Jul 8 13:11:09 1996
***************
*** 1,43 ****
- #
- # expand and unexpand tabs as per the unix expand and
- # unexpand programs.
- #
- # expand and unexpand operate on arrays of lines. Do not
- # feed strings that contain newlines to them.
- #
- # David Muir Sharnoff <muir@idiom.com>
- #
- # Version: 9/21/95
- #
-
- =head1 NAME
-
- Text::Tabs -- expand and unexpand tabs
-
- =head1 SYNOPSIS
-
- use Text::Tabs;
-
- #$tabstop = 8; # Defaults
- print expand("Hello\tworld");
- print unexpand("Hello, world");
- $tabstop = 4;
- print join("\n",expand(split(/\n/,
- "Hello\tworld,\nit's a nice day.\n"
- )));
-
- =head1 DESCRIPTION
-
- This module expands and unexpands tabs into spaces, as per the unix expand
- and unexpand programs. Either function should be passed an array of strings
- (newlines may I<not> be included, and should be used to split an incoming
- string into separate elements.) which will be processed and returned.
-
- =head1 AUTHOR
-
- David Muir Sharnoff <muir@idiom.com>
-
- =cut
package Text::Tabs;
--- 1,3 ----
***************
*** 46,62 ****
@ISA = (Exporter);
@EXPORT = qw(expand unexpand $tabstop);
! $tabstop = 8;
sub expand
{
my @l = @_;
for $_ (@l) {
! 1 while s/^([^\t]*)(\t+)/
! $1 . (" " x
! ($tabstop * length($2)
! - (length($1) % $tabstop)))
! /e;
}
return @l if wantarray;
return @l[0];
--- 6,30 ----
@ISA = (Exporter);
@EXPORT = qw(expand unexpand $tabstop);
! use vars qw($VERSION $tabstop $debug);
! $VERSION = 96.051501;
!
! use strict;
!
! BEGIN {
! $tabstop = 8;
! $debug = 0;
! }
sub expand
{
my @l = @_;
for $_ (@l) {
! 1 while s/(^|\n)([^\t\n]*)(\t+)/
! $1. $2 . (" " x
! ($tabstop * length($3)
! - (length($2) % $tabstop)))
! /sex;
}
return @l if wantarray;
return @l[0];
***************
*** 64,80 ****
sub unexpand
{
! my @l = &expand(@_);
my @e;
for $x (@l) {
! @e = split(/(.{$tabstop})/,$x);
! for $_ (@e) {
! s/ +$/\t/;
}
! $x = join('',@e);
}
return @l if wantarray;
return @l[0];
}
1;
--- 32,97 ----
sub unexpand
{
! my @l = @_;
my @e;
+ my $x;
+ my $line;
+ my @lines;
+ my $lastbit;
for $x (@l) {
! @lines = split("\n", $x, -1);
! for $line (@lines) {
! $line = expand($line);
! @e = split(/(.{$tabstop})/,$line,-1);
! $lastbit = pop(@e);
! $lastbit = '' unless defined $lastbit;
! $lastbit = "\t"
! if $lastbit eq " "x$tabstop;
! for $_ (@e) {
! if ($debug) {
! my $x = $_;
! $x =~ s/\t/^I\t/gs;
! print "sub on '$x'\n";
! }
! s/ +$/\t/;
! }
! $line = join('',@e, $lastbit);
}
! $x = join("\n", @lines);
}
return @l if wantarray;
return @l[0];
}
1;
+ __END__
+
+
+ =head1 NAME
+
+ Text::Tabs -- expand and unexpand tabs per the unix expand(1) and unexpand(1)
+
+ =head1 SYNOPSIS
+
+ use Text::Tabs;
+
+ $tabstop = 4;
+ @lines_without_tabs = expand(@lines_with_tabs);
+ @lines_with_tabs = unexpand(@lines_without_tabs);
+
+ =head1 DESCRIPTION
+
+ Text::Tabs does about what the unix utilities expand(1) and unexpand(1)
+ do. Given a line with tabs in it, expand will replace the tabs with
+ the appropriate number of spaces. Given a line with or without tabs in
+ it, unexpand will add tabs when it can save bytes by doing so. Invisible
+ compression with plain ascii!
+
+ =head1 BUGS
+
+ expand doesn't handle newlines very quickly -- do not feed it an
+ entire document in one string. Instead feed it an array of lines.
+
+ =head1 AUTHOR
+
+ David Muir Sharnoff <muir@idiom.com>
#~ Update to version 96.041801
diff -Pcr perl5_003/lib/Text/Wrap.pm perl5_003_01/lib/Text/Wrap.pm
*** perl5_003/lib/Text/Wrap.pm Mon Jan 22 20:45:16 1996
--- perl5_003_01/lib/Text/Wrap.pm Fri Jul 5 18:05:23 1996
***************
*** 1,68 ****
-
package Text::Wrap;
- #
- # This is a very simple paragraph formatter. It formats one
- # paragraph at a time by wrapping and indenting text.
- #
- # Usage:
- #
- # use Text::Wrap;
- #
- # print wrap($initial_tab,$subsequent_tab,@text);
- #
- # You can also set the number of columns to wrap before:
- #
- # $Text::Wrap::columns = 135; # <= width of screen
- #
- # use Text::Wrap qw(wrap $columns);
- # $columns = 70;
- #
- #
- # The first line will be printed with $initial_tab prepended. All
- # following lines will have $subsequent_tab prepended.
- #
- # Example:
- #
- # print wrap("\t","","This is a bit of text that ...");
- #
- # David Muir Sharnoff <muir@idiom.com>
- # Version: 9/21/95
- #
-
- =head1 NAME
-
- Text::Wrap -- wrap text into a paragraph
-
- =head1 SYNOPSIS
-
- use Text::Wrap;
-
- $Text::Wrap::columns = 20; # Default
- print wrap("\t","",Hello, world, it's a nice day, isn't it?");
-
- =head1 DESCRIPTION
-
- This module is a simple paragraph formatter that wraps text into a paragraph
- and indents each line. The single exported function, wrap(), takes three
- arguments. The first is included before the first output line, and the
- second argument is included before each subsequest output line. The third
- argument is the text to be wrapped.
-
- =head1 AUTHOR
-
- David Muir Sharnoff <muir@idiom.com>
-
- =cut
-
require Exporter;
@ISA = (Exporter);
@EXPORT = qw(wrap);
@EXPORT_OK = qw($columns);
BEGIN {
! $Text::Wrap::columns = 76; # <= screen width
}
use Text::Tabs;
--- 1,19 ----
package Text::Wrap;
require Exporter;
@ISA = (Exporter);
@EXPORT = qw(wrap);
@EXPORT_OK = qw($columns);
+ $VERSION = 96.041801;
+
+ use vars qw($VERSION $columns $debug);
+ use strict;
+
BEGIN {
! $columns = 76; # <= screen width
! $debug = 0;
}
use Text::Tabs;
***************
*** 72,93 ****
{
my ($ip, $xp, @t) = @_;
! my $r;
my $t = expand(join(" ",@t));
my $lead = $ip;
! my $ll = $Text::Wrap::columns - length(expand($lead)) - 1;
! if ($t =~ s/^([^\n]{0,$ll})\s//) {
! $r .= unexpand($lead . $1 . "\n");
$lead = $xp;
! my $ll = $Text::Wrap::columns - length(expand($lead)) - 1;
! while ($t =~ s/^([^\n]{0,$ll})\s//) {
! $r .= unexpand($lead . $1 . "\n");
}
}
die "couldn't wrap '$t'"
if length($t) > $ll;
! $r .= $t;
return $r;
}
1;
--- 23,101 ----
{
my ($ip, $xp, @t) = @_;
! my $r = "";
my $t = expand(join(" ",@t));
my $lead = $ip;
! my $ll = $columns - length(expand($lead)) - 1;
! my $nl = "";
!
! # remove up to a line length of things that aren't
! # new lines and tabs.
!
! if ($t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm) {
!
! # accept it.
! $r .= unexpand($lead . $1);
!
! # recompute the leader
$lead = $xp;
! $ll = $columns - length(expand($lead)) - 1;
! $nl = $2;
!
! # repeat the above until there's none left
! while ($t and $t =~ s/^([^\n]{0,$ll})(\s|\Z(?!\n))//xm) {
! print "\$2 is '$2'\n" if $debug;
! $nl = $2;
! $r .= unexpand("\n" . $lead . $1);
}
+ $r .= $nl;
}
+
die "couldn't wrap '$t'"
if length($t) > $ll;
!
! print "-----------$r---------\n" if $debug;
!
! print "Finish up with '$lead', '$t'\n" if $debug;
!
! $r .= $lead . $t if $t ne "";
!
! print "-----------$r---------\n" if $debug;;
return $r;
}
1;
+ __DATA__
+
+ =head1 NAME
+
+ Text::Wrap - line wrapping to form simple paragraphs
+
+ =head1 SYNOPSIS
+
+ use Text::Wrap
+
+ print wrap($initial_tab, $subsequent_tab, @text);
+
+ use Text::Wrap qw(wrap $columns);
+
+ $columns = 132;
+
+ =head1 DESCRIPTION
+
+ Text::Wrap is a very simple paragraph formatter. It formats a
+ single paragraph at a time by breaking lines at word boundries.
+ Indentation is controlled for the first line ($initial_tab) and
+ all subsquent lines ($subsequent_tab) independently. $Text::Wrap::columns
+ should be set to the full width of your output device.
+
+ =head1 EXAMPLE
+
+ print wrap("\t","","This is a bit of text that forms
+ a normal book-style paragraph");
+
+ =head1 AUTHOR
+
+ David Muir Sharnoff <muir@idiom.com>
+
+ =cut
#~ Quote string argument in example -- necessary if using strict subs
diff -Pcr perl5_003/lib/Tie/Hash.pm perl5_003_01/lib/Tie/Hash.pm
*** perl5_003/lib/Tie/Hash.pm Mon Feb 12 14:47:45 1996
--- perl5_003_01/lib/Tie/Hash.pm Mon Jul 15 13:35:48 1996
***************
*** 26,33 ****
package main;
! tie %new_hash, NewHash;
! tie %new_std_hash, NewStdHash;
=head1 DESCRIPTION
--- 26,33 ----
package main;
! tie %new_hash, 'NewHash';
! tie %new_std_hash, 'NewStdHash';
=head1 DESCRIPTION
#~ Quote string argument in example -- necessary if using strict subs
diff -Pcr perl5_003/lib/Tie/Scalar.pm perl5_003_01/lib/Tie/Scalar.pm
*** perl5_003/lib/Tie/Scalar.pm Mon Feb 12 14:47:50 1996
--- perl5_003_01/lib/Tie/Scalar.pm Mon Jul 15 13:35:51 1996
***************
*** 26,33 ****
package main;
! tie $new_scalar, NewScalar;
! tie $new_std_scalar, NewStdScalar;
=head1 DESCRIPTION
--- 26,33 ----
package main;
! tie $new_scalar, 'NewScalar';
! tie $new_std_scalar, 'NewStdScalar';
=head1 DESCRIPTION
#~ Quote string argument in example -- necessary if using strict subs
diff -Pcr perl5_003/lib/Tie/SubstrHash.pm perl5_003_01/lib/Tie/SubstrHash.pm
*** perl5_003/lib/Tie/SubstrHash.pm Mon Feb 12 14:47:54 1996
--- perl5_003_01/lib/Tie/SubstrHash.pm Mon Jul 15 13:35:54 1996
***************
*** 8,14 ****
require Tie::SubstrHash;
! tie %myhash, Tie::SubstrHash, $key_len, $value_len, $table_size;
=head1 DESCRIPTION
--- 8,14 ----
require Tie::SubstrHash;
! tie %myhash, 'Tie::SubstrHash', $key_len, $value_len, $table_size;
=head1 DESCRIPTION
#~ Fix bugs in initialization for some timezones
diff -Pcr perl5_003/lib/Time/Local.pm perl5_003_01/lib/Time/Local.pm
*** perl5_003/lib/Time/Local.pm Mon Jan 22 20:45:20 1996
--- perl5_003_01/lib/Time/Local.pm Thu Jul 4 12:36:46 1996
***************
*** 39,66 ****
=cut
! @epoch = localtime(0);
! $tzmin = $epoch[2] * 60 + $epoch[1]; # minutes east of GMT
! if ($tzmin > 0) {
! $tzmin = 24 * 60 - $tzmin; # minutes west of GMT
! $tzmin -= 24 * 60 if $epoch[5] == 70; # account for the date line
! }
! $SEC = 1;
! $MIN = 60 * $SEC;
! $HR = 60 * $MIN;
! $DAYS = 24 * $HR;
! $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0;
sub timegm {
$ym = pack(C2, @_[5,4]);
$cheat = $cheat{$ym} || &cheat;
return -1 if $cheat<0;
! $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAYS;
}
sub timelocal {
! $time = &timegm + $tzmin*$MIN;
return -1 if $cheat<0;
@test = localtime($time);
$time -= $HR if $test[2] != $_[2];
--- 39,82 ----
=cut
! BEGIN {
! @epoch = localtime(0);
!
! $SEC = 1;
! $MIN = 60 * $SEC;
! $HR = 60 * $MIN;
! $DAY = 24 * $HR;
! $YearFix = ((gmtime(946684800))[5] == 100) ? 100 : 0;
!
! my $t = time;
! my @lt = localtime($t);
! my @gt = gmtime($t);
! $tzsec = ($gt[1] - $lt[1]) * $MIN + ($gt[2] - $lt[2]) * $HR;
!
! my($lday,$gday) = ($lt[7],$gt[7]);
! if($lt[5] > $gt[5]) {
! $tzsec -= $DAY;
! }
! elsif($gt[5] > $lt[5]) {
! $tzsec += $DAY;
! }
! else {
! $tzsec += ($gt[7] - $lt[7]) * $DAY;
! }
!
! $tzsec += $HR if($lt[8]);
! }
sub timegm {
$ym = pack(C2, @_[5,4]);
$cheat = $cheat{$ym} || &cheat;
return -1 if $cheat<0;
! $cheat + $_[0] * $SEC + $_[1] * $MIN + $_[2] * $HR + ($_[3]-1) * $DAY;
}
sub timelocal {
! $time = &timegm + $tzsec;
return -1 if $cheat<0;
@test = localtime($time);
$time -= $HR if $test[2] != $_[2];
***************
*** 69,74 ****
--- 85,92 ----
sub cheat {
$year = $_[5];
+ $year -= 1900
+ if $year > 1900;
$month = $_[4];
croak "Month out of range 0..11 in timelocal.pl"
if $month > 11 || $month < 0;
***************
*** 85,91 ****
$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
--- 103,109 ----
$year += $YearFix if $year < $epoch[5];
$lastguess = "";
while ($diff = $year - $g[5]) {
! $guess += $diff * (363 * $DAY);
@g = gmtime($guess);
if (($thisguess = "@g") eq $lastguess){
return -1; #date beyond this machine's integer limit
***************
*** 93,99 ****
$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
--- 111,117 ----
$lastguess = $thisguess;
}
while ($diff = $month - $g[4]) {
! $guess += $diff * (27 * $DAY);
@g = gmtime($guess);
if (($thisguess = "@g") eq $lastguess){
return -1; #date beyond this machine's integer limit
***************
*** 105,111 ****
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;
}
--- 123,129 ----
return -1; #date beyond this machine's integer limit
}
$g[3]--;
! $guess -= $g[0] * $SEC + $g[1] * $MIN + $g[2] * $HR + $g[3] * $DAY;
$cheat{$ym} = $guess;
}
#~ Use ~-expanded version of privlib
diff -Pcr perl5_003/lib/diagnostics.pm perl5_003_01/lib/diagnostics.pm
*** perl5_003/lib/diagnostics.pm Mon Mar 25 01:04:12 1996
--- perl5_003_01/lib/diagnostics.pm Wed Jul 10 13:26:26 1996
***************
*** 4,13 ****
use Config;
if ($^O eq 'VMS') {
! $diagnostics::PODFILE = VMS::Filespec::unixify($Config{'privlib'}) .
'/pod/perldiag.pod';
}
! else { $diagnostics::PODFILE= $Config{privlib} . "/pod/perldiag.pod"; }
package diagnostics;
require 5.001;
--- 4,13 ----
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;
#~ Eliminate $`,$' to avoid runtime penalty
diff -Pcr perl5_003/lib/dotsh.pl perl5_003_01/lib/dotsh.pl
*** perl5_003/lib/dotsh.pl Mon Oct 30 18:46:24 1995
--- perl5_003_01/lib/dotsh.pl Wed May 1 17:10:21 1996
***************
*** 53,60 ****
open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n";
while (<_SH_ENV>) {
chop;
! /=/;
! $ENV{$`} = $';
}
close (_SH_ENV);
system "rm -f /tmp/_sh_env$$";
--- 53,60 ----
open (_SH_ENV, "/tmp/_sh_env$$") || die "Could not open /tmp/_sh_env$$!\n";
while (<_SH_ENV>) {
chop;
! m/^([^=]*)=(.*)/s;
! $ENV{$1} = $2;
}
close (_SH_ENV);
system "rm -f /tmp/_sh_env$$";
#~ Turn off optional warnings
#~ Eliminate $' to avoid runtime penalty
diff -Pcr perl5_003/lib/dumpvar.pl perl5_003_01/lib/dumpvar.pl
*** perl5_003/lib/dumpvar.pl Mon Feb 12 14:56:09 1996
--- perl5_003_01/lib/dumpvar.pl Fri Jul 5 18:30:30 1996
***************
*** 25,30 ****
--- 25,31 ----
sub main::dumpValue {
local %address;
+ local $^W=0;
(print "undef\n"), return unless defined $_[0];
(print &stringify($_[0]), "\n"), return unless ref $_[0];
dumpvar::unwrap($_[0],0);
***************
*** 222,229 ****
sub matchvar {
$_[0] eq $_[1] or
! ($_[1] =~ /^([!~])(.)/) and
! ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$'/});
}
sub compactDump {
--- 223,230 ----
sub matchvar {
$_[0] eq $_[1] or
! ($_[1] =~ /^([!~])(.)([\x00-\xff]*)/) and
! ($1 eq '!') ^ (eval {($_[2] . "::" . $_[0]) =~ /$2$3/});
}
sub compactDump {
***************
*** 319,325 ****
sub main::dumpvar {
my ($package,@vars) = @_;
! local(%address,$key,$val);
$package .= "::" unless $package =~ /::$/;
*stab = *{"main::"};
while ($package =~ /(\w+?::)/g){
--- 320,326 ----
sub main::dumpvar {
my ($package,@vars) = @_;
! local(%address,$key,$val,$^W);
$package .= "::" unless $package =~ /::$/;
*stab = *{"main::"};
while ($package =~ /(\w+?::)/g){
#~ Use newer File::Find to eliminate duplicate code
diff -Pcr perl5_003/lib/find.pl perl5_003_01/lib/find.pl
*** perl5_003/lib/find.pl Tue Oct 18 12:36:08 1994
--- perl5_003_01/lib/find.pl Tue Jun 18 20:00:39 1996
***************
*** 29,108 ****
#
# Set the variable $dont_use_nlink if you're using AFS, since AFS cheats.
! sub find {
! chop($cwd = `pwd`);
! foreach $topdir (@_) {
! (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
! || (warn("Can't stat $topdir: $!\n"), next);
! if (-d _) {
! if (chdir($topdir)) {
! ($dir,$_) = ($topdir,'.');
! $name = $topdir;
! &wanted;
! ($fixtopdir = $topdir) =~ s,/$,, ;
! &finddir($fixtopdir,$topnlink);
! }
! else {
! warn "Can't cd to $topdir: $!\n";
! }
! }
! else {
! unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
! ($dir,$_) = ('.', $topdir);
! }
! $name = $topdir;
! chdir $dir && &wanted;
! }
! chdir $cwd;
! }
! }
!
! sub finddir {
! local($dir,$nlink) = @_;
! local($dev,$ino,$mode,$subcount);
! local($name);
!
! # Get the list of files in the current directory.
!
! opendir(DIR,'.') || (warn "Can't open $dir: $!\n", return);
! local(@filenames) = readdir(DIR);
! closedir(DIR);
! if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories.
! for (@filenames) {
! next if $_ eq '.';
! next if $_ eq '..';
! $name = "$dir/$_";
! $nlink = 0;
! &wanted;
! }
! }
! else { # This dir has subdirectories.
! $subcount = $nlink - 2;
! for (@filenames) {
! next if $_ eq '.';
! next if $_ eq '..';
! $nlink = $prune = 0;
! $name = "$dir/$_";
! &wanted;
! if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs?
! # Get link count and check for directoriness.
!
! ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
!
! if (-d _) {
!
! # It really is a directory, so do it recursively.
!
! if (!$prune && chdir $_) {
! &finddir($name,$nlink);
! chdir '..';
! }
! --$subcount;
! }
! }
! }
! }
}
1;
--- 29,42 ----
#
# Set the variable $dont_use_nlink if you're using AFS, since AFS cheats.
! use File::Find ();
! *name = *File::Find::name;
! *prune = *File::Find::prune;
! *dir = *File::Find::dir;
! sub find {
! &File::Find::find(\&wanted, @_);
}
+
1;
#~ Use newer File::Find to eliminate duplicate code
diff -Pcr perl5_003/lib/finddepth.pl perl5_003_01/lib/finddepth.pl
*** perl5_003/lib/finddepth.pl Tue Oct 18 12:36:11 1994
--- perl5_003_01/lib/finddepth.pl Tue Jun 18 20:00:42 1996
***************
*** 27,105 ****
# ($prune = 1);
# }
- sub finddepth {
- chop($cwd = `pwd`);
- foreach $topdir (@_) {
- (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
- || (warn("Can't stat $topdir: $!\n"), next);
- if (-d _) {
- if (chdir($topdir)) {
- ($fixtopdir = $topdir) =~ s,/$,, ;
- &finddepthdir($fixtopdir,$topnlink);
- ($dir,$_) = ($fixtopdir,'.');
- $name = $fixtopdir;
- &wanted;
- }
- else {
- warn "Can't cd to $topdir: $!\n";
- }
- }
- else {
- unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
- ($dir,$_) = ('.', $topdir);
- }
- chdir $dir && &wanted;
- }
- chdir $cwd;
- }
- }
-
- sub finddepthdir {
- local($dir,$nlink) = @_;
- local($dev,$ino,$mode,$subcount);
- local($name);
-
- # Get the list of files in the current directory.
-
- opendir(DIR,'.') || warn "Can't open $dir: $!\n";
- local(@filenames) = readdir(DIR);
- closedir(DIR);
! if ($nlink == 2) { # This dir has no subdirectories.
! for (@filenames) {
! next if $_ eq '.';
! next if $_ eq '..';
! $name = "$dir/$_";
! $nlink = 0;
! &wanted;
! }
! }
! else { # This dir has subdirectories.
! $subcount = $nlink - 2;
! for (@filenames) {
! next if $_ eq '.';
! next if $_ eq '..';
! $nlink = $prune = 0;
! $name = "$dir/$_";
! if ($subcount > 0) { # Seen all the subdirs?
! # Get link count and check for directoriness.
! ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
!
! if (-d _) {
!
! # It really is a directory, so do it recursively.
!
! if (!$prune && chdir $_) {
! &finddepthdir($name,$nlink);
! chdir '..';
! }
! --$subcount;
! }
! }
! &wanted;
! }
! }
}
1;
--- 27,41 ----
# ($prune = 1);
# }
! use File::Find ();
! *name = *File::Find::name;
! *prune = *File::Find::prune;
! *dir = *File::Find::dir;
! sub finddepth {
! &File::Find::finddepth(\&wanted, @_);
}
+
1;
#~ Escape literal "@" in string
diff -Pcr perl5_003/lib/ftp.pl perl5_003_01/lib/ftp.pl
*** perl5_003/lib/ftp.pl Wed Jun 7 19:49:23 1995
--- perl5_003_01/lib/ftp.pl Wed May 1 15:00:50 1996
***************
*** 245,251 ****
local( $remote_user, $remote_password ) = @_;
if( $proxy ){
! &ftp'send( "USER $remote_user@$site" );
}
else {
&ftp'send( "USER $remote_user" );
--- 245,251 ----
local( $remote_user, $remote_password ) = @_;
if( $proxy ){
! &ftp'send( "USER $remote_user\@$site" );
}
else {
&ftp'send( "USER $remote_user" );
#~ Allow for directory named "0"
diff -Pcr perl5_003/lib/getcwd.pl perl5_003_01/lib/getcwd.pl
*** perl5_003/lib/getcwd.pl Wed Jun 7 19:49:27 1995
--- perl5_003_01/lib/getcwd.pl Tue May 14 21:42:17 1996
***************
*** 54,60 ****
}
$cwd = "$dir/$cwd";
closedir(getcwd'PARENT); #');
! } while ($dir);
chop($cwd);
$cwd;
}
--- 54,60 ----
}
$cwd = "$dir/$cwd";
closedir(getcwd'PARENT); #');
! } while ($dir ne '');
chop($cwd);
$cwd;
}
#~ Handle empty strings gracefully
#~ Look for architecture-specific directory with or without version
#~ Update reference to FindBin in documentation
diff -Pcr perl5_003/lib/lib.pm perl5_003_01/lib/lib.pm
*** perl5_003/lib/lib.pm Mon Feb 26 13:08:56 1996
--- perl5_003_01/lib/lib.pm Mon Jun 3 13:21:06 1996
***************
*** 11,20 ****
sub import {
shift;
foreach (reverse @_) {
unshift(@INC, $_);
# Put a corresponding archlib directory infront of $_ if it
# looks like $_ has an archlib directory below it.
! unshift(@INC, "$_/$archname") if -d "$_/$archname/auto";
}
}
--- 11,25 ----
sub import {
shift;
foreach (reverse @_) {
+ unless (defined $_ and $_ ne '') {
+ require Carp;
+ Carp::carp("Empty or undefined compile time value given"); # at foo.pl line ...
+ }
unshift(@INC, $_);
# Put a corresponding archlib directory infront of $_ if it
# looks like $_ has an archlib directory below it.
! unshift(@INC, "$_/$archname/$]") if -d "$_/$archname/$]/auto";
! unshift(@INC, "$_/$archname") if -d "$_/$archname/auto";
}
}
***************
*** 118,124 ****
=head1 SEE ALSO
! AddINC - optional module which deals with paths relative to the source file.
=head1 AUTHOR
--- 123,129 ----
=head1 SEE ALSO
! FindBin - optional module which deals with paths relative to the source file.
=head1 AUTHOR
#~ Update to version 1.16
diff -Pcr perl5_003/lib/newgetopt.pl perl5_003_01/lib/newgetopt.pl
*** perl5_003/lib/newgetopt.pl Mon Feb 12 14:56:18 1996
--- perl5_003_01/lib/newgetopt.pl Thu May 9 17:30:28 1996
***************
*** 1,6 ****
# newgetopt.pl -- new options parsing.
# Now just a wrapper around the Getopt::Long module.
! # $Id: newgetopt.pl,v 1.15 1995/12/26 14:57:33 jv Exp $
{ package newgetopt;
--- 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 $
{ package newgetopt;
***************
*** 15,26 ****
--- 15,28 ----
$getopt_compat = 0; # disallow '+' to start options
$option_start = "(--|-)";
$order = $REQUIRE_ORDER;
+ $bundling = 0;
}
else {
$autoabbrev = 1; # automatic abbrev of options
$getopt_compat = 1; # allow '+' to start options
$option_start = "(--|-|\\+)";
$order = $PERMUTE;
+ $bundling = 0;
}
# Other configurable settings.
***************
*** 45,50 ****
--- 47,54 ----
if defined $newgetopt::option_start;
$Getopt::Long::order = $newgetopt::order
if defined $newgetopt::order;
+ $Getopt::Long::bundling = $newgetopt::bundling
+ if defined $newgetopt::bundling;
$Getopt::Long::ignorecase = $newgetopt::ignorecase
if defined $newgetopt::ignorecase;
#~ Eliminate use of $& to avoid runtime penalty
diff -Pcr perl5_003/lib/open2.pl perl5_003_01/lib/open2.pl
*** perl5_003/lib/open2.pl Tue Oct 18 12:36:44 1994
--- perl5_003_01/lib/open2.pl Wed May 1 17:10:26 1996
***************
*** 28,35 ****
# force unqualified filehandles into callers' package
local($package) = caller;
! $dad_rdr =~ s/^[^']+$/$package'$&/;
! $dad_wtr =~ s/^[^']+$/$package'$&/;
local($kid_rdr) = ++$fh;
local($kid_wtr) = ++$fh;
--- 28,35 ----
# force unqualified filehandles into callers' package
local($package) = caller;
! $dad_rdr =~ s/^([^']+$)/$package'$1/;
! $dad_wtr =~ s/^([^']+$)/$package'$1/;
local($kid_rdr) = ++$fh;
local($kid_wtr) = ++$fh;
#~ Eliminate use of $& to avoid runtime penalty
diff -Pcr perl5_003/lib/open3.pl perl5_003_01/lib/open3.pl
*** perl5_003/lib/open3.pl Tue Oct 18 12:36:47 1994
--- perl5_003_01/lib/open3.pl Wed May 1 17:10:28 1996
***************
*** 46,54 ****
# force unqualified filehandles into callers' package
local($package) = caller;
! $dad_wtr =~ s/^[^']+$/$package'$&/;
! $dad_rdr =~ s/^[^']+$/$package'$&/;
! $dad_err =~ s/^[^']+$/$package'$&/;
local($kid_rdr) = ++$fh;
local($kid_wtr) = ++$fh;
--- 46,54 ----
# force unqualified filehandles into callers' package
local($package) = caller;
! $dad_wtr =~ s/^([^']+$)/$package'$1/;
! $dad_rdr =~ s/^([^']+$)/$package'$1/;
! $dad_err =~ s/^([^']+$)/$package'$1/;
local($kid_rdr) = ++$fh;
local($kid_wtr) = ++$fh;
#~ Drop support for null package name or package "0"
#~ Document fallbacks for logical negation
diff -Pcr perl5_003/lib/overload.pm perl5_003_01/lib/overload.pm
*** perl5_003/lib/overload.pm Mon Jan 22 20:43:23 1996
--- perl5_003_01/lib/overload.pm Tue Jun 18 20:41:37 1996
***************
*** 26,43 ****
}
sub Overloaded {
! defined ($package = ref $_[0]) and defined %{$package . "::OVERLOAD"};
}
sub OverloadedStringify {
! defined ($package = ref $_[0]) and
defined %{$package . "::OVERLOAD"} and
exists $ {$package . "::OVERLOAD"}{'""'} and
defined &{$ {$package . "::OVERLOAD"}{'""'}};
}
sub Method {
! defined ($package = ref $_[0]) and
defined %{$package . "::OVERLOAD"} and
$ {$package . "::OVERLOAD"}{$_[1]};
}
--- 26,43 ----
}
sub Overloaded {
! ($package = ref $_[0]) and defined %{$package . "::OVERLOAD"};
}
sub OverloadedStringify {
! ($package = ref $_[0]) and
defined %{$package . "::OVERLOAD"} and
exists $ {$package . "::OVERLOAD"}{'""'} and
defined &{$ {$package . "::OVERLOAD"}{'""'}};
}
sub Method {
! ($package = ref $_[0]) and
defined %{$package . "::OVERLOAD"} and
$ {$package . "::OVERLOAD"}{$_[1]};
}
***************
*** 186,192 ****
"&", "^", "|", "neg", "!", "~",
"C<neg>" stands for unary minus. If the method for C<neg> is not
! specified, it can be autogenerated using the method for subtraction.
=item * I<Increment and decrement>
--- 186,194 ----
"&", "^", "|", "neg", "!", "~",
"C<neg>" stands for unary minus. If the method for C<neg> is not
! specified, it can be autogenerated using the method for
! subtraction. If the method for "C<!>" is not specified, it can be
! autogenerated using the methods for "C<bool>", or "C<\"\">", or "C<0+>".
=item * I<Increment and decrement>
***************
*** 360,365 ****
--- 362,372 ----
=item I<Unary minus>
can be expressed in terms of subtraction.
+
+ =item I<Negation>
+
+ C<!> and C<not> can be expressed in terms of boolean conversion, or
+ string or numerical conversion.
=item I<Concatenation>
#~ Update to version 0.95: use SHELL environment variable, add option
#~ for status message on return from sub, improved reporting of AUTOLOAD,
#~ listing of package versions, improved ReadLine support
diff -Pcr perl5_003/lib/perl5db.pl perl5_003_01/lib/perl5db.pl
*** perl5_003/lib/perl5db.pl Mon Feb 12 14:56:26 1996
--- perl5_003_01/lib/perl5db.pl Fri Jul 5 18:30:27 1996
***************
*** 2,8 ****
# Debugger for Perl 5.00x; perl5db.pl patch level:
! $header = 'perl5db.pl patch level 0.94';
# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
--- 2,9 ----
# Debugger for Perl 5.00x; perl5db.pl patch level:
! $VERSION = 0.95;
! $header = "perl5db.pl patch level $VERSION";
# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
# Latest version available: ftp://ftp.math.ohio-state.edu/pub/users/ilya/perl
***************
*** 63,68 ****
--- 64,88 ----
# information into db.out. (If you interrupt it, you would better
# reset LineInfo to something "interactive"!)
#
+ # Changes: 0.95: v command shows versions.
+
+ ##################################################################
+ # Changelog:
+
+ # A lot of things changed after 0.94. First of all, core now informs
+ # debugger about entry into XSUBs, overloaded operators, tied operations,
+ # BEGIN and END. Handy with `O f=2'.
+
+ # This can make debugger a little bit too verbose, please be patient
+ # and report your problems promptly.
+
+ # Now the option frame has 3 values: 0,1,2.
+
+ # Note that if DESTROY returns a reference to the object (or object),
+ # the deletion of data may be postponed until the next function call,
+ # due to the need to examine the return value.
+
+ ####################################################################
# Needed for the statement after exec():
***************
*** 91,96 ****
--- 111,118 ----
$trace = $signal = $single = 0; # Uninitialized warning suppression
# (local $^W cannot help - other packages!).
+ $doret = -2;
+ $frame = 0;
@stack = (0);
$option{PrintRet} = 1;
***************
*** 140,145 ****
--- 162,170 ----
# These guys may be defined in $ENV{PERL5DB} :
$rl = 1 unless defined $rl;
+ $warnLevel = 1 unless defined $warnLevel;
+ $dieLevel = 1 unless defined $dieLevel;
+ $signalLevel = 1 unless defined $signalLevel;
warnLevel($warnLevel);
dieLevel($dieLevel);
signalLevel($signalLevel);
***************
*** 201,207 ****
}
# Around a bug:
! if (defined $ENV{OS2_SHELL} and $emacs) { # In OS/2
$console = undef;
}
--- 226,232 ----
}
# Around a bug:
! if (defined $ENV{OS2_SHELL} and ($emacs or $ENV{WINDOWID})) { # In OS/2
$console = undef;
}
***************
*** 270,283 ****
# EOE
}
&save;
- if ($doret) {
- $doret = 0;
- if ($option{PrintRet}) {
- print $OUT "$retctx context return from $lastsub:",
- ($retctx eq 'list') ? "\n" : " " ;
- dumpit( ($retctx eq 'list') ? \@ret : $ret );
- }
- }
($package, $filename, $line) = caller;
$filename_ini = $filename;
$usercontext = '($@, $!, $,, $/, $\, $^W) = @saved;' .
--- 295,300 ----
***************
*** 373,378 ****
--- 390,397 ----
}
}
next CMD; };
+ $cmd =~ /^v$/ && do {
+ list_versions(); next CMD};
$cmd =~ s/^X\b/V $package/;
$cmd =~ /^V$/ && do {
$cmd = "V $package"; };
***************
*** 383,388 ****
--- 402,408 ----
do 'dumpvar.pl' unless defined &main::dumpvar;
if (defined &main::dumpvar) {
local $frame = 0;
+ local $doret = -2;
&main::dumpvar($packname,@vars);
} else {
print $OUT "dumpvar.pl not available.\n";
***************
*** 614,620 ****
last CMD; };
$cmd =~ /^r$/ && do {
$stack[$#stack] |= 1;
! $doret = 1;
last CMD; };
$cmd =~ /^R$/ && do {
print $OUT "Warning: a lot of settings and command-line options may be lost!\n";
--- 634,640 ----
last CMD; };
$cmd =~ /^r$/ && do {
$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";
***************
*** 747,754 ****
$cmd = $hist[$i] . "\n";
print $OUT $cmd;
redo CMD; };
! $cmd =~ /^$sh$sh\s*/ && do {
! &system($');
next CMD; };
$cmd =~ /^$rc([^$rc].*)$/ && do {
$pat = "^$1";
--- 767,774 ----
$cmd = $hist[$i] . "\n";
print $OUT $cmd;
redo CMD; };
! $cmd =~ /^$sh$sh\s*([\x00-\xff]]*)/ && do {
! &system($1);
next CMD; };
$cmd =~ /^$rc([^$rc].*)$/ && do {
$pat = "^$1";
***************
*** 766,773 ****
$cmd =~ /^$sh$/ && do {
&system($ENV{SHELL}||"/bin/sh");
next CMD; };
! $cmd =~ /^$sh\s*/ && do {
! &system($ENV{SHELL}||"/bin/sh","-c",$');
next CMD; };
$cmd =~ /^H\b\s*(-(\d+))?/ && do {
$end = $2?($#hist-$2):0;
--- 786,793 ----
$cmd =~ /^$sh$/ && do {
&system($ENV{SHELL}||"/bin/sh");
next CMD; };
! $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
! &system($ENV{SHELL}||"/bin/sh","-c",$1);
next CMD; };
$cmd =~ /^H\b\s*(-(\d+))?/ && do {
$end = $2?($#hist-$2):0;
***************
*** 864,886 ****
# BEGIN {warn 4}
sub sub {
! print $LINEINFO ' ' x $#stack, "entering $sub\n" if $frame;
push(@stack, $single);
$single &= 1;
$single |= 4 if $#stack == $deep;
if (wantarray) {
@ret = &$sub;
$single |= pop(@stack);
! $retctx = "list";
! $lastsub = $sub;
! print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
@ret;
} else {
$ret = &$sub;
$single |= pop(@stack);
! $retctx = "scalar";
! $lastsub = $sub;
! print $LINEINFO ' ' x $#stack, "exited $sub\n" if $frame;
$ret;
}
}
--- 884,910 ----
# BEGIN {warn 4}
sub sub {
! my ($al, $ret, @ret) = "";
! 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;
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;
@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;
$ret;
}
}
***************
*** 927,939 ****
sub dumpit {
local ($savout) = select($OUT);
! do 'dumpvar.pl' unless defined &main::dumpValue;
if (defined &main::dumpValue) {
- local $frame = 0;
&main::dumpValue(shift);
} else {
print $OUT "dumpvar.pl not available.\n";
}
select ($savout);
}
--- 951,971 ----
sub dumpit {
local ($savout) = select($OUT);
! my $osingle = $single;
! my $otrace = $trace;
! $single = $trace = 0;
! local $frame = 0;
! local $doret = -2;
! unless (defined &main::dumpValue) {
! do 'dumpvar.pl';
! }
if (defined &main::dumpValue) {
&main::dumpValue(shift);
} else {
print $OUT "dumpvar.pl not available.\n";
}
+ $single = $osingle;
+ $trace = $otrace;
select ($savout);
}
***************
*** 972,978 ****
sub setterm {
local $frame = 0;
! eval "require Term::ReadLine;" or die $@;
if ($notty) {
if ($tty) {
open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
--- 1004,1012 ----
sub setterm {
local $frame = 0;
! local $doret = -2;
! local @stack = @stack; # Prevent growth by failing `use'.
! eval { require Term::ReadLine } or die $@;
if ($notty) {
if ($tty) {
open(IN,"<$tty") or die "Cannot open TTY `$TTY' for read: $!";
***************
*** 1017,1022 ****
--- 1051,1057 ----
return $got;
}
local $frame = 0;
+ local $doret = -2;
$term->readline(@_);
}
***************
*** 1036,1042 ****
} else {
$val = $option{$opt};
}
! $val =~ s/[\\\']/\\$&/g;
printf $OUT "%20s = '%s'\n", $opt, $val;
}
--- 1071,1077 ----
} else {
$val = $option{$opt};
}
! $val =~ s/([\\\'])/\\$1/g;
printf $OUT "%20s = '%s'\n", $opt, $val;
}
***************
*** 1070,1076 ****
print $OUT "Unknown option `$opt'\n" unless $matches;
print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
$option{$option} = $val if $matches == 1 and defined $val;
! eval "local \$frame = 0; require '$optionRequire{$option}'"
if $matches == 1 and defined $optionRequire{$option} and defined $val;
$ {$optionVars{$option}} = $val
if $matches == 1
--- 1105,1112 ----
print $OUT "Unknown option `$opt'\n" unless $matches;
print $OUT "Ambiguous option `$opt'\n" if $matches > 1;
$option{$option} = $val if $matches == 1 and defined $val;
! eval "local \$frame = 0; local \$doret = -2;
! require '$optionRequire{$option}'"
if $matches == 1 and defined $optionRequire{$option} and defined $val;
$ {$optionVars{$option}} = $val
if $matches == 1
***************
*** 1091,1097 ****
for $i (0 .. $#list) {
$val = $list[$i];
$val =~ s/\\/\\\\/g;
! $val =~ s/[\0-\37\177\200-\377]/"\\0x" . unpack('H2',$&)/eg;
$ENV{"$ {stem}_$i"} = $val;
}
}
--- 1127,1133 ----
for $i (0 .. $#list) {
$val = $list[$i];
$val =~ s/\\/\\\\/g;
! $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
$ENV{"$ {stem}_$i"} = $val;
}
}
***************
*** 1200,1205 ****
--- 1236,1263 ----
$lineinfo;
}
+ sub list_versions {
+ my %version;
+ my $file;
+ for (keys %INC) {
+ $file = $_;
+ s,\.p[lm]$,,i ;
+ s,/,::,g ;
+ s/^perl5db$/DB/;
+ if (defined $ { $_ . '::VERSION' }) {
+ $version{$file} = "$ { $_ . '::VERSION' } from ";
+ }
+ $version{$file} .= $INC{$file};
+ }
+ do 'dumpvar.pl' unless defined &main::dumpValue;
+ if (defined &main::dumpValue) {
+ local $frame = 0;
+ &main::dumpValue(\%version);
+ } else {
+ print $OUT "dumpvar.pl not available.\n";
+ }
+ }
+
sub sethelp {
$help = "
T Stack trace.
***************
*** 1275,1280 ****
--- 1333,1339 ----
||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.
h [db_command] Get help [on a specific debugger command], enter |h to page.
***************
*** 1288,1295 ****
- or . List previous/current line s [expr] Single step [in expr]
w [line] List around line n [expr] Next, steps over subs
f filename View source in file <CR> Repeat last n or s
! /pattern/ Search forward r Return from subroutine
! ?pattern? Search backward c [line] Continue until line
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
--- 1347,1354 ----
- or . List previous/current line s [expr] Single step [in expr]
w [line] List around line n [expr] Next, steps over subs
f filename View source in file <CR> Repeat last n or s
! /pattern/ ?patt? Search forw/backw r Return from subroutine
! v Show versions of modules c [line] Continue until line
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
***************
*** 1312,1317 ****
--- 1371,1377 ----
sub diesignal {
local $frame = 0;
+ local $doret = -2;
$SIG{'ABRT'} = DEFAULT;
kill 'ABRT', $$ if $panic++;
print $DB::OUT "Got $_[0]!\n"; # in the case cannot continue
***************
*** 1324,1329 ****
--- 1384,1390 ----
sub dbwarn {
local $frame = 0;
+ local $doret = -2;
local $SIG{__WARN__} = '';
require Carp;
#&warn("Entering dbwarn\n");
***************
*** 1338,1343 ****
--- 1399,1405 ----
sub dbdie {
local $frame = 0;
+ local $doret = -2;
local $SIG{__DIE__} = '';
local $SIG{__WARN__} = '';
my $i = 0; my $ineval = 0; my $sub;
***************
*** 1423,1438 ****
$window = 10;
$preview = 3;
$sub = '';
- #$SIG{__WARN__} = "DB::dbwarn";
- #$SIG{__DIE__} = 'DB::dbdie';
- #$SIG{SEGV} = "DB::diesignal";
- #$SIG{BUS} = "DB::diesignal";
$SIG{INT} = "DB::catch";
! #$SIG{FPE} = "DB::catch";
! #warn "SIGFPE installed";
! $warnLevel = 1 unless defined $warnLevel;
! $dieLevel = 1 unless defined $dieLevel;
! $signalLevel = 1 unless defined $signalLevel;
$db_stop = 0; # Compiler warning
$db_stop = 1 << 30;
--- 1485,1495 ----
$window = 10;
$preview = 3;
$sub = '';
$SIG{INT} = "DB::catch";
! # This may be enabled to debug debugger:
! #$warnLevel = 1 unless defined $warnLevel;
! #$dieLevel = 1 unless defined $dieLevel;
! #$signalLevel = 1 unless defined $signalLevel;
$db_stop = 0; # Compiler warning
$db_stop = 1 << 30;
#~ Greatly expand options for setting handlers
diff -Pcr perl5_003/lib/sigtrap.pm perl5_003_01/lib/sigtrap.pm
*** perl5_003/lib/sigtrap.pm Mon Jan 22 20:43:30 1996
--- perl5_003_01/lib/sigtrap.pm Wed May 1 14:41:08 1996
***************
*** 2,39 ****
=head1 NAME
! sigtrap - Perl pragma to enable stack backtrace on unexpected signals
!
! =head1 SYNOPSIS
!
! use sigtrap;
! use sigtrap qw(BUS SEGV PIPE SYS ABRT TRAP);
!
! =head1 DESCRIPTION
!
! The C<sigtrap> pragma initializes some default signal handlers that print
! a stack dump of your Perl program, then sends itself a SIGABRT. This
! provides a nice starting point if something horrible goes wrong.
!
! By default, handlers are installed for the ABRT, BUS, EMT, FPE, ILL, PIPE,
! QUIT, SEGV, SYS, TERM, and TRAP signals.
!
! See L<perlmod/Pragmatic Modules>.
=cut
! require Carp;
sub import {
! my $pack = shift;
! my @sigs = @_;
! @sigs or @sigs = qw(QUIT ILL TRAP ABRT EMT FPE BUS SEGV SYS PIPE TERM);
! foreach $sig (@sigs) {
! $SIG{$sig} = 'sigtrap::trap';
}
}
! sub trap {
package DB; # To get subroutine args.
$SIG{'ABRT'} = DEFAULT;
kill 'ABRT', $$ if $panic++;
--- 2,82 ----
=head1 NAME
! sigtrap - Perl pragma to enable simple signal handling
=cut
! use Carp;
!
! $VERSION = 1.01;
! $Verbose ||= 0;
sub import {
! my $pkg = shift;
! my $handler = \&handler_traceback;
! my $saw_sig = 0;
! my $untrapped = 0;
! local $_;
!
! Arg_loop:
! while (@_) {
! $_ = shift;
! if (/^[A-Z][A-Z0-9]*$/) {
! $saw_sig++;
! unless ($untrapped and $SIG{$_} and $SIG{$_} ne 'DEFAULT') {
! print "Installing handler $handler for $_\n" if $Verbose;
! $SIG{$_} = $handler;
! }
! }
! elsif ($_ eq 'normal-signals') {
! unshift @_, qw(HUP INT PIPE TERM);
! }
! elsif ($_ eq 'error-signals') {
! unshift @_, 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);
! }
! elsif ($_ eq 'stack-trace') {
! $handler = \&handler_traceback;
! }
! elsif ($_ eq 'die') {
! $handler = \&handler_die;
! }
! elsif ($_ eq 'handler') {
! @_ or croak "No argument specified after 'handler'";
! $handler = shift;
! unless (ref $handler or $handler eq 'IGNORE'
! or $handler eq 'DEFAULT') {
! require Symbol;
! $handler = Symbol::qualify($handler, (caller)[0]);
! }
! }
! elsif ($_ eq 'untrapped') {
! $untrapped = 1;
! }
! elsif ($_ eq 'any') {
! $untrapped = 0;
! }
! elsif ($_ =~ /^\d/) {
! $VERSION >= $_ or croak "sigtrap.pm version $_ required,"
! . " but this is only version $VERSION";
! }
! else {
! croak "Unrecognized argument $_";
! }
! }
! unless ($saw_sig) {
! @_ = qw(old-interface-signals);
! goto Arg_loop;
}
}
! sub handler_die {
! croak "Caught a SIG$_[0]";
! }
!
! sub handler_traceback {
package DB; # To get subroutine args.
$SIG{'ABRT'} = DEFAULT;
kill 'ABRT', $$ if $panic++;
***************
*** 77,79 ****
--- 120,279 ----
}
1;
+
+ __END__
+
+ =head1 SYNOPSIS
+
+ use sigtrap;
+ use sigtrap qw(stack-trace old-interface-signals); # equivalent
+ use sigtrap qw(BUS SEGV PIPE ABRT);
+ use sigtrap qw(die INT QUIT);
+ use sigtrap qw(die normal-signals);
+ use sigtrap qw(die untrapped normal-signals);
+ use sigtrap qw(die untrapped normal-signals
+ stack-trace any error-signals);
+ use sigtrap 'handler' => \&my_handler, 'normal-signals';
+ use sigtrap qw(handler my_handler normal-signals
+ stack-trace error-signals);
+
+ =head1 DESCRIPTION
+
+ The B<sigtrap> pragma is a simple interface to installing signal
+ handlers. You can have it install one of two handlers supplied by
+ B<sigtrap> itself (one which provides a Perl stack trace and one which
+ simply C<die()>s), or alternately you can supply your own handler for it
+ to install. It can be told only to install a handler for signals which
+ are either untrapped or ignored. It has a couple of lists of signals to
+ trap, plus you can supply your own list of signals.
+
+ The arguments passed to the C<use> statement which invokes B<sigtrap>
+ are processed in order. When a signal name or the name of one of
+ B<sigtrap>'s signal lists is encountered a handler is immediately
+ installed, when an option is encountered it affects subsequently
+ installed handlers.
+
+ =head1 OPTIONS
+
+ =head2 SIGNAL HANDLERS
+
+ These options affect which handler will be used for subsequently
+ installed signals.
+
+ =over
+
+ =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.
+
+ =item B<die>
+
+ The handler used for subsequently installed signals calls C<die>
+ (actually C<croak>) with a message indicating which signal was caught.
+
+ =item B<handler> I<your-handler>
+
+ I<your-handler> will be used as the handler for subsequently installed
+ signals. I<your-handler> can be any value which is valid as an
+ assignment to an element of C<%SIG>.
+
+ =back
+
+ =head2 SIGNAL LISTS
+
+ B<sigtrap> has two built-in lists of signals to trap. They are:
+
+ =over
+
+ =item B<normal-signals>
+
+ These are the signals which a program might normally expect to encounter
+ and which by default cause it to terminate. They are HUP, INT, PIPE and
+ TERM.
+
+ =item B<error-signals>
+
+ These signals usually indicate a serious problem with the Perl
+ interpreter or with your script. They are ABRT, BUS, EMT, FPE, ILL,
+ QUIT, SEGV, SYS and TRAP.
+
+ =item B<old-interface-signals>
+
+ These are the signals which were trapped by default by the old
+ B<sigtrap> interface, they are ABRT, BUS, EMT, FPE, ILL, PIPE, QUIT,
+ SEGV, SYS, TERM, and TRAP. If no signals or signals lists are passed to
+ B<sigtrap> this list is used.
+
+ =back
+
+ =head2 OTHER
+
+ =item B<untrapped>
+
+ This token tells B<sigtrap> only to install handlers for subsequently
+ listed signals which aren't already trapped or ignored.
+
+ =item B<any>
+
+ This token tells B<sigtrap> to install handlers for all subsequently
+ listed signals. This is the default behavior.
+
+ =item I<signal>
+
+ Any argument which looks like a 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.
+
+ =item I<number>
+
+ Require that at least version I<number> of B<sigtrap> is being used.
+
+ =back
+
+ =head1 EXAMPLES
+
+ Provide a stack trace for the old-interface-signals:
+
+ use sigtrap;
+
+ Ditto:
+
+ use sigtrap qw(stack-trace old-interface-signals);
+
+ Provide a stack trace on the 4 listed signals only:
+
+ use sigtrap qw(BUS SEGV PIPE ABRT);
+
+ Die on INT or QUIT:
+
+ use sigtrap qw(die INT QUIT);
+
+ Die on HUP, INT, PIPE or TERM:
+
+ use sigtrap qw(die normal-signals);
+
+ Die on HUP, INT, PIPE or TERM, except don't change the behavior for
+ signals which are already trapped or ignored:
+
+ use sigtrap qw(die untrapped normal-signals);
+
+ Die on receipt one of an of the B<normal-signals> which is currently
+ B<untrapped>, provide a stack trace on receipt of B<any> of the
+ B<error-signals>:
+
+ use sigtrap qw(die untrapped normal-signals
+ stack-trace any error-signals);
+
+ Install my_handler() as the handler for the B<normal-signals>:
+
+ use sigtrap 'handler', \&my_handler, 'normal-signals';
+
+ Install my_handler() as the handler for the normal-signals, provide a
+ Perl stack trace on receipt of one of the error-signals:
+
+ use sigtrap qw(handler my_handler normal-signals
+ stack-trace error-signals);
+
+ =cut
#~ Use ~-expanded version of privlib
#~ Add VMS support
diff -Pcr perl5_003/lib/splain perl5_003_01/lib/splain
*** perl5_003/lib/splain Mon Jan 22 20:43:32 1996
--- perl5_003_01/lib/splain Wed Jul 10 13:27:38 1996
***************
*** 3,9 ****
if 0;
use Config;
! $diagnostics::PODFILE= $Config{privlib} . "/pod/perldiag.pod";
package diagnostics;
require 5.001;
--- 3,13 ----
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;
#~ Add strict untie
diff -Pcr perl5_003/lib/strict.pm perl5_003_01/lib/strict.pm
*** perl5_003/lib/strict.pm Mon Jan 22 20:43:34 1996
--- perl5_003_01/lib/strict.pm Mon Jul 15 13:35:58 1996
***************
*** 11,16 ****
--- 11,17 ----
use strict "vars";
use strict "refs";
use strict "subs";
+ use strict "untie";
use strict;
no strict "vars";
***************
*** 19,26 ****
If no import list is supplied, all possible restrictions are assumed.
(This is the safest mode to operate in, but is sometimes too strict for
! casual programming.) Currently, there are three possible things to be
! strict about: "subs", "vars", and "refs".
=over 6
--- 20,27 ----
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".
=over 6
***************
*** 65,70 ****
--- 66,89 ----
+ =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>.
***************
*** 78,95 ****
$bits |= 0x00000002 if $sememe eq 'refs';
$bits |= 0x00000200 if $sememe eq 'subs';
$bits |= 0x00000400 if $sememe eq 'vars';
}
$bits;
}
sub import {
shift;
! $^H |= bits(@_ ? @_ : qw(refs subs vars));
}
sub unimport {
shift;
! $^H &= ~ bits(@_ ? @_ : qw(refs subs vars));
}
1;
--- 97,115 ----
$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));
}
sub unimport {
shift;
! $^H &= ~ bits(@_ ? @_ : qw(refs subs vars untie));
}
1;
#~ Add explanation of common usage
diff -Pcr perl5_003/lib/vars.pm perl5_003_01/lib/vars.pm
*** perl5_003/lib/vars.pm Fri Feb 2 14:31:24 1996
--- perl5_003_01/lib/vars.pm Thu Jul 11 12:22:48 1996
***************
*** 14,19 ****
--- 14,26 ----
in the list, allowing you to use them under "use strict", and
disabling any typo warnings.
+ Packages such as the B<AutoLoader> and B<SelfLoader> that delay loading
+ of subroutines within packages can create problems with package lexicals
+ defined using C<my()>. While the B<vars> pragma cannot duplicate the
+ effect of package lexicals (total transparency outside of the package),
+ it can act as an acceptable substitute by pre-declaring global symbols,
+ ensuring their availability to to the later-loaded routines.
+
See L<perlmod/Pragmatic Modules>.
=cut
#~ Delete old copy before generating new one
diff -Pcr perl5_003/makeaperl.SH perl5_003_01/makeaperl.SH
*** perl5_003/makeaperl.SH Mon Jan 22 20:40:10 1996
--- perl5_003_01/makeaperl.SH Thu Jul 11 12:25:29 1996
***************
*** 17,22 ****
--- 17,23 ----
*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
esac
echo "Extracting makeaperl (with variable substitutions)"
+ rm -f makeaperl
$spitshell >makeaperl <<!GROK!THIS!
$startperl
eval 'exec perl -S \$0 "\$@"'
#~ Allow for different shell names
#~ Delete old version of file before copying in new version
diff -Pcr perl5_003/makedepend.SH perl5_003_01/makedepend.SH
*** perl5_003/makedepend.SH Mon Mar 25 01:04:52 1996
--- perl5_003_01/makedepend.SH Thu Jul 11 12:25:32 1996
***************
*** 1,3 ****
--- 1,4 ----
+ #! /bin/sh
case $CONFIG in
'')
if test -f config.sh; then TOP=.;
***************
*** 16,21 ****
--- 17,25 ----
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!
***************
*** 53,58 ****
--- 57,63 ----
$cat /dev/null >.deptmp
$rm -f *.c.c c/*.c.c
if test -f Makefile; then
+ rm -f $firstmakefile
cp Makefile $firstmakefile
fi
mf=$firstmakefile
***************
*** 128,134 ****
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
done
$echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
--- 133,139 ----
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
done
$echo "Updating $mf..."
$echo "# If this runs make out of memory, delete /usr/include lines." \
***************
*** 155,165 ****
$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
done
fi
$rm -f $mf.old
$cp $mf $mf.old
$cp $mf.new $mf
$rm $mf.new
$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
--- 160,171 ----
$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
done
fi
$rm -f $mf.old
$cp $mf $mf.old
+ $rm -f $mf
$cp $mf.new $mf
$rm $mf.new
$echo "# WARNING: Put nothing here or make depend will gobble it up!" >> $mf
#~ Add PACK_MALLOC option
#~ Improve OS/2 and NeXT support, including sbrk() replacement
#~ Allow for redirection of diagnostic messages
#~ Add calloc() function
diff -Pcr perl5_003/malloc.c perl5_003_01/malloc.c
*** perl5_003/malloc.c Sun Jan 28 02:18:22 1996
--- perl5_003_01/malloc.c Fri Jul 5 15:36:36 1996
***************
*** 14,19 ****
--- 14,20 ----
* number of different sizes, and keeps free lists of each size. Blocks that
* don't exactly fit are passed up to the next larger size. In this
* implementation, the available sizes are 2^n-4 (or 2^n-12) bytes long.
+ * If PACK_MALLOC is defined, small blocks are 2^n bytes long.
* This is designed for use in a program that uses vast quantities of memory,
* but bombs when it runs out.
*/
***************
*** 27,33 ****
--- 28,42 ----
#define u_int unsigned int
#define u_short unsigned short
+ /* 286 and atarist like big chunks, which gives too much overhead. */
+ #if (defined(RCHECK) || defined(I286) || defined(atarist)) && defined(PACK_MALLOC)
+ #undef PACK_MALLOC
+ #endif
+
+
/*
+ * The description below is applicable if PACK_MALLOC is not defined.
+ *
* The overhead on a block is at least 4 bytes. When free, this space
* contains a pointer to the next free block, and the bottom two bits must
* be zero. When in use, the first byte is set to MAGIC, and the second
***************
*** 69,74 ****
--- 78,144 ----
#define RSLOP 0
#endif
+ #ifdef PACK_MALLOC
+ /*
+ * In this case it is assumed that if we do sbrk() in 2K units, we
+ * will get 2K aligned blocks. The bucket number of the given subblock is
+ * on the boundary of 2K block which contains the subblock.
+ * Several following bytes contain the magic numbers for the subblocks
+ * in the block.
+ *
+ * Sizes of chunks are powers of 2 for chunks in buckets <=
+ * MAX_PACKED, after this they are (2^n - sizeof(union overhead)) (to
+ * get alignment right).
+ *
+ * We suppose that starts of all the chunks in a 2K block are in
+ * different 2^n-byte-long chunks. If the top of the last chunk is
+ * aligned on a boundary of 2K block, this means that
+ * sizeof(union overhead)*"number of chunks" < 2^n, or
+ * sizeof(union overhead)*2K < 4^n, or n > 6 + log2(sizeof()/2)/2, if a
+ * chunk of size 2^n - overhead is used. Since this rules out n = 7
+ * for 8 byte alignment, we specialcase allocation of the first of 16
+ * 128-byte-long chunks.
+ *
+ * Note that with the above assumption we automatically have enough
+ * place for MAGIC at the start of 2K block. Note also that we
+ * overlay union overhead over the chunk, thus the start of the chunk
+ * is immediately overwritten after freeing.
+ */
+ # define MAX_PACKED 6
+ # define MAX_2_POT_ALGO ((1<<(MAX_PACKED + 1)) - M_OVERHEAD)
+ # define TWOK_MASK ((1<<11) - 1)
+ # define TWOK_MASKED(x) ((int)x & ~TWOK_MASK)
+ # define TWOK_SHIFT(x) ((int)x & TWOK_MASK)
+ # define OV_INDEXp(block) ((u_char*)(TWOK_MASKED(block)))
+ # define OV_INDEX(block) (*OV_INDEXp(block))
+ # define OV_MAGIC(block,bucket) (*(OV_INDEXp(block) + \
+ (TWOK_SHIFT(block)>>(bucket + 3)) + \
+ (bucket > MAX_NONSHIFT ? 1 : 0)))
+ # define CHUNK_SHIFT 0
+
+ static u_char n_blks[11 - 3] = {224, 120, 62, 31, 16, 8, 4, 2};
+ static u_short blk_shift[11 - 3] = {256, 128, 64, 32,
+ 16*sizeof(union overhead),
+ 8*sizeof(union overhead),
+ 4*sizeof(union overhead),
+ 2*sizeof(union overhead),
+ # define MAX_NONSHIFT 2 /* Shift 64 greater than chunk 32. */
+ };
+
+ # 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
+ # define OV_INDEX(block) (block)->ov_index
+ # define CHUNK_SHIFT 1
+ #endif /* !PACK_MALLOC */
+
+ # define M_OVERHEAD (sizeof(union overhead) + RSLOP)
+
/*
* nextf[i] is the pointer to the next free block of size 2^(i+3). The
* smallest allocatable block is 8 bytes. The overhead information
***************
*** 76,82 ****
--- 146,158 ----
*/
#define NBUCKETS 30
static union overhead *nextf[NBUCKETS];
+
+ #ifdef USE_PERL_SBRK
+ #define sbrk(a) Perl_sbrk(a)
+ char * Perl_sbrk _((int size));
+ #else
extern char *sbrk();
+ #endif
#ifdef DEBUGGING_MSTATS
/*
***************
*** 132,139 ****
* which satisfies request. Account for
* space used per block for accounting.
*/
! nbytes += sizeof (union overhead) + RSLOP;
! nbytes = (nbytes + 3) &~ 3;
shiftr = (nbytes - 1) >> 2;
/* apart from this loop, this is O(1) */
while (shiftr >>= 1)
--- 208,223 ----
* which satisfies request. Account for
* space used per block for accounting.
*/
! #ifdef PACK_MALLOC
! if (nbytes > MAX_2_POT_ALGO) {
! #endif
! nbytes += M_OVERHEAD;
! nbytes = (nbytes + 3) &~ 3;
! #ifdef PACK_MALLOC
! } else if (nbytes == 0) {
! nbytes = 1;
! }
! #endif
shiftr = (nbytes - 1) >> 2;
/* apart from this loop, this is O(1) */
while (shiftr >>= 1)
***************
*** 156,162 ****
}
#ifdef safemalloc
! DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",
(unsigned long)(p+1),an++,(long)size));
#endif /* safemalloc */
--- 240,246 ----
}
#ifdef safemalloc
! DEBUG_m(fprintf(Perl_debug_log,"0x%lx: (%05d) malloc %ld bytes\n",
(unsigned long)(p+1),an++,(long)size));
#endif /* safemalloc */
***************
*** 167,174 ****
(unsigned long)*((int*)p),(unsigned long)p);
#endif
nextf[bucket] = p->ov_next;
! p->ov_magic = MAGIC;
! p->ov_index= bucket;
#ifdef DEBUGGING_MSTATS
nmalloc[bucket]++;
#endif
--- 251,260 ----
(unsigned long)*((int*)p),(unsigned long)p);
#endif
nextf[bucket] = p->ov_next;
! OV_MAGIC(p, bucket) = MAGIC;
! #ifndef PACK_MALLOC
! OV_INDEX(p) = bucket;
! #endif
#ifdef DEBUGGING_MSTATS
nmalloc[bucket]++;
#endif
***************
*** 182,188 ****
p->ov_rmagic = RMAGIC;
*((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
#endif
! return ((Malloc_t)(p + 1));
}
/*
--- 268,274 ----
p->ov_rmagic = RMAGIC;
*((u_int *)((caddr_t)p + nbytes - RSLOP)) = RMAGIC;
#endif
! return ((Malloc_t)(p + CHUNK_SHIFT));
}
/*
***************
*** 196,201 ****
--- 282,288 ----
register int rnu; /* 2^rnu bytes will be requested */
register int nblks; /* become nblks blocks of the desired size */
register MEM_SIZE siz;
+ int slack = 0;
if (nextf[bucket])
return;
***************
*** 206,217 ****
*/
#ifndef atarist /* on the atari we dont have to worry about this */
op = (union overhead *)sbrk(0);
! #ifndef I286
if ((int)op & 0x3ff)
! (void)sbrk(1024 - ((int)op & 0x3ff));
! #else
/* The sbrk(0) call on the I286 always returns the next segment */
! #endif
#endif /* atarist */
#if !(defined(I286) || defined(atarist))
--- 293,312 ----
*/
#ifndef atarist /* on the atari we dont have to worry about this */
op = (union overhead *)sbrk(0);
! # ifndef I286
! # ifdef PACK_MALLOC
! if ((int)op & 0x7ff)
! (void)sbrk(slack = 2048 - ((int)op & 0x7ff));
! # else
if ((int)op & 0x3ff)
! (void)sbrk(slack = 1024 - ((int)op & 0x3ff));
! # endif
! # if defined(DEBUGGING_MSTATS) && defined(PACK_MALLOC)
! sbrk_slack += slack;
! # endif
! # else
/* The sbrk(0) call on the I286 always returns the next segment */
! # endif
#endif /* atarist */
#if !(defined(I286) || defined(atarist))
***************
*** 223,230 ****
rnu = (bucket <= 11) ? 14 : bucket + 3;
#endif
nblks = 1 << (rnu - (bucket + 3)); /* how many blocks to get */
! if (rnu < bucket)
! rnu = bucket;
op = (union overhead *)sbrk(1L << rnu);
/* no more room! */
if ((int)op == -1)
--- 318,325 ----
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);
/* no more room! */
if ((int)op == -1)
***************
*** 234,239 ****
--- 329,338 ----
* and deduct from block count to reflect.
*/
#ifndef I286
+ # ifdef PACK_MALLOC
+ if ((int)op & 0x7ff)
+ croak("panic: Off-page sbrk");
+ # endif
if ((int)op & 7) {
op = (union overhead *)(((MEM_SIZE)op + 8) &~ 7);
nblks--;
***************
*** 245,256 ****
* Add new memory allocated to that on
* free list for this hash bucket.
*/
- nextf[bucket] = op;
siz = 1 << (bucket + 3);
while (--nblks > 0) {
op->ov_next = (union overhead *)((caddr_t)op + siz);
op = (union overhead *)((caddr_t)op + siz);
}
}
Free_t
--- 344,381 ----
* Add new memory allocated to that on
* free list for this hash bucket.
*/
siz = 1 << (bucket + 3);
+ #ifdef PACK_MALLOC
+ *(u_char*)op = bucket; /* Fill index. */
+ if (bucket <= MAX_PACKED - 3) {
+ op = (union overhead *) ((char*)op + blk_shift[bucket]);
+ nblks = n_blks[bucket];
+ # ifdef DEBUGGING_MSTATS
+ start_slack += blk_shift[bucket];
+ # endif
+ } else if (bucket <= 11 - 1 - 3) {
+ op = (union overhead *) ((char*)op + blk_shift[bucket]);
+ /* nblks = n_blks[bucket]; */
+ siz -= sizeof(union overhead);
+ } else op++; /* One chunk per block. */
+ #endif /* !PACK_MALLOC */
+ nextf[bucket] = op;
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 */
+ 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;
+ nextf[7 - 3] = (union overhead *)((caddr_t)nextf[7 - 3]
+ - sizeof(union overhead));
+ nextf[7 - 3]->ov_next = n_op;
+ }
+ #endif /* !PACK_MALLOC */
}
Free_t
***************
*** 260,277 ****
register MEM_SIZE size;
register union overhead *op;
char *cp = (char*)mp;
#ifdef safemalloc
! DEBUG_m(fprintf(stderr,"0x%lx: (%05d) free\n",(unsigned long)cp,an++));
#endif /* safemalloc */
! if (cp == NULL)
! return;
! op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
#ifdef debug
! ASSERT(op->ov_magic == MAGIC); /* make sure it was in use */
#else
! if (op->ov_magic != MAGIC) {
#ifdef RCHECK
warn("%s free() ignored",
op->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
--- 385,416 ----
register MEM_SIZE size;
register union overhead *op;
char *cp = (char*)mp;
+ #ifdef PACK_MALLOC
+ u_char bucket;
+ #endif
#ifdef safemalloc
! DEBUG_m(fprintf(Perl_debug_log,"0x%lx: (%05d) free\n",(unsigned long)cp,an++));
#endif /* safemalloc */
! if (cp == NULL)
! return;
! op = (union overhead *)((caddr_t)cp
! - sizeof (union overhead) * CHUNK_SHIFT);
! #ifdef PACK_MALLOC
! bucket = OV_INDEX(op);
! #endif
#ifdef debug
! ASSERT(OV_MAGIC(op, bucket) == MAGIC); /* make sure it was in use */
#else
! if (OV_MAGIC(op, bucket) != MAGIC) {
! static bad_free_warn = -1;
! if (bad_free_warn == -1) {
! char *pbf = getenv("PERL_BADFREE");
! bad_free_warn = (pbf) ? atoi(pbf) : 1;
! }
! if (!bad_free_warn)
! return;
#ifdef RCHECK
warn("%s free() ignored",
op->ov_rmagic == RMAGIC - 1 ? "Duplicate" : "Bad");
***************
*** 283,294 ****
#endif
#ifdef RCHECK
ASSERT(op->ov_rmagic == RMAGIC);
! if (op->ov_index <= 13)
ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC);
op->ov_rmagic = RMAGIC - 1;
#endif
! ASSERT(op->ov_index < NBUCKETS);
! size = op->ov_index;
op->ov_next = nextf[size];
nextf[size] = op;
#ifdef DEBUGGING_MSTATS
--- 422,433 ----
#endif
#ifdef RCHECK
ASSERT(op->ov_rmagic == RMAGIC);
! if (OV_INDEX(op) <= 13)
ASSERT(*(u_int *)((caddr_t)op + op->ov_size + 1 - RSLOP) == RMAGIC);
op->ov_rmagic = RMAGIC - 1;
#endif
! ASSERT(OV_INDEX(op) < NBUCKETS);
! size = OV_INDEX(op);
op->ov_next = nextf[size];
nextf[size] = op;
#ifdef DEBUGGING_MSTATS
***************
*** 340,349 ****
#endif
#endif /* safemalloc */
! op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
! if (op->ov_magic == MAGIC) {
was_alloced++;
- i = op->ov_index;
} else {
/*
* Already free, doing "compaction".
--- 479,489 ----
#endif
#endif /* safemalloc */
! op = (union overhead *)((caddr_t)cp
! - sizeof (union overhead) * CHUNK_SHIFT);
! i = OV_INDEX(op);
! if (OV_MAGIC(op, i) == MAGIC) {
was_alloced++;
} else {
/*
* Already free, doing "compaction".
***************
*** 360,382 ****
(i = findbucket(op, reall_srchlen)) < 0)
i = 0;
}
! onb = (1L << (i + 3)) - sizeof (*op) - RSLOP;
/* avoid the copy if same size block */
if (was_alloced &&
! nbytes <= onb && nbytes > (onb >> 1) - sizeof(*op) - RSLOP) {
#ifdef RCHECK
/*
* Record new allocated size of block and
* bound space with magic numbers.
*/
! if (op->ov_index <= 13) {
/*
* Convert amount of memory requested into
* closest block size stored in hash buckets
* which satisfies request. Account for
* space used per block for accounting.
*/
! nbytes += sizeof (union overhead) + RSLOP;
nbytes = (nbytes + 3) &~ 3;
op->ov_size = nbytes - 1;
*((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC;
--- 500,528 ----
(i = findbucket(op, reall_srchlen)) < 0)
i = 0;
}
! onb = (1L << (i + 3)) -
! #ifdef PACK_MALLOC
! (i <= (MAX_PACKED - 3) ? 0 : M_OVERHEAD)
! #else
! M_OVERHEAD
! #endif
! ;
/* avoid the copy if same size block */
if (was_alloced &&
! nbytes <= onb && nbytes > (onb >> 1) - M_OVERHEAD) {
#ifdef RCHECK
/*
* Record new allocated size of block and
* bound space with magic numbers.
*/
! if (OV_INDEX(op) <= 13) {
/*
* Convert amount of memory requested into
* closest block size stored in hash buckets
* which satisfies request. Account for
* space used per block for accounting.
*/
! nbytes += M_OVERHEAD;
nbytes = (nbytes + 3) &~ 3;
op->ov_size = nbytes - 1;
*((u_int *)((caddr_t)op + nbytes - RSLOP)) = RMAGIC;
***************
*** 429,434 ****
--- 575,594 ----
return (-1);
}
+ Malloc_t
+ calloc(elements, size)
+ register MEM_SIZE elements;
+ register MEM_SIZE size;
+ {
+ long sz = elements * size;
+ Malloc_t p = malloc(sz);
+
+ if (p) {
+ memset((void*)p, 0, sz);
+ }
+ return p;
+ }
+
#ifdef DEBUGGING_MSTATS
/*
* mstats - print out statistics about malloc
***************
*** 467,472 ****
--- 627,638 ----
fprintf(stderr, (i<5)?" %5d":" %3d", nmalloc[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
}
#else
void
***************
*** 476,478 ****
--- 642,717 ----
}
#endif
#endif /* lint */
+
+
+ #ifdef USE_PERL_SBRK
+
+ #ifdef NeXT
+ #ifdef HIDEMYMALLOC
+ #undef malloc
+ #else
+ #include "Error: -DUSE_PERL_SBRK on the NeXT requires -DHIDEMYMALLOC"
+ #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
+
+
+ static IV Perl_sbrk_oldchunk;
+ static long Perl_sbrk_oldsize;
+
+ #define PERLSBRK_32_K (1<<15)
+ #define PERLSBRK_64_K (1<<16)
+
+ char *
+ Perl_sbrk(size)
+ int size;
+ {
+ IV got;
+ int small, reqsize;
+
+ if (!size) return 0;
+ #ifdef safemalloc
+ reqsize = size; /* just for the DEBUG_m statement */
+ #endif
+ if (size <= Perl_sbrk_oldsize) {
+ got = Perl_sbrk_oldchunk;
+ Perl_sbrk_oldchunk += size;
+ Perl_sbrk_oldsize -= size;
+ } else {
+ if (size >= PERLSBRK_32_K) {
+ small = 0;
+ } else {
+ #ifndef safemalloc
+ reqsize = size;
+ #endif
+ size = PERLSBRK_64_K;
+ small = 1;
+ }
+ got = (IV)SYSTEM_ALLOC(size);
+ if (small) {
+ /* Chunk is small, register the rest for future allocs. */
+ Perl_sbrk_oldchunk = got + reqsize;
+ Perl_sbrk_oldsize = size - reqsize;
+ }
+ }
+
+ #ifdef safemalloc
+ DEBUG_m(fprintf(stderr,"sbrk malloc size %ld (reqsize %ld), left size %ld, give addr 0x%lx\n",
+ size, reqsize, Perl_sbrk_oldsize, got));
+ #endif
+
+ return (void *)got;
+ }
+
+ #endif /* ! defined USE_PERL_SBRK */
#~ Use safefree() instead of Safefree to free memory allocated by safemalloc()
#~ Add support for shared hash keys
#~ Add $^E support for OS/2
#~ Add support for 64-bit time values
#~ Add cast for new GV type
#~ Don't allow errors in setting string $! to change $!
#~ Restart system calls on all signals where possible
#~ Add support for imporved %SIG management
#~ Don't reset global $. unless we're reading a file
diff -Pcr perl5_003/mg.c perl5_003_01/mg.c
*** perl5_003/mg.c Mon Mar 25 01:04:56 1996
--- perl5_003_01/mg.c Fri Jul 5 18:20:30 1996
***************
*** 70,76 ****
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
}
! Safefree(mgs);
}
--- 70,76 ----
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
}
! safefree((void *)mgs);
}
***************
*** 210,216 ****
SV* sv;
SV* nsv;
char *key;
! STRLEN klen;
{
int count = 0;
MAGIC* mg;
--- 210,216 ----
SV* sv;
SV* nsv;
char *key;
! I32 klen;
{
int count = 0;
MAGIC* mg;
***************
*** 235,241 ****
if (vtbl && vtbl->svt_free)
(*vtbl->svt_free)(sv, mg);
if (mg->mg_ptr && mg->mg_type != 'g')
! Safefree(mg->mg_ptr);
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
--- 235,244 ----
if (vtbl && vtbl->svt_free)
(*vtbl->svt_free)(sv, mg);
if (mg->mg_ptr && mg->mg_type != 'g')
! if (mg->mg_len >= 0)
! Safefree(mg->mg_ptr);
! else if (mg->mg_len == HEf_SVKEY)
! SvREFCNT_dec((SV*)mg->mg_ptr);
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
***************
*** 346,354 ****
--- 349,362 ----
sv_setpv(sv,"");
}
#else
+ #ifdef OS2
+ sv_setnv(sv,(double)Perl_rc);
+ sv_setpv(sv, os2error(Perl_rc));
+ #else
sv_setnv(sv,(double)errno);
sv_setpv(sv, errno ? Strerror(errno) : "");
#endif
+ #endif
SvNOK_on(sv); /* what a wonderful hack! */
break;
case '\006': /* ^F */
***************
*** 370,376 ****
--- 378,388 ----
sv_setiv(sv,(I32)perldb);
break;
case '\024': /* ^T */
+ #ifdef BIG_TIME
+ sv_setnv(sv,basetime);
+ #else
sv_setiv(sv,(I32)basetime);
+ #endif
break;
case '\027': /* ^W */
sv_setiv(sv,(I32)dowarn);
***************
*** 378,384 ****
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
if (curpm) {
! paren = atoi(GvENAME(mg->mg_obj));
getparen:
if (curpm->op_pmregexp &&
paren <= curpm->op_pmregexp->nparens &&
--- 390,396 ----
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
if (curpm) {
! paren = atoi(GvENAME((GV*)mg->mg_obj));
getparen:
if (curpm->op_pmregexp &&
paren <= curpm->op_pmregexp->nparens &&
***************
*** 485,494 ****
--- 497,515 ----
case '!':
#ifdef VMS
sv_setnv(sv,(double)((errno == EVMSERR) ? vaxc$errno : errno));
+ sv_setpv(sv, errno ? Strerror(errno) : "");
#else
+ {
+ int saveerrno = errno;
sv_setnv(sv,(double)errno);
+ #ifdef OS2
+ if (errno == errno_isOS2) sv_setpv(sv, os2error(Perl_rc));
+ else
#endif
sv_setpv(sv, errno ? Strerror(errno) : "");
+ errno = saveerrno;
+ }
+ #endif
SvNOK_on(sv); /* what a wonderful hack! */
break;
case '<':
***************
*** 548,570 ****
MAGIC* mg;
{
register char *s;
STRLEN len;
I32 i;
s = SvPV(sv,len);
! my_setenv(mg->mg_ptr,s);
#ifdef DYNAMIC_ENV_FETCH
/* We just undefd an environment var. Is a replacement */
/* waiting in the wings? */
if (!len) {
! SV **envsvp;
! if (envsvp = hv_fetch(GvHVn(envgv),mg->mg_ptr,mg->mg_len,FALSE))
! s = SvPV(*envsvp,len);
}
#endif
/* And you'll never guess what the dog had */
/* in its mouth... */
if (tainting) {
! if (s && strEQ(mg->mg_ptr,"PATH")) {
char *strend = s + len;
while (s < strend) {
--- 569,593 ----
MAGIC* mg;
{
register char *s;
+ char *ptr;
STRLEN len;
I32 i;
s = SvPV(sv,len);
! ptr = (mg->mg_len == HEf_SVKEY) ? SvPV((SV*)mg->mg_ptr, na) : mg->mg_ptr;
! 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))
! s = SvPV(HeVAL(envhe),len);
}
#endif
/* And you'll never guess what the dog had */
/* in its mouth... */
if (tainting) {
! if (s && strEQ(ptr,"PATH")) {
char *strend = s + len;
while (s < strend) {
***************
*** 584,590 ****
SV* sv;
MAGIC* mg;
{
! my_setenv(mg->mg_ptr,Nullch);
return 0;
}
--- 607,614 ----
SV* sv;
MAGIC* mg;
{
! my_setenv(((mg->mg_len == HEf_SVKEY) ?
! SvPV((SV*)mg->mg_ptr, na) : mg->mg_ptr),Nullch);
return 0;
}
***************
*** 603,621 ****
act.sa_handler = handler;
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
- #ifdef SIGALRM
- if (signo == SIGALRM) {
- #else
- if (0) {
- #endif
- #ifdef SA_INTERRUPT
- act.sa_flags |= SA_INTERRUPT; /* SunOS */
- #endif
- } else {
#ifdef SA_RESTART
! act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
#endif
- }
if (sigaction(signo, &act, &oact) < 0)
return(SIG_ERR);
else
--- 627,635 ----
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
***************
*** 630,635 ****
--- 644,707 ----
#endif
+ static sig_trapped;
+ static
+ Signal_t
+ sig_trap(signo)
+ int signo;
+ {
+ sig_trapped++;
+ }
+ int
+ magic_getsig(sv,mg)
+ SV* sv;
+ MAGIC* mg;
+ {
+ I32 i;
+ /* Are we fetching a signal entry? */
+ i = whichsig(mg->mg_ptr);
+ 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);
+ /* cache state so we don't fetch it again */
+ if(origsig == SIG_IGN)
+ sv_setpv(sv,"IGNORE");
+ else
+ sv_setsv(sv,&sv_undef);
+ psig_ptr[i] = SvREFCNT_inc(sv);
+ SvTEMP_off(sv);
+ }
+ }
+ return 0;
+ }
+ int
+ magic_clearsig(sv,mg)
+ SV* sv;
+ MAGIC* mg;
+ {
+ I32 i;
+ /* Are we clearing a signal entry? */
+ i = whichsig(mg->mg_ptr);
+ if (i) {
+ if(psig_ptr[i]) {
+ SvREFCNT_dec(psig_ptr[i]);
+ psig_ptr[i]=0;
+ }
+ if(psig_name[i]) {
+ SvREFCNT_dec(psig_name[i]);
+ psig_name[i]=0;
+ }
+ }
+ return 0;
+ }
int
magic_setsig(sv,mg)
***************
*** 640,646 ****
I32 i;
SV** svp;
! s = mg->mg_ptr;
if (*s == '_') {
if (strEQ(s,"__DIE__"))
svp = &diehook;
--- 712,718 ----
I32 i;
SV** svp;
! s = (mg->mg_len == HEf_SVKEY) ? SvPV((SV*)mg->mg_ptr, na) : mg->mg_ptr;
if (*s == '_') {
if (strEQ(s,"__DIE__"))
svp = &diehook;
***************
*** 663,668 ****
--- 735,748 ----
warn("No such signal: SIG%s", s);
return 0;
}
+ if(psig_ptr[i])
+ SvREFCNT_dec(psig_ptr[i]);
+ 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));
+ 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)
***************
*** 733,740 ****
PUSHMARK(sp);
EXTEND(sp, 2);
PUSHs(mg->mg_obj);
! if (mg->mg_ptr)
! PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
else if (mg->mg_type == 'p')
PUSHs(sv_2mortal(newSViv(mg->mg_len)));
PUTBACK;
--- 813,824 ----
PUSHMARK(sp);
EXTEND(sp, 2);
PUSHs(mg->mg_obj);
! if (mg->mg_ptr) {
! if (mg->mg_len >= 0)
! PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
! else if (mg->mg_len == HEf_SVKEY)
! PUSHs((SV*)mg->mg_ptr);
! }
else if (mg->mg_type == 'p')
PUSHs(sv_2mortal(newSViv(mg->mg_len)));
PUTBACK;
***************
*** 768,775 ****
PUSHMARK(sp);
EXTEND(sp, 3);
PUSHs(mg->mg_obj);
! if (mg->mg_ptr)
! PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
else if (mg->mg_type == 'p')
PUSHs(sv_2mortal(newSViv(mg->mg_len)));
PUSHs(sv);
--- 852,863 ----
PUSHMARK(sp);
EXTEND(sp, 3);
PUSHs(mg->mg_obj);
! if (mg->mg_ptr) {
! if (mg->mg_len >= 0)
! PUSHs(sv_2mortal(newSVpv(mg->mg_ptr, mg->mg_len)));
! else if (mg->mg_len == HEf_SVKEY)
! PUSHs((SV*)mg->mg_ptr);
! }
else if (mg->mg_type == 'p')
PUSHs(sv_2mortal(newSViv(mg->mg_len)));
PUSHs(sv);
***************
*** 957,963 ****
if (sv == (SV*)gv)
return 0;
if (GvGP(sv))
! gp_free(sv);
GvGP(sv) = gp_ref(GvGP(gv));
if (!GvAV(gv))
gv_AVadd(gv);
--- 1045,1051 ----
if (sv == (SV*)gv)
return 0;
if (GvGP(sv))
! gp_free((GV*)sv);
GvGP(sv) = gp_ref(GvGP(gv));
if (!GvAV(gv))
gv_AVadd(gv);
***************
*** 1106,1112 ****
--- 1194,1204 ----
perldb = i;
break;
case '\024': /* ^T */
+ #ifdef BIG_TIME
+ basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
+ #else
basetime = (Time_t)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ #endif
break;
case '\027': /* ^W */
dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
***************
*** 1116,1122 ****
if (localizing == 1)
save_sptr((SV**)&last_in_gv);
}
! else if (SvOK(sv))
IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
break;
case '^':
--- 1208,1214 ----
if (localizing == 1)
save_sptr((SV**)&last_in_gv);
}
! else if (SvOK(sv) && GvIO(last_in_gv))
IoLINES(GvIOp(last_in_gv)) = (long)SvIV(sv);
break;
case '^':
***************
*** 1362,1402 ****
SV *sv;
CV *cv;
AV *oldstack;
- char *signame;
-
- #ifdef OS2 /* or anybody else who requires SIG_ACK */
- signal(sig, SIG_ACK);
- #endif
! signame = sig_name[sig];
! cv = sv_2cv(*hv_fetch(GvHVn(siggv),signame,strlen(signame),
! TRUE),
! &st, &gv, TRUE);
! if (!cv || !CvROOT(cv) &&
! *signame == 'C' && instr(signame,"LD")) {
!
! if (signame[1] == 'H')
! cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CLD",3,TRUE),
! &st, &gv, TRUE);
! else
! cv = sv_2cv(*hv_fetch(GvHVn(siggv),"CHLD",4,TRUE),
! &st, &gv, TRUE);
! /* gag */
! }
if (!cv || !CvROOT(cv)) {
if (dowarn)
warn("SIG%s handler \"%s\" not defined.\n",
! signame, GvENAME(gv) );
return;
}
! oldstack = stack;
! if (stack != signalstack)
AvFILL(signalstack) = 0;
! SWITCHSTACK(stack, signalstack);
! sv = sv_newmortal();
! sv_setpv(sv,signame);
PUSHMARK(sp);
PUSHs(sv);
PUTBACK;
--- 1454,1479 ----
SV *sv;
CV *cv;
AV *oldstack;
! cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
if (!cv || !CvROOT(cv)) {
if (dowarn)
warn("SIG%s handler \"%s\" not defined.\n",
! sig_name[sig], GvENAME(gv) );
return;
}
! oldstack = curstack;
! if (curstack != signalstack)
AvFILL(signalstack) = 0;
! SWITCHSTACK(curstack, signalstack);
! if(psig_name[sig])
! sv = SvREFCNT_inc(psig_name[sig]);
! else {
! sv = sv_newmortal();
! sv_setpv(sv,sig_name[sig]);
! }
PUSHMARK(sp);
PUSHs(sv);
PUTBACK;
#~ Correct count in i18nl10n
#~ Insure that perl_destruct() and perl_free() are called before exiting
diff -Pcr perl5_003/miniperlmain.c perl5_003_01/miniperlmain.c
*** perl5_003/miniperlmain.c Mon Mar 25 01:04:57 1996
--- perl5_003_01/miniperlmain.c Thu Jul 18 11:15:28 1996
***************
*** 33,39 ****
PERL_SYS_INIT(&argc,&argv);
! perl_init_i18nl14n(1);
if (!do_undump) {
my_perl = perl_alloc();
--- 33,39 ----
PERL_SYS_INIT(&argc,&argv);
! perl_init_i18nl10n(1);
if (!do_undump) {
my_perl = perl_alloc();
***************
*** 43,52 ****
}
exitstatus = perl_parse( my_perl, xs_init, argc, argv, (char **) NULL );
! if (exitstatus)
! exit( exitstatus );
!
! exitstatus = perl_run( my_perl );
perl_destruct( my_perl );
perl_free( my_perl );
--- 43,51 ----
}
exitstatus = perl_parse( my_perl, xs_init, argc, argv, (char **) NULL );
! if (!exitstatus) {
! exitstatus = perl_run( my_perl );
! }
perl_destruct( my_perl );
perl_free( my_perl );
#~ Correct typo osver --> osvers
diff -Pcr perl5_003/myconfig perl5_003_01/myconfig
*** perl5_003/myconfig Mon Mar 25 01:04:59 1996
--- perl5_003_01/myconfig Wed Jul 10 20:40:12 1996
***************
*** 21,27 ****
Summary of my $package ($baserev patchlevel $PATCHLEVEL subversion $SUBVERSION) configuration:
Platform:
! osname=$osname, osver=$osvers, archname=$archname
uname='$myuname'
hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction
Compiler:
--- 21,27 ----
Summary of my $package ($baserev patchlevel $PATCHLEVEL subversion $SUBVERSION) configuration:
Platform:
! osname=$osname, osvers=$osvers, archname=$archname
uname='$myuname'
hint=$hint, useposix=$useposix, d_sigaction=$d_sigaction
Compiler:
#~ Add warning for duplicate my() declaration in same scope
#~ Allow redirection of debug/error messages
#~ Add op_seq flag used by compiler
#~ Add support for new GV type
#~ Add comment indicating potential fix for memory leak when free OP_ANONCODE;
#~ however, this fix breaks eval of anon sub in closure
#~ Carry G_KEEPERR setting down from perl_call_sv() into nested evals
#~ Remove problematic integer optimization of order comparisons
#~ Add shared hash key support
#~ Add optional version check to "use"
#~ Rename newCONDOP() parameters to avoid collisions with systtem headers
#~ Call imported "glob" function from "<*.*>"-style expansion
#~ Use defgv directly for arg-less "shift" within sub
#~ Permit spaces in prototype specifications
diff -Pcr perl5_003/op.c perl5_003_01/op.c
*** perl5_003/op.c Sun Jun 23 20:35:03 1996
--- perl5_003_01/op.c Sat Jul 6 09:43:23 1996
***************
*** 124,129 ****
--- 124,142 ----
sprintf(name+1, "^%c", name[1] ^ 64); /* XXX is tokenbuf, really */
croak("Can't use global %s in \"my\"",name);
}
+ if (AvFILL(comppad_name) >= 0) {
+ SV **svp = AvARRAY(comppad_name);
+ for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) {
+ if ((sv = svp[off])
+ && sv != &sv_undef
+ && SvIVX(sv) == 999999999 /* var is in open scope */
+ && strEQ(name, SvPVX(sv)))
+ {
+ warn("\"my\" variable %s masks earlier declaration in same scope", name);
+ break;
+ }
+ }
+ }
off = pad_alloc(OP_PADSV, SVs_PADMY);
sv = NEWSV(1102,0);
sv_upgrade(sv, SVt_PVNV);
***************
*** 308,314 ****
}
SvFLAGS(sv) |= tmptype;
curpad = AvARRAY(comppad);
! DEBUG_X(fprintf(stderr, "Pad alloc %ld for %s\n", (long) retval, op_name[optype]));
return (PADOFFSET)retval;
}
--- 321,327 ----
}
SvFLAGS(sv) |= tmptype;
curpad = AvARRAY(comppad);
! DEBUG_X(fprintf(Perl_debug_log, "Pad alloc %ld for %s\n", (long) retval, op_name[optype]));
return (PADOFFSET)retval;
}
***************
*** 322,328 ****
{
if (!po)
croak("panic: pad_sv po");
! DEBUG_X(fprintf(stderr, "Pad sv %d\n", po));
return curpad[po]; /* eventually we'll turn this into a macro */
}
--- 335,341 ----
{
if (!po)
croak("panic: pad_sv po");
! DEBUG_X(fprintf(Perl_debug_log, "Pad sv %d\n", po));
return curpad[po]; /* eventually we'll turn this into a macro */
}
***************
*** 340,346 ****
croak("panic: pad_free curpad");
if (!po)
croak("panic: pad_free po");
! DEBUG_X(fprintf(stderr, "Pad free %d\n", po));
if (curpad[po] && curpad[po] != &sv_undef)
SvPADTMP_off(curpad[po]);
if ((I32)po < padix)
--- 353,359 ----
croak("panic: pad_free curpad");
if (!po)
croak("panic: pad_free po");
! DEBUG_X(fprintf(Perl_debug_log, "Pad free %d\n", po));
if (curpad[po] && curpad[po] != &sv_undef)
SvPADTMP_off(curpad[po]);
if ((I32)po < padix)
***************
*** 359,365 ****
croak("panic: pad_swipe curpad");
if (!po)
croak("panic: pad_swipe po");
! DEBUG_X(fprintf(stderr, "Pad swipe %d\n", po));
SvPADTMP_off(curpad[po]);
curpad[po] = NEWSV(1107,0);
SvPADTMP_on(curpad[po]);
--- 372,378 ----
croak("panic: pad_swipe curpad");
if (!po)
croak("panic: pad_swipe po");
! DEBUG_X(fprintf(Perl_debug_log, "Pad swipe %d\n", po));
SvPADTMP_off(curpad[po]);
curpad[po] = NEWSV(1107,0);
SvPADTMP_on(curpad[po]);
***************
*** 374,380 ****
if (AvARRAY(comppad) != curpad)
croak("panic: pad_reset curpad");
! DEBUG_X(fprintf(stderr, "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)
--- 387,393 ----
if (AvARRAY(comppad) != curpad)
croak("panic: pad_reset curpad");
! DEBUG_X(fprintf(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)
***************
*** 393,399 ****
{
register OP *kid, *nextkid;
! if (!op)
return;
if (op->op_flags & OPf_KIDS) {
--- 406,412 ----
{
register OP *kid, *nextkid;
! if (!op || op->op_seq == (U16)-1)
return;
if (op->op_flags & OPf_KIDS) {
***************
*** 418,423 ****
--- 431,437 ----
case OP_DBSTATE:
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;
***************
*** 1251,1257 ****
block_start()
{
int retval = savestack_ix;
! comppad_name_fill = AvFILL(comppad_name);
SAVEINT(min_intro_pending);
SAVEINT(max_intro_pending);
min_intro_pending = 0;
--- 1265,1275 ----
block_start()
{
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);
min_intro_pending = 0;
***************
*** 1287,1293 ****
OP *op;
{
if (in_eval) {
! eval_root = newUNOP(OP_LEAVEEVAL, 0, op);
eval_start = linklist(eval_root);
eval_root->op_next = 0;
peep(eval_start);
--- 1305,1311 ----
OP *op;
{
if (in_eval) {
! eval_root = newUNOP(OP_LEAVEEVAL, ((in_eval & 4) ? OPf_SPECIAL : 0), op);
eval_start = linklist(eval_root);
eval_root->op_next = 0;
peep(eval_start);
***************
*** 1388,1394 ****
}
op_free(o);
if (type == OP_RV2GV)
! return newGVOP(OP_GV, 0, sv);
else {
if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) {
IV iv = SvIV(sv);
--- 1406,1412 ----
}
op_free(o);
if (type == OP_RV2GV)
! return newGVOP(OP_GV, 0, (GV*)sv);
else {
if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK) {
IV iv = SvIV(sv);
***************
*** 1396,1401 ****
--- 1414,1421 ----
SvREFCNT_dec(sv);
sv = newSViv(iv);
}
+ else
+ SvIOK_off(sv); /* undo SvIV() damage */
}
return newSVOP(OP_CONST, 0, sv);
}
***************
*** 1405,1438 ****
return o;
if (!(hints & HINT_INTEGER)) {
- int vars = 0;
-
if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS))
return o;
for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
if (curop->op_type == OP_CONST) {
! if (SvIOK(((SVOP*)curop)->op_sv)) {
! if (SvIVX(((SVOP*)curop)->op_sv) <= 0 && vars++)
! return o; /* negatives truncate wrong way, alas */
continue;
- }
return o;
}
if (opargs[curop->op_type] & OA_RETINTEGER)
continue;
- if (curop->op_type == OP_PADSV || curop->op_type == OP_RV2SV) {
- if (vars++)
- return o;
- if (((o->op_type == OP_LT || o->op_type == OP_GE) &&
- curop == ((BINOP*)o)->op_first ) ||
- ((o->op_type == OP_GT || o->op_type == OP_LE) &&
- curop == ((BINOP*)o)->op_last ))
- {
- /* Allow "$i < 100" and variants to integerize */
- continue;
- }
- }
return o;
}
o->op_ppaddr = ppaddr[++(o->op_type)];
--- 1425,1441 ----
return o;
if (!(hints & HINT_INTEGER)) {
if (type == OP_DIVIDE || !(o->op_flags & OPf_KIDS))
return o;
for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
if (curop->op_type == OP_CONST) {
! if (SvIOK(((SVOP*)curop)->op_sv))
continue;
return o;
}
if (opargs[curop->op_type] & OA_RETINTEGER)
continue;
return o;
}
o->op_ppaddr = ppaddr[++(o->op_type)];
***************
*** 2011,2017 ****
char *name;
sv = cSVOP->op_sv;
name = SvPV(sv, len);
! curstash = gv_stashpv(name,TRUE);
sv_setpvn(curstname, name, len);
op_free(op);
}
--- 2014,2020 ----
char *name;
sv = cSVOP->op_sv;
name = SvPV(sv, len);
! curstash = gv_stashpvn(name,len,TRUE);
sv_setpvn(curstname, name, len);
op_free(op);
}
***************
*** 2024,2032 ****
}
void
! utilize(aver, floor, id, arg)
int aver;
I32 floor;
OP *id;
OP *arg;
{
--- 2027,2036 ----
}
void
! utilize(aver, floor, version, id, arg)
int aver;
I32 floor;
+ OP *version;
OP *id;
OP *arg;
{
***************
*** 2034,2050 ****
OP *meth;
OP *rqop;
OP *imop;
if (id->op_type != OP_CONST)
croak("Module name must be constant");
/* Fake up an import/unimport */
if (arg && arg->op_type == OP_STUB)
imop = arg; /* no import on explicit () */
else {
/* Make copy of id so we don't free it twice */
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
-
meth = newSVOP(OP_CONST, 0,
aver
? newSVpv("import", 6)
--- 2038,2084 ----
OP *meth;
OP *rqop;
OP *imop;
+ OP *veop;
if (id->op_type != OP_CONST)
croak("Module name must be constant");
+ veop = Nullop;
+
+ if(version != Nullop) {
+ SV *vesv = ((SVOP*)version)->op_sv;
+
+ if (arg == Nullop && !SvNIOK(vesv)) {
+ arg = version;
+ }
+ else {
+ OP *pack;
+ OP *meth;
+
+ if (version->op_type != OP_CONST || !SvNIOK(vesv))
+ croak("Version number must be constant number");
+
+ /* Make copy of id so we don't free it twice */
+ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+
+ /* Fake up a method call to VERSION */
+ meth = newSVOP(OP_CONST, 0, newSVpv("VERSION", 7));
+ veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, pack, list(version)),
+ newUNOP(OP_METHOD, 0, meth)));
+ }
+ }
+
/* Fake up an import/unimport */
if (arg && arg->op_type == OP_STUB)
imop = arg; /* no import on explicit () */
+ else if(SvNIOK(((SVOP*)id)->op_sv)) {
+ imop = Nullop; /* use 5.0; */
+ }
else {
/* Make copy of id so we don't free it twice */
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
meth = newSVOP(OP_CONST, 0,
aver
? newSVpv("import", 6)
***************
*** 2064,2070 ****
newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)),
Nullop,
append_elem(OP_LINESEQ,
! newSTATEOP(0, Nullch, rqop),
newSTATEOP(0, Nullch, imop) ));
copline = NOLINE;
--- 2098,2106 ----
newSVOP(OP_CONST, 0, newSVpv("BEGIN", 5)),
Nullop,
append_elem(OP_LINESEQ,
! append_elem(OP_LINESEQ,
! newSTATEOP(0, Nullch, rqop),
! newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
copline = NOLINE;
***************
*** 2299,2305 ****
cop->cop_line = copline;
copline = NOLINE;
}
! cop->cop_filegv = SvREFCNT_inc(curcop->cop_filegv);
cop->cop_stash = curstash;
if (perldb && curstash != debstash) {
--- 2335,2341 ----
cop->cop_line = copline;
copline = NOLINE;
}
! cop->cop_filegv = GvREFCNT_inc(curcop->cop_filegv);
cop->cop_stash = curstash;
if (perldb && curstash != debstash) {
***************
*** 2389,2424 ****
}
OP *
! newCONDOP(flags, first, true, false)
I32 flags;
OP* first;
! OP* true;
! OP* false;
{
CONDOP *condop;
OP *op;
! if (!false)
! return newLOGOP(OP_AND, 0, first, true);
! if (!true)
! return newLOGOP(OP_OR, 0, first, false);
scalarboolean(first);
if (first->op_type == OP_CONST) {
if (SvTRUE(((SVOP*)first)->op_sv)) {
op_free(first);
! op_free(false);
! return true;
}
else {
op_free(first);
! op_free(true);
! return false;
}
}
else if (first->op_type == OP_WANTARRAY) {
! list(true);
! scalar(false);
}
Newz(1101, condop, 1, CONDOP);
--- 2425,2460 ----
}
OP *
! newCONDOP(flags, first, trueop, falseop)
I32 flags;
OP* first;
! OP* trueop;
! OP* falseop;
{
CONDOP *condop;
OP *op;
! if (!falseop)
! return newLOGOP(OP_AND, 0, first, trueop);
! if (!trueop)
! return newLOGOP(OP_OR, 0, first, falseop);
scalarboolean(first);
if (first->op_type == OP_CONST) {
if (SvTRUE(((SVOP*)first)->op_sv)) {
op_free(first);
! op_free(falseop);
! return trueop;
}
else {
op_free(first);
! op_free(trueop);
! return falseop;
}
}
else if (first->op_type == OP_WANTARRAY) {
! list(trueop);
! scalar(falseop);
}
Newz(1101, condop, 1, CONDOP);
***************
*** 2426,2445 ****
condop->op_ppaddr = ppaddr[OP_COND_EXPR];
condop->op_first = first;
condop->op_flags = flags | OPf_KIDS;
! condop->op_true = LINKLIST(true);
! condop->op_false = LINKLIST(false);
condop->op_private = 1 | (flags >> 8);
/* establish postfix order */
condop->op_next = LINKLIST(first);
first->op_next = (OP*)condop;
! first->op_sibling = true;
! true->op_sibling = false;
op = newUNOP(OP_NULL, 0, (OP*)condop);
! true->op_next = op;
! false->op_next = op;
return op;
}
--- 2462,2481 ----
condop->op_ppaddr = ppaddr[OP_COND_EXPR];
condop->op_first = first;
condop->op_flags = flags | OPf_KIDS;
! condop->op_true = LINKLIST(trueop);
! condop->op_false = LINKLIST(falseop);
condop->op_private = 1 | (flags >> 8);
/* establish postfix order */
condop->op_next = LINKLIST(first);
first->op_next = (OP*)condop;
! first->op_sibling = trueop;
! trueop->op_sibling = falseop;
op = newUNOP(OP_NULL, 0, (OP*)condop);
! trueop->op_next = op;
! falseop->op_next = op;
return op;
}
***************
*** 2723,2729 ****
CvCLONED_on(cv);
CvFILEGV(cv) = CvFILEGV(proto);
! CvGV(cv) = SvREFCNT_inc(CvGV(proto));
CvSTASH(cv) = CvSTASH(proto);
CvROOT(cv) = CvROOT(proto);
CvSTART(cv) = CvSTART(proto);
--- 2759,2765 ----
CvCLONED_on(cv);
CvFILEGV(cv) = CvFILEGV(proto);
! CvGV(cv) = GvREFCNT_inc(CvGV(proto));
CvSTASH(cv) = CvSTASH(proto);
CvROOT(cv) = CvROOT(proto);
CvSTART(cv) = CvSTART(proto);
***************
*** 2796,2802 ****
if (GvCVGEN(gv))
cv = 0; /* just a cached method */
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
! if (dowarn) { /* already defined (or promised)? */
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
--- 2832,2838 ----
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)? */
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
***************
*** 2823,2829 ****
GvCV(gv) = cv;
GvCVGEN(gv) = 0;
CvFILEGV(cv) = curcop->cop_filegv;
! CvGV(cv) = SvREFCNT_inc(gv);
CvSTASH(cv) = curstash;
if (proto) {
--- 2859,2865 ----
GvCV(gv) = cv;
GvCVGEN(gv) = 0;
CvFILEGV(cv) = curcop->cop_filegv;
! CvGV(cv) = GvREFCNT_inc(gv);
CvSTASH(cv) = curstash;
if (proto) {
***************
*** 2879,2886 ****
av_push(beginav, (SV *)cv);
DEBUG_x( dump_sub(gv) );
rs = SvREFCNT_inc(nrs);
! GvCV(gv) = 0;
calllist(beginav);
SvREFCNT_dec(rs);
rs = oldrs;
curcop = &compiling;
--- 2915,2926 ----
av_push(beginav, (SV *)cv);
DEBUG_x( dump_sub(gv) );
rs = SvREFCNT_inc(nrs);
! SvREFCNT_inc(cv);
calllist(beginav);
+ if (GvCV(gv) == cv) { /* Detach it. */
+ SvREFCNT_dec(cv);
+ GvCV(gv) = 0; /* Was above calllist, why? IZ */
+ }
SvREFCNT_dec(rs);
rs = oldrs;
curcop = &compiling;
***************
*** 2966,2972 ****
sv_upgrade((SV *)cv, SVt_PVCV);
}
GvCV(gv) = cv;
! CvGV(cv) = SvREFCNT_inc(gv);
GvCVGEN(gv) = 0;
CvFILEGV(cv) = gv_fetchfile(filename);
CvXSUB(cv) = subaddr;
--- 3006,3012 ----
sv_upgrade((SV *)cv, SVt_PVCV);
}
GvCV(gv) = cv;
! CvGV(cv) = GvREFCNT_inc(gv);
GvCVGEN(gv) = 0;
CvFILEGV(cv) = gv_fetchfile(filename);
CvXSUB(cv) = subaddr;
***************
*** 3023,3029 ****
}
cv = compcv;
GvFORM(gv) = cv;
! CvGV(cv) = SvREFCNT_inc(gv);
CvFILEGV(cv) = curcop->cop_filegv;
for (ix = AvFILL(comppad); ix > 0; ix--) {
--- 3063,3069 ----
}
cv = compcv;
GvFORM(gv) = cv;
! CvGV(cv) = GvREFCNT_inc(gv);
CvFILEGV(cv) = curcop->cop_filegv;
for (ix = AvFILL(comppad); ix > 0; ix--) {
***************
*** 3530,3536 ****
ck_glob(op)
OP *op;
{
! GV *gv = newGVgen("main");
gv_IOadd(gv);
append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv));
scalarkids(op);
--- 3570,3587 ----
ck_glob(op)
OP *op;
{
! GV *gv = gv_fetchpv("glob", FALSE, SVt_PVCV);
!
! if (gv && GvIMPORTED_CV(gv)) {
! op->op_type = OP_LIST;
! op->op_ppaddr = ppaddr[OP_LIST];
! op = newUNOP(OP_ENTERSUB, OPf_STACKED,
! append_elem(OP_LIST, op,
! scalar(newUNOP(OP_RV2CV, 0,
! newGVOP(OP_GV, 0, gv)))));
! return ck_subr(op);
! }
! gv = newGVgen("main");
gv_IOadd(gv);
append_elem(OP_GLOB, op, newGVOP(OP_GV, 0, gv));
scalarkids(op);
***************
*** 3745,3752 ****
op_free(op);
return newUNOP(type, 0,
scalar(newUNOP(OP_RV2AV, 0,
! scalar(newGVOP(OP_GV, 0,
! gv_fetchpv((subline ? "_" : "ARGV"), TRUE, SVt_PVAV) )))));
}
return scalar(modkids(ck_fun(op), type));
}
--- 3796,3804 ----
op_free(op);
return newUNOP(type, 0,
scalar(newUNOP(OP_RV2AV, 0,
! scalar(newGVOP(OP_GV, 0, subline
! ? defgv
! : gv_fetchpv("ARGV", TRUE, SVt_PVAV) )))));
}
return scalar(modkids(ck_fun(op), type));
}
***************
*** 3953,3958 ****
--- 4005,4013 ----
default: goto oops;
}
break;
+ case ' ':
+ proto++;
+ continue;
default:
oops:
croak("Malformed prototype for %s: %s",
#~ Overload OPf_SPECIAL with G_KEEPERR status for OP_(ENTER|LEAVE)EVAL
diff -Pcr perl5_003/op.h perl5_003_01/op.h
*** perl5_003/op.h Sun Jan 28 00:15:28 1996
--- perl5_003_01/op.h Fri Jul 5 13:38:18 1996
***************
*** 63,68 ****
--- 63,69 ----
/* On flipflop, we saw ... instead of .. */
/* On UNOPs, saw bare parens, e.g. eof(). */
/* On OP_ENTERSUB || OP_NULL, saw a "do". */
+ /* On OP_(ENTER|LEAVE)EVAL, don't clear $@ */
/* Private for lvalues */
#define OPpLVAL_INTRO 128 /* Lvalue must be localized */
#~ Reflect fix to "truncate" in opcode.pl
diff -Pcr perl5_003/opcode.h perl5_003_01/opcode.h
*** perl5_003/opcode.h Wed Feb 14 19:00:28 1996
--- perl5_003_01/opcode.h Fri Jul 5 14:59:56 1996
***************
*** 2344,2350 ****
0x00000e14, /* eof */
0x00000e0c, /* tell */
0x00011604, /* seek */
! 0x00001114, /* truncate */
0x0001160c, /* fcntl */
0x0001160c, /* ioctl */
0x0000161c, /* flock */
--- 2344,2350 ----
0x00000e14, /* eof */
0x00000e0c, /* tell */
0x00011604, /* seek */
! 0x00001614, /* truncate */
0x0001160c, /* fcntl */
0x0001160c, /* ioctl */
0x0000161c, /* flock */
#~ "truncate" should expect file handle as first argument
diff -Pcr perl5_003/opcode.pl perl5_003_01/opcode.pl
*** perl5_003/opcode.pl Wed Feb 14 19:00:09 1996
--- perl5_003_01/opcode.pl Fri Jul 5 14:58:34 1996
***************
*** 477,483 ****
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 S S
fcntl fcntl ck_fun st F S S
ioctl ioctl ck_fun st F S S
--- 477,483 ----
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
fcntl fcntl ck_fun st F S S
ioctl ioctl ck_fun st F S S
#~ Add a.out support
#~ Update library and dynamic loading support
diff -Pcr perl5_003/os2/Makefile.SHs perl5_003_01/os2/Makefile.SHs
*** perl5_003/os2/Makefile.SHs Mon Mar 25 01:05:00 1996
--- perl5_003_01/os2/Makefile.SHs Tue Jun 18 21:42:20 1996
***************
*** 1,5 ****
! # This file is read by Makefile.SH to produce rules for $(perllib)
! # We insert perl5.def since I do not know how to generate it yet.
$spitshell >>Makefile <<'!NO!SUBS!'
$(perllib): perl.imp perl.dll perl5.def
--- 1,21 ----
! # This file is read by Makefile.SH to produce rules for $(perllib) (and
! # some additional rules as well).
!
! # Rerun `sh Makefile.SH; make depend' after making any change.
!
! # Additional rules supported: perl_, aout_test, aout_install, use them
! # for a.out style perl (which may fork).
!
! $spitshell >>Makefile <<!GROK!THIS!
!
! AOUT_CCCMD = \$(CC) $aout_ccflags $optimize
! AOUT_AR = $aout_ar
! AOUT_OBJ_EXT = $aout_obj_ext
! AOUT_LIB_EXT = $aout_lib_ext
! aout_perllib = libperl$aout_lib_ext
! AOUT_CLDFLAGS = $aout_ldflags
!
! !GROK!THIS!
$spitshell >>Makefile <<'!NO!SUBS!'
$(perllib): perl.imp perl.dll perl5.def
***************
*** 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" > $@
--- 25,31 ----
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" > $@
***************
*** 19,26 ****
--- 35,46 ----
echo DATA LOADONCALL NONSHARED MULTIPLE >>$@
echo EXPORTS >>$@
echo ' "ctermid"' >>$@
+ echo ' "get_sysinfo"' >>$@
echo ' "Perl_OS2_init"' >>$@
echo ' "OS2_Perl_data"' >>$@
+ echo ' "dlopen"' >>$@
+ echo ' "dlsym"' >>$@
+ echo ' "dlerror"' >>$@
!NO!SUBS!
if [ ! -z "$myttyname" ] ; then
***************
*** 49,59 ****
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
! depend: os2ish.h
# Stupid make? Needed...
os2$(OBJ_EXT) : os2.c
--- 69,79 ----
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
! depend: os2ish.h dlfcn.h
# Stupid make? Needed...
os2$(OBJ_EXT) : os2.c
***************
*** 61,71 ****
--- 81,140 ----
os2.c: os2/os2.c os2ish.h
cp $< $@
+ dl_os2.c: os2/dl_os2.c os2ish.h
+ cp $< $@
+
os2ish.h: os2/os2ish.h
cp $< $@
+ dlfcn.h: os2/dlfcn.h
+ cp $< $@
+
+
installcmd :
perl -e 'die qq{Give the option INSTALLCMDDIR=... to make!} if $$ARGV[0] eq ""' $(INSTALLCMDDIR)
perl os2/perl2cmd.pl $(INSTALLCMDDIR)
+
+ # Aout section:
+
+ aout_obj = $(addsuffix $(AOUT_OBJ_EXT),$(basename $(obj)))
+ AOUT_DYNALOADER = $(addsuffix $(AOUT_LIB_EXT),$(basename $(DYNALOADER)))
+ aout_static_ext = $(addsuffix $(AOUT_LIB_EXT),$(basename $(dynamic_ext)))
+ aout_static_lib = $(addsuffix $(LIB_EXT),$(basename $(dynamic_ext)))
+
+ $(aout_perllib) : $(aout_obj) perl$(AOUT_OBJ_EXT)
+ rm -f $(perllib)
+ $(AOUT_AR) rcu $(aout_perllib) perl$(AOUT_OBJ_EXT) $(aout_obj)
+
+ .c$(AOUT_OBJ_EXT):
+ $(AOUT_CCCMD) $(PLDLFLAGS) -c $*.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)
+
+ 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)
+
+ aout_clean:
+ -rm *perl_.* *.o *.a lib/auto/*/*.a ext/*/Makefile.aout
+
+ aout_install: perl_ aout_install.perl
+
+ aout_install.perl: perl_ installperl
+ ./perl_ installperl
+
+ aout_test: perl_
+ - cd t && (rm -f perl_$(EXE_EXT); $(LNS) ../perl_$(EXE_EXT) perl_$(EXE_EXT)) && ./perl_ TEST </dev/tty
+
+ lib/auto/*/%.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=
+
+ ext/%/Makefile.aout : miniperl_
+ cd $(dir $@) ; ../../miniperl_ Makefile.PL MAKEFILE=Makefile.aout INSTALLDIRS=perl
!NO!SUBS!
#~ Add OS/2-specific dynamic loading routines emulating dlopen calls
diff -Pcr perl5_003/os2/dl_os2.c perl5_003_01/os2/dl_os2.c
*** perl5_003/os2/dl_os2.c Wed Dec 31 19:00:00 1969
--- perl5_003_01/os2/dl_os2.c Tue Jun 18 20:42:26 1996
***************
*** 0 ****
--- 1,71 ----
+ #include "dlfcn.h"
+
+ #define INCL_BASE
+ #include <os2.h>
+
+ static ULONG retcode;
+
+ void *
+ dlopen(char *path, int mode)
+ {
+ HMODULE handle;
+ char tmp[260], *beg, *dot;
+ char fail[300];
+ ULONG rc;
+
+ if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0)
+ return (void *)handle;
+
+ retcode = rc;
+
+ /* Not found. Check for non-FAT name and try truncated name. */
+ /* Don't know if this helps though... */
+ for (beg = dot = path + strlen(path);
+ beg > path && !strchr(":/\\", *(beg-1));
+ beg--)
+ if (*beg == '.')
+ dot = beg;
+ if (dot - beg > 8) {
+ int n = beg+8-path;
+ memmove(tmp, path, n);
+ memmove(tmp+n, dot, strlen(dot)+1);
+ if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0)
+ return (void *)handle;
+ }
+
+ return NULL;
+ }
+
+ void *
+ dlsym(void *handle, char *symbol)
+ {
+ ULONG rc, type;
+ PFN addr;
+
+ rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr);
+ if (rc == 0) {
+ rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type);
+ if (rc == 0 && type == PT_32BIT)
+ return (void *)addr;
+ rc = ERROR_CALL_NOT_IMPLEMENTED;
+ }
+ retcode = rc;
+ return NULL;
+ }
+
+ char *
+ dlerror(void)
+ {
+ static char buf[300];
+ ULONG len;
+
+ if (retcode == 0)
+ return NULL;
+ if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len))
+ sprintf(buf, "OS/2 system error code %d", retcode);
+ else
+ buf[len] = '\0';
+ retcode = 0;
+ return buf;
+ }
+
#~ Prototypes for OS/2-specific emulation of dlopen routines
diff -Pcr perl5_003/os2/dlfcn.h perl5_003_01/os2/dlfcn.h
*** perl5_003/os2/dlfcn.h Wed Dec 31 19:00:00 1969
--- perl5_003_01/os2/dlfcn.h Tue Jun 18 20:42:27 1996
***************
*** 0 ****
--- 1,6 ----
+ 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);
#~ DB_File OS/2 changes subsumed into new version of DB_File
diff -Pcr perl5_003/os2/notes perl5_003_01/os2/notes
*** perl5_003/os2/notes Mon Jan 22 20:46:20 1996
--- perl5_003_01/os2/notes Fri Jul 5 18:45:34 1996
***************
*** 25,28 ****
diff.c2ph, diff.rest are small and should not break anything.
- diff.db_file adds binary mode.
--- 25,27 ----
#~ Update process priority functions
#~ Use SH_PATH macro to find shell
#~ Use local popen only if not using fork()
#~ Add OS/2-specific mod2fname for DynaLoader support
#~ Add strerror() equivalent for OS/2-specific errors
diff -Pcr perl5_003/os2/os2.c perl5_003_01/os2/os2.c
*** perl5_003/os2/os2.c Mon Mar 25 01:05:01 1996
--- perl5_003_01/os2/os2.c Tue Jun 18 21:42:24 1996
***************
*** 21,39 ****
/*****************************************************************************/
/* priorities */
! int setpriority(int which, int pid, int val)
{
! return DosSetPriority((pid < 0) ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
! val >> 8, val & 0xFF, abs(pid));
}
! int getpriority(int which /* ignored */, int pid)
{
TIB *tib;
PIB *pib;
! DosGetInfoBlocks(&tib, &pib);
! return tib->tib_ptib2->tib2_ulpri;
}
/*****************************************************************************/
--- 21,131 ----
/*****************************************************************************/
/* priorities */
+ static signed char priors[] = {0, 1, 3, 2}; /* Last two interchanged,
+ self inverse. */
+ #define QSS_INI_BUFFER 1024
+
+ PQTOPLEVEL
+ get_sysinfo(ULONG pid, ULONG flags)
+ {
+ char *pbuffer;
+ ULONG rc, buf_len = QSS_INI_BUFFER;
+
+ New(1022, pbuffer, buf_len, char);
+ /* QSS_PROCESS | QSS_MODULE | QSS_SEMAPHORES | QSS_SHARED */
+ rc = QuerySysState(flags, pid, pbuffer, buf_len);
+ while (rc == ERROR_BUFFER_OVERFLOW) {
+ Renew(pbuffer, buf_len *= 2, char);
+ rc = QuerySysState(QSS_PROCESS, pid, pbuffer, buf_len);
+ }
+ if (rc) {
+ FillOSError(rc);
+ Safefree(pbuffer);
+ return 0;
+ }
+ return (PQTOPLEVEL)pbuffer;
+ }
+
+ #define PRIO_ERR 0x1111
! static ULONG
! sys_prio(pid)
{
! ULONG prio;
! PQTOPLEVEL psi;
!
! psi = get_sysinfo(pid, QSS_PROCESS);
! if (!psi) {
! return PRIO_ERR;
! }
! if (pid != psi->procdata->pid) {
! Safefree(psi);
! croak("panic: wrong pid in sysinfo");
! }
! prio = psi->procdata->threads->priority;
! Safefree(psi);
! return prio;
! }
!
! int
! setpriority(int which, int pid, int val)
! {
! ULONG rc, prio;
! PQTOPLEVEL psi;
!
! prio = sys_prio(pid);
!
! if (priors[(32 - val) >> 5] + 1 == (prio >> 8)) {
! /* Do not change class. */
! return CheckOSError(DosSetPriority((pid < 0)
! ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
! 0,
! (32 - val) % 32 - (prio & 0xFF),
! abs(pid)))
! ? -1 : 0;
! } else /* if ((32 - val) % 32 == (prio & 0xFF)) */ {
! /* Documentation claims one can change both class and basevalue,
! * but I find it wrong. */
! /* Change class, but since delta == 0 denotes absolute 0, correct. */
! if (CheckOSError(DosSetPriority((pid < 0)
! ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
! priors[(32 - val) >> 5] + 1,
! 0,
! abs(pid))))
! return -1;
! if ( ((32 - val) % 32) == 0 ) return 0;
! return CheckOSError(DosSetPriority((pid < 0)
! ? PRTYS_PROCESSTREE : PRTYS_PROCESS,
! 0,
! (32 - val) % 32,
! abs(pid)))
! ? -1 : 0;
! }
! /* else return CheckOSError(DosSetPriority((pid < 0) */
! /* ? PRTYS_PROCESSTREE : PRTYS_PROCESS, */
! /* priors[(32 - val) >> 5] + 1, */
! /* (32 - val) % 32 - (prio & 0xFF), */
! /* abs(pid))) */
! /* ? -1 : 0; */
}
! int
! getpriority(int which /* ignored */, int pid)
{
TIB *tib;
PIB *pib;
! ULONG rc, ret;
!
! /* DosGetInfoBlocks has old priority! */
! /* if (CheckOSError(DosGetInfoBlocks(&tib, &pib))) return -1; */
! /* if (pid != pib->pib_ulpid) { */
! ret = sys_prio(pid);
! if (ret == PRIO_ERR) {
! return -1;
! }
! /* } else */
! /* ret = tib->tib_ptib2->tib2_ulpri; */
! return (1 - priors[((ret >> 8) - 1)])*32 - (ret & 0xFF);
}
/*****************************************************************************/
***************
*** 135,141 ****
have a shell which will not change between computers with the
same architecture, to avoid "action on a distance".
And to have simple build, this shell should be sh. */
! shell = "sh.exe";
copt = "-c";
#endif
--- 227,233 ----
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;
copt = "-c";
#endif
***************
*** 194,199 ****
--- 286,292 ----
return rc;
}
+ #ifndef HAS_FORK
FILE *
my_popen(cmd,mode)
char *cmd;
***************
*** 202,212 ****
char *shell = getenv("EMXSHELL");
FILE *res;
! my_setenv("EMXSHELL", "sh.exe");
res = popen(cmd, mode);
my_setenv("EMXSHELL", shell);
return res;
}
/*****************************************************************************/
--- 295,306 ----
char *shell = getenv("EMXSHELL");
FILE *res;
! my_setenv("EMXSHELL", SH_PATH);
res = popen(cmd, mode);
my_setenv("EMXSHELL", shell);
return res;
}
+ #endif
/*****************************************************************************/
***************
*** 357,370 ****
flag = (unsigned long)SvIV(ST(2));
}
! errno = DosCopy(src, dst, flag);
! RETVAL = !errno;
ST(0) = sv_newmortal();
sv_setiv(ST(0), (IV)RETVAL);
}
XSRETURN(1);
}
OS2_Perl_data_t OS2_Perl_data;
int
--- 451,519 ----
flag = (unsigned long)SvIV(ST(2));
}
! RETVAL = !CheckOSError(DosCopy(src, dst, flag));
ST(0) = sv_newmortal();
sv_setiv(ST(0), (IV)RETVAL);
}
XSRETURN(1);
}
+ char *
+ mod2fname(sv)
+ SV *sv;
+ {
+ static char fname[9];
+ int pos = 7;
+ int len;
+ AV *av;
+ SV *svp;
+ char *s;
+
+ if (!SvROK(sv)) croak("Not a reference given to mod2fname");
+ sv = SvRV(sv);
+ if (SvTYPE(sv) != SVt_PVAV)
+ croak("Not array reference given to mod2fname");
+ if (av_len((AV*)sv) < 0)
+ croak("Empty array reference given to mod2fname");
+ s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na);
+ strncpy(fname, s, 8);
+ if ((len=strlen(s)) < 7) pos = len;
+ fname[pos] = '_';
+ fname[pos + 1] = '\0';
+ return (char *)fname;
+ }
+
+ XS(XS_DynaLoader_mod2fname)
+ {
+ dXSARGS;
+ if (items != 1)
+ croak("Usage: DynaLoader::mod2fname(sv)");
+ {
+ SV * sv = ST(0);
+ char * RETVAL;
+
+ RETVAL = mod2fname(sv);
+ ST(0) = sv_newmortal();
+ sv_setpv((SV*)ST(0), RETVAL);
+ }
+ XSRETURN(1);
+ }
+
+ char *
+ os2error(int rc)
+ {
+ static char buf[300];
+ ULONG len;
+
+ if (rc == 0)
+ return NULL;
+ if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, rc, "OSO001.MSG", &len))
+ sprintf(buf, "OS/2 system error code %d=0x%x", rc, rc);
+ else
+ buf[len] = '\0';
+ return buf;
+ }
+
OS2_Perl_data_t OS2_Perl_data;
int
***************
*** 372,384 ****
--- 521,551 ----
{
char *file = __FILE__;
{
+ GV *gv;
+
newXS("File::Copy::syscopy", XS_File__Copy_syscopy, file);
+ newXS("DynaLoader::mod2fname", XS_DynaLoader_mod2fname, file);
+ #ifdef PERL_IS_AOUT
+ gv = gv_fetchpv("OS2::is_aout", TRUE, SVt_PV);
+ GvMULTI_on(gv);
+ sv_setiv(GvSV(gv), 1);
+ #endif
}
}
void
Perl_OS2_init()
{
+ char *shell;
+
settmppath();
OS2_Perl_data.xs_init = &Xs_OS2_init;
+ if ( (shell = getenv("PERL_SH_DRIVE")) ) {
+ sh_path[0] = shell[0];
+ }
}
+
+ char sh_path[33] = BIN_SH;
+
+ extern void dlopen();
+ void *fakedl = &dlopen; /* Pull in dynaloading part. */
#~ Add OS-specific setup for cpp macros introduced by Plan9 and VMS
#~ Eliminate old PERL_SYS_TERM definition
#~ Add a.out support
#~ Improved error status/message handling
#~ Add data types for process management
diff -Pcr perl5_003/os2/os2ish.h perl5_003_01/os2/os2ish.h
*** perl5_003/os2/os2ish.h Mon Mar 25 01:05:01 1996
--- perl5_003_01/os2/os2ish.h Thu Jul 25 16:12:38 1996
***************
*** 14,19 ****
--- 14,41 ----
#define HAS_KILL
#define HAS_WAIT
+ #define HAS_DLERROR
+
+ /* USEMYBINMODE
+ * This symbol, if defined, indicates that the program should
+ * use the routine my_binmode(FILE *fp, char iotype) to insure
+ * that a file is in "binary" mode -- that is, that no translation
+ * of bytes occurs on read or write operations.
+ */
+ #undef USEMYBINMODE
+
+ /* USE_STAT_RDEV:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_rdev
+ */
+ #define USE_STAT_RDEV /**/
+
+ /* ACME_MESS:
+ * This symbol, if defined, indicates that error messages should be
+ * should be generated in a format that allows the use of the Acme
+ * GUI/editor's autofind feature.
+ */
+ #undef ACME_MESS /**/
#ifndef SIGABRT
# define SIGABRT SIGILL
***************
*** 34,41 ****
--- 56,70 ----
#define PERL_SYS_TERM()
+ /* #define PERL_SYS_TERM() STMT_START { \
+ if (Perl_HAB_set) WinTerminate(Perl_hab); } STMT_END */
+
#define dXSUB_SYS int fake = OS2_XS_init()
+ #ifdef PERL_IS_AOUT
+ #define NO_SYS_ALLOC
+ #endif
+
#define TMPPATH tmppath
#define TMPPATH1 "plXXXXXX"
extern char *tmppath;
***************
*** 96,109 ****
unsigned long flags;
unsigned long phab;
int (*xs_init)();
} OS2_Perl_data_t;
extern OS2_Perl_data_t OS2_Perl_data;
! #define hab ((HAB)OS2_Perl_data->phab)
! #define OS2_Perl_flag (OS2_Perl_data->flag)
#define Perl_HAB_set_f 1
! #define Perl_HAB_set (OS2_Perl_flag & Perl_HAB_set_f)
! #define set_Perl_HAB_f (OS2_Perl_flag |= Perl_HAB_set_f)
! #define set_Perl_HAB(h) (set_Perl_HAB_f, hab = h)
#define OS2_XS_init() (*OS2_Perl_data.xs_init)()
--- 125,337 ----
unsigned long flags;
unsigned long phab;
int (*xs_init)();
+ unsigned long rc;
+ unsigned long severity;
} OS2_Perl_data_t;
extern OS2_Perl_data_t OS2_Perl_data;
! #define Perl_hab ((HAB)OS2_Perl_data.phab)
! #define Perl_rc (OS2_Perl_data.rc)
! #define Perl_severity (OS2_Perl_data.severity)
! #define errno_isOS2 12345678
! #define OS2_Perl_flags (OS2_Perl_data.flags)
#define Perl_HAB_set_f 1
! #define Perl_HAB_set (OS2_Perl_flags & Perl_HAB_set_f)
! #define set_Perl_HAB_f (OS2_Perl_flags |= Perl_HAB_set_f)
! #define set_Perl_HAB(h) (set_Perl_HAB_f, Perl_hab = h)
#define OS2_XS_init() (*OS2_Perl_data.xs_init)()
+ /* The expressions below return true on error. */
+ /* INCL_DOSERRORS needed. */
+ #define CheckOSError(expr) (!(rc = (expr)) ? 0 : (FillOSError(rc), 1))
+ /* INCL_WINERRORS needed. */
+ #define SaveWinError(expr) ((expr) ? : (FillWinError, 0))
+ #define CheckWinError(expr) ((expr) ? 0: (FillWinError, 1))
+ #define FillOSError(rc) (Perl_rc = rc, \
+ errno = errno_isOS2, \
+ Perl_severity = SEVERITY_ERROR)
+ #define FillWinError (Perl_rc = WinGetLastError(Perl_hab), \
+ errno = errno_isOS2, \
+ Perl_severity = ERRORIDSEV(Perl_rc), \
+ Perl_rc = ERRORIDERROR(Perl_rc))
+ #define Acquire_hab() if (!Perl_HAB_set) { \
+ Perl_hab = WinInitialize(0); \
+ if (!Perl_hab) die("WinInitialize failed"); \
+ set_Perl_HAB_f; \
+ }
+
+ extern char sh_path[33];
+ #define SH_PATH sh_path
+
+ char *os2error(int rc);
+
+ /* ************************************************************ */
+ #define Dos32QuerySysState DosQuerySysState
+ #define QuerySysState(flags, pid, buf, bufsz) \
+ Dos32QuerySysState(flags, 0, pid, 0, buf, bufsz)
+
+ #define QSS_PROCESS 1
+ #define QSS_MODULE 2
+ #define QSS_SEMAPHORES 4
+ #define QSS_FILE 8 /* Buggy until fixpack18 */
+ #define QSS_SHARED 16
+
+ #ifdef _OS2EMX_H
+
+ APIRET APIENTRY Dos32QuerySysState(ULONG func,ULONG arg1,ULONG pid,
+ ULONG _res_,PVOID buf,ULONG bufsz);
+ typedef struct {
+ ULONG threadcnt;
+ ULONG proccnt;
+ ULONG modulecnt;
+ } QGLOBAL, *PQGLOBAL;
+
+ typedef struct {
+ ULONG rectype;
+ USHORT threadid;
+ USHORT slotid;
+ ULONG sleepid;
+ ULONG priority;
+ ULONG systime;
+ ULONG usertime;
+ UCHAR state;
+ UCHAR _reserved1_; /* padding to ULONG */
+ USHORT _reserved2_; /* padding to ULONG */
+ } QTHREAD, *PQTHREAD;
+
+ typedef struct {
+ USHORT sfn;
+ USHORT refcnt;
+ USHORT flags1;
+ USHORT flags2;
+ USHORT accmode1;
+ USHORT accmode2;
+ ULONG filesize;
+ USHORT volhnd;
+ USHORT attrib;
+ USHORT _reserved_;
+ } QFDS, *PQFDS;
+
+ typedef struct qfile {
+ ULONG rectype;
+ struct qfile *next;
+ ULONG opencnt;
+ PQFDS filedata;
+ char name[1];
+ } QFILE, *PQFILE;
+
+ typedef struct {
+ ULONG rectype;
+ PQTHREAD threads;
+ USHORT pid;
+ USHORT ppid;
+ ULONG type;
+ ULONG state;
+ ULONG sessid;
+ USHORT hndmod;
+ USHORT threadcnt;
+ ULONG privsem32cnt;
+ ULONG _reserved2_;
+ USHORT sem16cnt;
+ USHORT dllcnt;
+ USHORT shrmemcnt;
+ USHORT fdscnt;
+ PUSHORT sem16s;
+ PUSHORT dlls;
+ PUSHORT shrmems;
+ PUSHORT fds;
+ } QPROCESS, *PQPROCESS;
+
+ typedef struct sema {
+ struct sema *next;
+ USHORT refcnt;
+ UCHAR sysflags;
+ UCHAR sysproccnt;
+ ULONG _reserved1_;
+ USHORT index;
+ CHAR name[1];
+ } QSEMA, *PQSEMA;
+
+ typedef struct {
+ ULONG rectype;
+ ULONG _reserved1_;
+ USHORT _reserved2_;
+ USHORT syssemidx;
+ ULONG index;
+ QSEMA sema;
+ } QSEMSTRUC, *PQSEMSTRUC;
+
+ typedef struct {
+ USHORT pid;
+ USHORT opencnt;
+ } QSEMOWNER32, *PQSEMOWNER32;
+
+ typedef struct {
+ PQSEMOWNER32 own;
+ PCHAR name;
+ PVOID semrecs; /* array of associated sema's */
+ USHORT flags;
+ USHORT semreccnt;
+ USHORT waitcnt;
+ USHORT _reserved_; /* padding to ULONG */
+ } QSEMSMUX32, *PQSEMSMUX32;
+
+ typedef struct {
+ PQSEMOWNER32 own;
+ PCHAR name;
+ PQSEMSMUX32 mux;
+ USHORT flags;
+ USHORT postcnt;
+ } QSEMEV32, *PQSEMEV32;
+
+ typedef struct {
+ PQSEMOWNER32 own;
+ PCHAR name;
+ PQSEMSMUX32 mux;
+ USHORT flags;
+ USHORT refcnt;
+ USHORT thrdnum;
+ USHORT _reserved_; /* padding to ULONG */
+ } QSEMMUX32, *PQSEMMUX32;
+
+ typedef struct semstr32 {
+ struct semstr *next;
+ QSEMEV32 evsem;
+ QSEMMUX32 muxsem;
+ QSEMSMUX32 smuxsem;
+ } QSEMSTRUC32, *PQSEMSTRUC32;
+
+ typedef struct shrmem {
+ struct shrmem *next;
+ USHORT hndshr;
+ USHORT selshr;
+ USHORT refcnt;
+ CHAR name[1];
+ } QSHRMEM, *PQSHRMEM;
+
+ typedef struct module {
+ struct module *next;
+ USHORT hndmod;
+ USHORT type;
+ ULONG refcnt;
+ ULONG segcnt;
+ PVOID _reserved_;
+ PCHAR name;
+ USHORT modref[1];
+ } QMODULE, *PQMODULE;
+
+ typedef struct {
+ PQGLOBAL gbldata;
+ PQPROCESS procdata;
+ PQSEMSTRUC semadata;
+ PQSEMSTRUC32 sem32data;
+ PQSHRMEM shrmemdata;
+ PQMODULE moddata;
+ PVOID _reserved2_;
+ PQFILE filedata;
+ } QTOPLEVEL, *PQTOPLEVEL;
+ /* ************************************************************ */
+
+ PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags);
+
+ #endif /* _OS2EMX_H */
#~ Update SUBVERSION
#~ Hide LOCAL_PATCH_COUNT from metaconfig
diff -Pcr perl5_003/patchlevel.h perl5_003_01/patchlevel.h
*** perl5_003/patchlevel.h Sun Jun 23 13:57:18 1996
--- perl5_003_01/patchlevel.h Sun Jul 7 20:12:50 1996
***************
*** 1,5 ****
#define PATCHLEVEL 3
! #define SUBVERSION 0
/*
local_patches -- list of locally applied less-than-subversion patches.
--- 1,5 ----
#define PATCHLEVEL 3
! #define SUBVERSION 1
/*
local_patches -- list of locally applied less-than-subversion patches.
***************
*** 41,45 ****
,NULL
};
! #define LOCAL_PATCH_COUNT \
(sizeof(local_patches)/sizeof(local_patches[0])-2)
--- 41,46 ----
,NULL
};
! /* Initial space prevents this variable from being inserted in config.sh */
! # define LOCAL_PATCH_COUNT \
(sizeof(local_patches)/sizeof(local_patches[0])-2)
#~ Clean up interpreter initialization to eliminate leaks when
#~ multiple interpreters are started within a single application
#~ Add shared hash key support
#~ Initialize NeXT dynamic loading
#~ Move information from -v to -V to keep the former concise
#~ Rename global variables to eliminate collisions with system headers
#~ Initialize new UNIVERSAL routines
#~ Allow redirection of debug messages
#~ Get debugger set up to debug BEGIN blocks
#~ Assume G_EVAL in perl_eval_sv(), and propagate G_KEEPERR correctly
#~ Remove help info for obsolete OS/2 command line switch
#~ Uncouple $/ setup from $\
#~ Update VMS -S handling
#~ Recognize perl binaries on #! line when name contains version
#~ Insure open script is rewound by suidperl before handing off to normal perl
diff -Pcr perl5_003/perl.c perl5_003_01/perl.c
*** perl5_003/perl.c Mon Jun 24 17:06:37 1996
--- perl5_003_01/perl.c Thu Jul 11 12:25:43 1996
***************
*** 45,50 ****
--- 45,51 ----
static void init_postdump_symbols _((int, char **, char **));
static void init_predump_symbols _((void));
static void init_stacks _((void));
+ static void nuke_stacks _((void));
static void open_script _((char *, bool, SV *));
static void usage _((char *));
static void validate_suid _((char *, char*));
***************
*** 77,91 ****
linestr = NEWSV(65,80);
sv_upgrade(linestr,SVt_PVIV);
! SvREADONLY_on(&sv_undef);
! sv_setpv(&sv_no,No);
! SvNV(&sv_no);
! SvREADONLY_on(&sv_no);
!
! sv_setpv(&sv_yes,Yes);
! SvNV(&sv_yes);
! SvREADONLY_on(&sv_yes);
nrs = newSVpv("\n", 1);
rs = SvREFCNT_inc(nrs);
--- 78,94 ----
linestr = NEWSV(65,80);
sv_upgrade(linestr,SVt_PVIV);
! if (!SvREADONLY(&sv_undef)) {
! SvREADONLY_on(&sv_undef);
! sv_setpv(&sv_no,No);
! SvNV(&sv_no);
! SvREADONLY_on(&sv_no);
!
! sv_setpv(&sv_yes,Yes);
! SvNV(&sv_yes);
! SvREADONLY_on(&sv_yes);
! }
nrs = newSVpv("\n", 1);
rs = SvREFCNT_inc(nrs);
***************
*** 126,132 ****
#endif
#if defined(LOCAL_PATCH_COUNT)
! Ilocalpatches = local_patches; /* For possible -v */
#endif
fdpid = newAV(); /* for remembering popen pids by fd */
--- 129,135 ----
#endif
#if defined(LOCAL_PATCH_COUNT)
! localpatches = local_patches; /* For possible -v */
#endif
fdpid = newAV(); /* for remembering popen pids by fd */
***************
*** 159,171 ****
LEAVE;
FREETMPS;
! if (sv_objcount) {
! /* We must account for everything. First the syntax tree. */
! if (main_root) {
! curpad = AvARRAY(comppad);
! op_free(main_root);
! main_root = 0;
! }
}
if (sv_objcount) {
/*
--- 162,172 ----
LEAVE;
FREETMPS;
! /* We must account for everything. First the syntax tree. */
! if (main_root) {
! curpad = AvARRAY(comppad);
! op_free(main_root);
! main_root = 0;
}
if (sv_objcount) {
/*
***************
*** 205,218 ****
--- 206,260 ----
/* Now absolutely destruct everything, somehow or other, loops or no. */
last_sv_count = 0;
+ SvFLAGS(strtab) |= SVTYPEMASK; /* don't clean out strtab now */
while (sv_count != 0 && sv_count != last_sv_count) {
last_sv_count = sv_count;
sv_clean_all();
}
+ SvFLAGS(strtab) &= ~SVTYPEMASK;
+ SvFLAGS(strtab) |= SVt_PVHV;
+
+ /* Destruct the global string table. */
+ {
+ /* Yell and reset the HeVAL() slots that are still holding refcounts,
+ * so that sv_free() won't fail on them.
+ */
+ I32 riter;
+ I32 max;
+ HE *hent;
+ HE **array;
+
+ riter = 0;
+ max = HvMAX(strtab);
+ array = HvARRAY(strtab);
+ hent = array[0];
+ for (;;) {
+ if (hent) {
+ warn("Unbalanced string table refcount: (%d) for \"%s\"",
+ HeVAL(hent) - Nullsv, HeKEY(hent));
+ HeVAL(hent) = Nullsv;
+ hent = HeNEXT(hent);
+ }
+ if (!hent) {
+ if (++riter > max)
+ break;
+ hent = array[riter];
+ }
+ }
+ }
+ SvREFCNT_dec(strtab);
+
if (sv_count != 0)
warn("Scalars leaked: %d\n", sv_count);
+
sv_free_arenas();
+ linestr = NULL; /* No SVs have survived, need to clean out */
+ if (origfilename)
+ Safefree(origfilename);
+ nuke_stacks();
+ hints = 0; /* Reset hints. Should hints be per-interpreter ? */
+
DEBUG_P(debprofdump());
}
***************
*** 254,259 ****
--- 296,306 ----
if (!(curinterp = sv_interp))
return 255;
+ #if defined(NeXT) && defined(__DYNAMIC__)
+ _dyld_lookup_and_bind
+ ("__environ", (unsigned long *) &environ_pointer, NULL);
+ #endif /* environ */
+
origargv = argv;
origargc = argc;
#ifndef VMS /* VMS doesn't have environ array */
***************
*** 381,387 ****
preambleav = newAV();
av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
if (*++s != ':') {
! Sv = newSVpv("print myconfig(),'@INC: '.\"@INC\\n\"",0);
}
else {
Sv = newSVpv("config_vars(qw(",0);
--- 428,476 ----
preambleav = newAV();
av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
if (*++s != ':') {
! Sv = newSVpv("print myconfig();",0);
! #ifdef VMS
! sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
! #else
! sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
! #endif
! #if defined(DEBUGGING) || defined(NOEMBED) || defined(MULTIPLICITY)
! strcpy(buf,"\" Compile-time options:");
! # ifdef DEBUGGING
! strcat(buf," DEBUGGING");
! # endif
! # ifdef NOEMBED
! strcat(buf," NOEMBED");
! # endif
! # ifdef MULTIPLICITY
! strcat(buf," MULTIPLICITY");
! # endif
! strcat(buf,"\\n\",");
! sv_catpv(Sv,buf);
! #endif
! #if defined(LOCAL_PATCH_COUNT)
! if (LOCAL_PATCH_COUNT > 0)
! { int i;
! sv_catpv(Sv,"print \" Locally applied patches:\\n\",");
! for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
! if (localpatches[i]) {
! sprintf(buf,"\" \\t%s\\n\",",localpatches[i]);
! sv_catpv(Sv,buf);
! }
! }
! }
! #endif
! sprintf(buf,"\" Built under %s\\n\",",OSNAME);
! sv_catpv(Sv,buf);
! #ifdef __DATE__
! # ifdef __TIME__
! sprintf(buf,"\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
! # else
! sprintf(buf,"\" Compiled on %s\\n\"",__DATE__);
! # endif
! sv_catpv(Sv,buf);
! #endif
! sv_catpv(Sv,"; $\"=\"\\n \"; print \" \\@INC:\\n @INC\\n\"");
}
else {
Sv = newSVpv("config_vars(qw(",0);
***************
*** 437,448 ****
compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)compcv, SVt_PVCV);
! pad = newAV();
! comppad = pad;
av_push(comppad, Nullsv);
curpad = AvARRAY(comppad);
! padname = newAV();
! comppad_name = padname;
comppad_name_fill = 0;
min_intro_pending = 0;
padix = 0;
--- 526,535 ----
compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)compcv, SVt_PVCV);
! comppad = newAV();
av_push(comppad, Nullsv);
curpad = AvARRAY(comppad);
! comppad_name = newAV();
comppad_name_fill = 0;
min_intro_pending = 0;
padix = 0;
***************
*** 453,458 ****
--- 540,546 ----
av_store(comppadlist, 1, (SV*)comppad);
CvPADLIST(compcv) = comppadlist;
+ boot_core_UNIVERSAL();
if (xsinit)
(*xsinit)(); /* in case linked C routines want magical variables */
#ifdef VMS
***************
*** 535,550 ****
FREETMPS;
return 1;
}
! if (stack != mainstack) {
dSP;
! SWITCHSTACK(stack, mainstack);
}
break;
}
if (!restartop) {
DEBUG_x(dump_all());
! DEBUG(fprintf(stderr,"\nEXECUTING...\n\n"));
if (minus_c) {
fprintf(stderr,"%s syntax OK\n", origfilename);
--- 623,641 ----
FREETMPS;
return 1;
}
! if (curstack != mainstack) {
dSP;
! SWITCHSTACK(curstack, mainstack);
}
break;
}
+ DEBUG_r(fprintf(stderr, "%s $` $& $' support.\n",
+ sawampersand ? "Enabling" : "Omitting"));
+
if (!restartop) {
DEBUG_x(dump_all());
! DEBUG(fprintf(Perl_debug_log,"\nEXECUTING...\n\n"));
if (minus_c) {
fprintf(stderr,"%s syntax OK\n", origfilename);
***************
*** 697,702 ****
--- 788,794 ----
I32 retval;
Sigjmp_buf oldtop;
I32 oldscope;
+ static CV *DBcv;
if (flags & G_DISCARD) {
ENTER;
***************
*** 717,722 ****
--- 809,818 ----
if (flags & G_ARRAY)
myop.op_flags |= OPf_LIST;
+ if (perldb && curstash != debstash
+ && (DBcv || (DBcv = GvCV(DBsub)))) /* to handle first BEGIN of -d */
+ op->op_private |= OPpENTERSUB_DB;
+
if (flags & G_EVAL) {
Copy(top_env, oldtop, 1, Sigjmp_buf);
***************
*** 814,820 ****
return retval;
}
! /* Eval a string. */
I32
perl_eval_sv(sv, flags)
--- 910,916 ----
return retval;
}
! /* Eval a string. The G_EVAL flag is always assumed. */
I32
perl_eval_sv(sv, flags)
***************
*** 843,851 ****
if (!(flags & G_NOARGS))
myop.op_flags = OPf_STACKED;
myop.op_next = Nullop;
myop.op_flags |= OPf_KNOW;
if (flags & G_ARRAY)
! myop.op_flags |= OPf_LIST;
Copy(top_env, oldtop, 1, Sigjmp_buf);
--- 939,950 ----
if (!(flags & G_NOARGS))
myop.op_flags = OPf_STACKED;
myop.op_next = Nullop;
+ myop.op_type = OP_ENTEREVAL;
myop.op_flags |= OPf_KNOW;
+ if (flags & G_KEEPERR)
+ myop.op_flags |= OPf_SPECIAL;
if (flags & G_ARRAY)
! myop.op_flags |= OPf_LIST;
Copy(top_env, oldtop, 1, Sigjmp_buf);
***************
*** 890,896 ****
if (op)
runops();
retval = stack_sp - (stack_base + oldmark);
! if ((flags & G_EVAL) && !(flags & G_KEEPERR))
sv_setpv(GvSV(errgv),"");
cleanup:
--- 989,995 ----
if (op)
runops();
retval = stack_sp - (stack_base + oldmark);
! if (!(flags & G_KEEPERR))
sv_setpv(GvSV(errgv),"");
cleanup:
***************
*** 987,995 ****
printf("\n -n assume 'while (<>) { ... }' loop arround your script");
printf("\n -p assume loop like -n but print line also like sed");
printf("\n -P run script through C preprocessor before compilation");
- #ifdef OS2
- printf("\n -R enable REXX variable pool");
- #endif
printf("\n -s enable some switch parsing for switches after script name");
printf("\n -S look for the script using PATH environment variable");
printf("\n -T turn on tainting checks");
--- 1086,1091 ----
***************
*** 1106,1116 ****
}
else {
if (RsPARA(nrs)) {
! ors = savepvn("\n\n", 2);
orslen = 2;
}
else
ors = SvPV(nrs, orslen);
}
return s;
case 'M':
--- 1202,1213 ----
}
else {
if (RsPARA(nrs)) {
! ors = "\n\n";
orslen = 2;
}
else
ors = SvPV(nrs, orslen);
+ ors = savepvn(ors, orslen);
}
return s;
case 'M':
***************
*** 1180,1225 ****
printf("\nThis is perl, version %s",patchlevel);
#endif
- #if defined(DEBUGGING) || defined(EMBED) || defined(MULTIPLICITY)
- fputs(" with", stdout);
- #ifdef DEBUGGING
- fputs(" DEBUGGING", stdout);
- #endif
- #ifdef EMBED
- fputs(" EMBED", stdout);
- #endif
- #ifdef MULTIPLICITY
- fputs(" MULTIPLICITY", stdout);
- #endif
- #endif
-
- #if defined(LOCAL_PATCH_COUNT)
- if (LOCAL_PATCH_COUNT > 0)
- { int i;
- fputs("\n\tLocally applied patches:\n", stdout);
- for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
- if (Ilocalpatches[i])
- fprintf(stdout, "\t %s\n", Ilocalpatches[i]);
- }
- }
- #endif
- printf("\n\tbuilt under %s",OSNAME);
- #ifdef __DATE__
- # ifdef __TIME__
- printf(" at %s %s",__DATE__,__TIME__);
- # else
- printf(" on %s",__DATE__);
- # endif
- #endif
- fputs("\n\t+ suidperl security patch", stdout);
fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
#ifdef MSDOS
fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
stdout);
#endif
#ifdef OS2
fputs("OS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
! "Version 5 port Copyright (c) 1994-1995, Andreas Kaiser\n", stdout);
#endif
#ifdef atarist
fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
--- 1277,1291 ----
printf("\nThis is perl, version %s",patchlevel);
#endif
fputs("\n\nCopyright 1987-1996, Larry Wall\n",stdout);
+ fputs("\n\t+ suidperl security patch", stdout);
#ifdef MSDOS
fputs("MS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n",
stdout);
#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);
#endif
#ifdef atarist
fputs("atariST series port, ++jrb bammi@cadence.com\n", stdout);
***************
*** 1287,1292 ****
--- 1353,1367 ----
init_main_stash()
{
GV *gv;
+
+ /* Note that strtab is a rather special HV. Assumptions are made
+ about not iterating on it, and not adding tie magic to it.
+ It is properly deallocated in perl_destruct() */
+ strtab = newHV();
+ HvSHAREKEYS_off(strtab); /* mandatory */
+ Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
+ sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
+
curstash = defstash = newHV();
curstname = newSVpv("main",4);
gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
***************
*** 1335,1344 ****
#endif
#ifdef VMS
! if (dosearch && !strpbrk(scriptname,":[</") && (my_getenv("DCL$PATH"))) {
! int idx = 0;
! while (my_trnlnm("DCL$PATH",tokenbuf,idx++)) {
strcat(tokenbuf,scriptname);
#else /* !VMS */
if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
--- 1410,1423 ----
#endif
#ifdef VMS
! if (dosearch) {
! int hasdir, idx = 0, deftypes = 1;
! hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
! /* The first time through, just add SEARCH_EXTS to whatever we
! * already have, so we can check for default file types. */
! while (deftypes || (!hasdir && my_trnlnm("DCL$PATH",tokenbuf,idx++)) ) {
! if (deftypes) { deftypes = 0; *tokenbuf = '\0'; }
strcat(tokenbuf,scriptname);
#else /* !VMS */
if (dosearch && !strchr(scriptname, '/') && (s = getenv("PATH"))) {
***************
*** 1377,1383 ****
extidx = 0;
do {
#endif
! DEBUG_p(fprintf(stderr,"Looking for %s\n",tokenbuf));
retval = Stat(tokenbuf,&statbuf);
#ifdef SEARCH_EXTS
} while ( retval < 0 /* not there */
--- 1456,1462 ----
extidx = 0;
do {
#endif
! DEBUG_p(fprintf(Perl_debug_log,"Looking for %s\n",tokenbuf));
retval = Stat(tokenbuf,&statbuf);
#ifdef SEARCH_EXTS
} while ( retval < 0 /* not there */
***************
*** 1544,1550 ****
*/
#ifdef DOSUID
! char *s;
if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
croak("Can't stat script \"%s\"",origfilename);
--- 1623,1629 ----
*/
#ifdef DOSUID
! char *s, *s2;
if (Fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
croak("Can't stat script \"%s\"",origfilename);
***************
*** 1627,1633 ****
s = tokenbuf+2;
if (*s == ' ') s++;
while (!isSPACE(*s)) s++;
! if (strnNE(s-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
croak("Not a perl script");
while (*s == ' ' || *s == '\t') s++;
/*
--- 1706,1714 ----
s = tokenbuf+2;
if (*s == ' ') s++;
while (!isSPACE(*s)) s++;
! for (s2 = s; (s2 > tokenbuf+2 &&
! (isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
! if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
croak("Not a perl script");
while (*s == ' ' || *s == '\t') s++;
/*
***************
*** 1725,1730 ****
--- 1806,1812 ----
/* 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 */
for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
if (!origargv[which])
croak("Permission denied");
***************
*** 1759,1765 ****
static void
find_beginning()
{
! register char *s;
/* skip forward in input to the real script? */
--- 1841,1847 ----
static void
find_beginning()
{
! register char *s, *s2;
/* skip forward in input to the real script? */
***************
*** 1767,1779 ****
while (doextract) {
if ((s = sv_gets(linestr, rsfp, 0)) == Nullch)
croak("No Perl script found in input\n");
! if (*s == '#' && s[1] == '!' && instr(s,"perl")) {
ungetc('\n',rsfp); /* to keep line count right */
doextract = FALSE;
! if (s = instr(s,"perl -")) {
! s += 6;
! /*SUPPRESS 530*/
! while (s = moreswitches(s)) ;
}
if (cddir && chdir(cddir) < 0)
croak("Can't chdir to %s",cddir);
--- 1849,1865 ----
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 */
doextract = FALSE;
! while (*s && !(isSPACE (*s) || *s == '#')) s++;
! s2 = s;
! while (*s == ' ' || *s == '\t') s++;
! if (*s++ == '-') {
! while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
! if (strnEQ(s2-4,"perl",4))
! /*SUPPRESS 530*/
! while (s = moreswitches(s)) ;
}
if (cddir && chdir(cddir) < 0)
croak("Can't chdir to %s",cddir);
***************
*** 1816,1845 ****
static void
init_stacks()
{
! stack = newAV();
! mainstack = stack; /* remember in case we switch stacks */
! AvREAL_off(stack); /* not a real array */
! av_extend(stack,127);
! stack_base = AvARRAY(stack);
stack_sp = stack_base;
stack_max = stack_base + 127;
! New(54,markstack,64,I32);
! markstack_ptr = markstack;
! markstack_max = markstack + 64;
!
! New(54,scopestack,32,I32);
! scopestack_ix = 0;
! scopestack_max = 32;
!
! New(54,savestack,128,ANY);
! savestack_ix = 0;
! savestack_max = 128;
!
! New(54,retstack,16,OP*);
! retstack_ix = 0;
! retstack_max = 16;
cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
New(50,cxstack,cxstack_max + 1,CONTEXT);
--- 1902,1948 ----
static void
init_stacks()
{
! curstack = newAV();
! 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? */
! if (markstack) {
! markstack_ptr = markstack;
! } else {
! New(54,markstack,64,I32);
! markstack_ptr = markstack;
! markstack_max = markstack + 64;
! }
!
! if (scopestack) {
! scopestack_ix = 0;
! } else {
! New(54,scopestack,32,I32);
! scopestack_ix = 0;
! scopestack_max = 32;
! }
!
! if (savestack) {
! savestack_ix = 0;
! } else {
! New(54,savestack,128,ANY);
! savestack_ix = 0;
! savestack_max = 128;
! }
!
! if (retstack) {
! retstack_ix = 0;
! } else {
! New(54,retstack,16,OP*);
! retstack_ix = 0;
! retstack_max = 16;
! }
cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
New(50,cxstack,cxstack_max + 1,CONTEXT);
***************
*** 1855,1860 ****
--- 1958,1970 ----
} )
}
+ static void
+ nuke_stacks()
+ {
+ Safefree(cxstack);
+ Safefree(tmps_stack);
+ }
+
static FILE *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
static void
init_lexer()
***************
*** 1898,1904 ****
statname = NEWSV(66,0); /* last filename we did stat on */
! osname = savepv(OSNAME);
}
static void
--- 2008,2015 ----
statname = NEWSV(66,0); /* last filename we did stat on */
! if (!osname)
! osname = savepv(OSNAME);
}
static void
#~ Update NeXT support
#~ Make HIDEMYMALLOC the default
#~ Add home-grown calloc() to MYMALLOC #defines
#~ Drop long long support under UTS
#~ Add new distinct GV type
#~ Add Plan9 support
#~ Use variable BIN_SH to find shell
#~ Allow redirection of output usually sent to stderr, so it can be
#~ handled separately from normal output
#~ Don't log memory allocations until we've got an interpreter set up
#~ Don't doubly define DEBUGGING_MSTATS
#~ Add globals and macros for improved signal handling, duplicate "my",
#~ strict untie, and debugger updates
#~ Rename some globals to avoid collisions with system headers
diff -Pcr perl5_003/perl.h perl5_003_01/perl.h
*** perl5_003/perl.h Mon Mar 25 01:05:06 1996
--- perl5_003_01/perl.h Sat Jul 27 09:42:41 1996
***************
*** 102,112 ****
#endif
#include <stdio.h>
#ifdef USE_NEXT_CTYPE
#include <appkit/NXCType.h>
! #else
#include <ctype.h>
! #endif
#ifdef I_LOCALE
#include <locale.h>
--- 102,119 ----
#endif
#include <stdio.h>
+
#ifdef USE_NEXT_CTYPE
+
+ #if NX_CURRENT_COMPILER_RELEASE >= 400
+ #include <objc/NXCType.h>
+ #else /* NX_CURRENT_COMPILER_RELEASE < 400 */
#include <appkit/NXCType.h>
! #endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */
!
! #else /* !USE_NEXT_CTYPE */
#include <ctype.h>
! #endif /* USE_NEXT_CTYPE */
#ifdef I_LOCALE
#include <locale.h>
***************
*** 136,149 ****
proto.h instead. I guess. The patch had no explanation.
*/
#ifdef MYMALLOC
! # ifdef HIDEMYMALLOC
# define malloc Mymalloc
# define realloc Myremalloc
# define free Myfree
# endif
# define safemalloc malloc
# define saferealloc realloc
# define safefree free
#endif
#define MEM_SIZE Size_t
--- 143,158 ----
proto.h instead. I guess. The patch had no explanation.
*/
#ifdef MYMALLOC
! # ifndef DONT_HIDEMYMALLOC
# define malloc Mymalloc
# define realloc Myremalloc
# define free Myfree
+ # define calloc Mycalloc
# endif
# define safemalloc malloc
# define saferealloc realloc
# define safefree free
+ # define safecalloc calloc
#endif
#define MEM_SIZE Size_t
***************
*** 493,499 ****
# define SLOPPYDIVIDE
#endif
! #if defined(cray) || defined(convex) || defined (uts) || BYTEORDER > 0xffff
# define HAS_QUAD
#endif
--- 502,508 ----
# define SLOPPYDIVIDE
#endif
! #if defined(cray) || defined(convex) || BYTEORDER > 0xffff
# define HAS_QUAD
#endif
***************
*** 505,511 ****
# ifdef cray
# define Quad_t int
# else
! # if defined(convex) || defined (uts)
# define Quad_t long long
# else
# define Quad_t long
--- 514,520 ----
# ifdef cray
# define Quad_t int
# else
! # if defined(convex)
# define Quad_t long long
# else
# define Quad_t long
***************
*** 542,548 ****
typedef struct cv CV;
typedef struct regexp REGEXP;
typedef struct gp GP;
! typedef struct sv GV;
typedef struct io IO;
typedef struct context CONTEXT;
typedef struct block BLOCK;
--- 551,557 ----
typedef struct cv CV;
typedef struct regexp REGEXP;
typedef struct gp GP;
! typedef struct gv GV;
typedef struct io IO;
typedef struct context CONTEXT;
typedef struct block BLOCK;
***************
*** 581,590 ****
# if defined(VMS)
# include "vmsish.h"
# else
! # include "unixish.h"
# endif
#endif
#ifndef HAS_PAUSE
#define pause() sleep((32767<<16)+32767)
#endif
--- 590,607 ----
# if defined(VMS)
# include "vmsish.h"
# else
! # if defined(PLAN9)
! # include "./plan9/plan9ish.h"
! # else
! # include "unixish.h"
! # 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)
#endif
***************
*** 730,735 ****
--- 747,755 ----
#endif
#ifdef DEBUGGING
+ #ifndef Perl_debug_log
+ #define Perl_debug_log stderr
+ #endif
#define YYDEBUG 1
#define DEB(a) a
#define DEBUG(a) if (debug) a
***************
*** 740,746 ****
#define DEBUG_o(a) if (debug & 16) a
#define DEBUG_c(a) if (debug & 32) a
#define DEBUG_P(a) if (debug & 64) a
! #define DEBUG_m(a) if (debug & 128) a
#define DEBUG_f(a) if (debug & 256) a
#define DEBUG_r(a) if (debug & 512) a
#define DEBUG_x(a) if (debug & 1024) a
--- 760,766 ----
#define DEBUG_o(a) if (debug & 16) a
#define DEBUG_c(a) if (debug & 32) a
#define DEBUG_P(a) if (debug & 64) a
! #define DEBUG_m(a) if (curinterp && debug & 128) a
#define DEBUG_f(a) if (debug & 256) a
#define DEBUG_r(a) if (debug & 512) a
#define DEBUG_x(a) if (debug & 1024) a
***************
*** 854,860 ****
# define register
# endif
# ifdef MYMALLOC
! # define DEBUGGING_MSTATS
# endif
# define PAD_SV(po) pad_sv(po)
#else
--- 874,882 ----
# define register
# endif
# ifdef MYMALLOC
! # ifndef DEBUGGING_MSTATS
! # define DEBUGGING_MSTATS
! # endif
# endif
# define PAD_SV(po) pad_sv(po)
#else
***************
*** 867,875 ****
/* global state */
EXT PerlInterpreter * curinterp; /* currently running interpreter */
! #ifndef VMS /* VMS doesn't use environ array */
extern char ** environ; /* environment variables supplied via exec */
! #endif
EXT int uid; /* current real user id */
EXT int euid; /* current effective user id */
EXT int gid; /* current real group id */
--- 889,906 ----
/* global state */
EXT PerlInterpreter * curinterp; /* currently running interpreter */
! /* VMS doesn't use environ array and NeXT has problems with crt0.o globals */
! #if !defined(VMS) && !(defined(NeXT) && defined(__DYNAMIC__))
extern char ** environ; /* environment variables supplied via exec */
! #else
! # if defined(NeXT) && defined(__DYNAMIC__)
!
! # include <mach-o/dyld.h>
! EXT char *** environ_pointer;
! # define environ (*environ_pointer)
! # endif
! #endif /* environ processing */
!
EXT int uid; /* current real user id */
EXT int euid; /* current effective user id */
EXT int gid; /* current real group id */
***************
*** 989,997 ****
--- 1020,1032 ----
#ifdef DOINIT
EXT char *sig_name[] = { SIG_NAME };
EXT int sig_num[] = { SIG_NUM };
+ EXT SV * psig_ptr[sizeof(sig_num)/sizeof(*sig_num)];
+ EXT SV * psig_name[sizeof(sig_num)/sizeof(*sig_num)];
#else
EXT char *sig_name[];
EXT int sig_num[];
+ EXT SV * psig_ptr[];
+ EXT SV * psig_name[];
#endif
#ifdef DOINIT
***************
*** 1148,1153 ****
--- 1183,1189 ----
EXT AV * comppad; /* storage for lexically scoped temporaries */
EXT AV * comppad_name; /* variable names for "my" variables */
EXT I32 comppad_name_fill;/* last "introduced" variable offset */
+ EXT I32 comppad_name_floor;/* start of vars in innermost block */
EXT I32 min_intro_pending;/* start of vars to introduce */
EXT I32 max_intro_pending;/* end of vars to introduce */
EXT I32 padix; /* max used index in current "register" pad */
***************
*** 1174,1179 ****
--- 1210,1216 ----
#define HINT_BLOCK_SCOPE 0x00000100
#define HINT_STRICT_SUBS 0x00000200
#define HINT_STRICT_VARS 0x00000400
+ #define HINT_STRICT_UNTIE 0x00000800
/**************************************************************************/
/* This regexp stuff is global since it always happens within 1 expr eval */
***************
*** 1313,1320 ****
IEXT SV * Icurstname; /* name of current package */
IEXT AV * Ibeginav; /* names of BEGIN subroutines */
IEXT AV * Iendav; /* names of END subroutines */
! IEXT AV * Ipad; /* storage for lexically scoped temporaries */
! IEXT AV * Ipadname; /* variable names for "my" variables */
/* memory management */
IEXT SV ** Itmps_stack;
--- 1350,1356 ----
IEXT SV * Icurstname; /* name of current package */
IEXT AV * Ibeginav; /* names of BEGIN subroutines */
IEXT AV * Iendav; /* names of END subroutines */
! IEXT HV * Istrtab; /* shared string table */
/* memory management */
IEXT SV ** Itmps_stack;
***************
*** 1360,1365 ****
--- 1396,1402 ----
/* runtime control stuff */
IEXT COP * VOL Icurcop IINIT(&compiling);
+ IEXT COP * Icurcopdb IINIT(NULL);
IEXT line_t Icopline IINIT(NOLINE);
IEXT CONTEXT * Icxstack;
IEXT I32 Icxstack_ix IINIT(-1);
***************
*** 1368,1374 ****
IEXT I32 Irunlevel;
/* stack stuff */
! IEXT AV * Istack; /* THE STACK */
IEXT AV * Imainstack; /* the stack when nothing funny is happening */
IEXT SV ** Imystack_base; /* stack->array_ary */
IEXT SV ** Imystack_sp; /* stack pointer now */
--- 1405,1411 ----
IEXT I32 Irunlevel;
/* stack stuff */
! IEXT AV * Icurstack; /* THE STACK */
IEXT AV * Imainstack; /* the stack when nothing funny is happening */
IEXT SV ** Imystack_base; /* stack->array_ary */
IEXT SV ** Imystack_sp; /* stack pointer now */
***************
*** 1458,1465 ****
0, magic_clearenv,
0};
EXT MGVTBL vtbl_sig = {0, 0, 0, 0, 0};
! EXT MGVTBL vtbl_sigelem = {0, magic_setsig,
! 0, 0, 0};
EXT MGVTBL vtbl_pack = {0, 0, 0, magic_wipepack,
0};
EXT MGVTBL vtbl_packelem = {magic_getpack,
--- 1495,1504 ----
0, magic_clearenv,
0};
EXT MGVTBL vtbl_sig = {0, 0, 0, 0, 0};
! EXT MGVTBL vtbl_sigelem = {magic_getsig,
! magic_setsig,
! 0, magic_clearsig,
! 0};
EXT MGVTBL vtbl_pack = {0, 0, 0, magic_wipepack,
0};
EXT MGVTBL vtbl_packelem = {magic_getpack,
#~ Remove old copy before generating new one
#~ Add symbol for home-grown calloc
diff -Pcr perl5_003/perl_exp.SH perl5_003_01/perl_exp.SH
*** perl5_003/perl_exp.SH Mon Mar 25 01:05:08 1996
--- perl5_003_01/perl_exp.SH Thu Jul 11 12:25:53 1996
***************
*** 14,19 ****
--- 14,20 ----
echo "Extracting perl.exp"
+ rm -f perl.exp
echo "#!" > perl.exp
sed -n '/^[A-Za-z]/ s/^/Perl_/p' global.sym >> perl.exp
***************
*** 42,47 ****
--- 43,49 ----
perl_call_method
perl_call_sv
perl_requirepv
+ safecalloc
safemalloc
saferealloc
safefree
#~ Update to reflect changes in perly.y
#~ Use safefree instead of Safefree to free memory allocated by safemalloc
#~ Allow redirection of debug messages
diff -Pcr perl5_003/perly.c perl5_003_01/perly.c
*** perl5_003/perly.c Wed Feb 28 17:38:38 1996
--- perl5_003_01/perly.c Sun Jul 7 10:04:15 1996
***************
*** 37,43 ****
6, 6, 4, 4, 0, 2, 7, 7, 5, 5,
8, 7, 10, 3, 0, 1, 0, 1, 0, 1,
1, 1, 1, 1, 4, 3, 5, 5, 0, 1,
! 0, 3, 2, 5, 3, 3, 1, 2, 3, 1,
3, 5, 6, 3, 5, 2, 4, 4, 1, 1,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 5, 3, 2, 2, 2, 2, 2, 2,
--- 37,43 ----
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,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 5, 3, 2, 2, 2, 2, 2, 2,
***************
*** 75,89 ****
55, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 69, 0, 70,
0, 0, 0, 0, 0, 0, 0, 120, 0, 48,
! 47, 54, 3, 0, 141, 0, 68, 101, 0, 29,
0, 30, 0, 0, 0, 23, 0, 24, 0, 0,
0, 140, 149, 67, 0, 125, 0, 127, 0, 99,
0, 0, 0, 0, 0, 0, 0, 107, 0, 105,
! 0, 116, 0, 121, 65, 0, 0, 0, 0, 19,
! 0, 0, 0, 0, 0, 62, 126, 128, 115, 0,
! 113, 0, 0, 106, 0, 111, 117, 103, 142, 27,
! 28, 21, 0, 22, 0, 32, 0, 114, 112, 63,
! 0, 0, 31, 0, 0, 20, 33,
};
short yydgoto[] = { 1,
9, 10, 83, 17, 86, 3, 11, 12, 66, 195,
--- 75,89 ----
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,
};
short yydgoto[] = { 1,
9, 10, 83, 17, 86, 3, 11, 12, 66, 195,
***************
*** 92,1104 ****
2, 14, 15, 16,
};
short yysindex[] = { 0,
! 0, 0, -82, 0, 0, 0, -52, 0, 0, 0,
! 0, 0, 853, 0, 0, 0, -80, -256, -19, 0,
! -245, 0, 0, 0, 19, 19, 0, 20, 0, 2177,
! 0, 0, -2, 1, 28, 41, 133, 2177, 27, 33,
! 52, 19, 1028, 2177, 1303, -210, 19, 2177, 965, 1359,
! 2177, 2177, 2177, 2177, 2177, 1415, 0, 2177, 2177, 1478,
! 19, 19, 19, 19, -225, 0, 71, 209, 1535, -49,
! -30, 0, 0, 8, 101, 42, 0, 30, 0, -112,
! 0, 2177, 0, 0, 0, 0, 0, 2177, 127, 2177,
! 1535, 30, -112, 2177, 30, 2177, 30, 2177, 30, 2177,
! 30, 1712, 128, 1535, 139, 1768, 965, 0, 141, 0,
! 1485, -14, 1485, 65, -42, 2177, 0, 71, 0, 71,
! -49, 0, 2177, 0, 1485, 334, 334, 334, -47, -47,
! 92, -26, 334, 334, 0, 63, 0, 0, 0, 0,
! 30, 0, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
! 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
! 2177, 2177, 2177, 2177, 0, 0, -27, 2177, 2177, 2177,
! 2177, 2177, 2177, 1824, 0, 0, 0, -48, 137, -92,
! 0, 2177, 221, 2177, 30, -191, 151, -225, -22, -225,
! -12, -147, 7, -147, 138, 5, 0, 2177, 0, 0,
! 9, -39, 160, 2177, 1887, 2121, 0, 77, 0, 71,
! 2177, 113, 0, 0, 1535, -191, -191, -191, -191, -86,
! 0, -20, 395, 1485, 1566, 461, -88, 1535, 4122, 1064,
! 679, 364, 1120, 728, 334, 334, 2177, 0, 2177, 0,
! 174, 89, 51, 98, 55, 118, 57, 0, 11, 0,
! 0, 0, 0, 175, 0, 2177, 0, 0, 30, 0,
! 30, 0, 30, 30, 178, 0, 30, 0, 2177, 30,
! 15, 0, 0, 0, 22, 0, 25, 0, 29, 0,
! 152, 2177, 94, 2177, 59, 177, 2177, 0, 96, 0,
! 97, 0, 102, 0, 0, 1190, -225, -225, -147, 0,
! 2177, -147, 176, -225, 30, 0, 0, 0, 0, 205,
! 0, 3039, 111, 0, 206, 0, 0, 0, 0, 0,
! 0, 0, 37, 0, 1712, 0, -225, 0, 0, 0,
! 30, 208, 0, -147, 30, 0, 0,
};
short yyrindex[] = { 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,
! 0, 0, 0, 0, 0, 0, 0, 2253, 505, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 2847, 2935,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 107, 0, -35, 10, 53, 3109,
! 3156, 0, 0, 2298, 1976, 0, 0, 0, 0, -23,
! 0, 230, 0, 0, 0, 0, 0, 2385, 0, 0,
! 1004, 0, 168, 253, 0, 0, 0, 0, 0, 0,
! 0, 254, 0, 2242, 0, 0, 274, 0, 2032, 0,
! 3844, 3109, 3902, 0, 0, 2385, 0, 2440, 452, 2554,
! 572, 0, 0, 0, 3981, 3274, 3312, 3421, 3200, 3237,
! 2661, 0, 3560, 3596, 0, 0, 0, 0, 0, 0,
! 0, 0, 2714, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 909,
! 0, 274, 0, 2385, 0, 39, 0, 107, 0, 107,
! 0, 170, 0, 170, 0, 262, 0, 0, 0, 0,
! 0, 288, 0, 0, 0, 0, 0, 0, 0, 2805,
! 0, 2757, 0, 0, 2650, 49, 58, 61, 64, 365,
! 0, 0, -31, 4018, 4028, 3719, 630, 2995, 0, 1623,
! 4106, 4096, 4064, 3756, 3640, 3683, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 277, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 274, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 107, 107, 170, 0,
! 0, 170, 0, 107, 0, 0, 0, 0, 0, 0,
! 0, 13, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 300, 0, 107, 0, 0, 0,
! 0, 0, 0, 170, 0, 0, 0,
};
short yygindex[] = { 0,
! 0, 0, 0, 506, -13, 255, 0, 0, 0, 18,
! -180, 839, -11, 4398, 2162, 0, 0, 0, 0, 0,
! 342, -57, -174, 1032, 90, 0, 0, 267, 0, -172,
0, 0, 0, 0,
};
! #define YYTABLESIZE 4682
short yytable[] = { 65,
! 80, 68, 168, 79, 273, 57, 20, 254, 61, 80,
! 250, 82, 80, 268, 212, 260, 208, 262, 261, 95,
! 97, 99, 101, 57, 179, 206, 80, 80, 263, 110,
! 181, 80, 253, 115, 150, 49, 124, 94, 283, 81,
! 96, 170, 23, 168, 132, 270, 116, 267, 136, 272,
! 13, 294, 141, 83, 61, 305, 83, 57, 209, 90,
! 172, 80, 306, 239, 176, 307, 105, 98, 13, 308,
! 83, 83, 106, 169, 23, 150, 170, 331, 184, 38,
! 100, 188, 186, 190, 189, 192, 191, 194, 193, 16,
! 196, 107, 171, 60, 201, 237, 60, 38, 17, 49,
! 175, 14, 148, 149, 15, 83, 25, 16, 169, 289,
! 60, 60, 315, 291, 143, 293, 17, 313, 322, 14,
! 23, 324, 15, 23, 320, 321, 257, 214, 264, 265,
! 173, 326, 216, 217, 218, 219, 220, 221, 222, 25,
! 174, 23, 25, 25, 25, 60, 25, 177, 25, 25,
! 23, 25, 23, 336, 333, 213, 242, 243, 244, 245,
! 246, 247, 249, 23, 251, 25, 182, 198, 61, 18,
! 25, 258, 102, 4, 5, 6, 78, 7, 8, 199,
! 205, 288, 211, 4, 5, 6, 271, 7, 8, 207,
! 290, 259, 275, 277, 279, 252, 269, 25, 154, 281,
! 274, 280, 18, 282, 19, 18, 18, 18, 149, 18,
! 292, 18, 18, 287, 18, 295, 163, 301, 311, 164,
! 316, 317, 165, 166, 167, 285, 318, 286, 18, 25,
! 238, 25, 25, 18, 325, 329, 57, 57, 57, 57,
! 80, 80, 80, 80, 309, 297, 330, 298, 335, 299,
! 300, 148, 149, 302, 148, 149, 304, 186, 57, 57,
! 18, 255, 80, 80, 256, 167, 80, 148, 149, 314,
! 310, 148, 149, 148, 149, 84, 144, 145, 146, 147,
! 85, 148, 149, 157, 83, 83, 83, 83, 145, 323,
! 49, 327, 18, 37, 18, 18, 2, 328, 148, 149,
! 148, 149, 148, 149, 148, 149, 83, 83, 148, 149,
! 83, 168, 35, 68, 147, 148, 149, 334, 148, 149,
! 13, 337, 148, 149, 60, 60, 60, 60, 148, 39,
! 148, 149, 39, 39, 39, 37, 39, 180, 39, 39,
! 35, 39, 332, 150, 148, 149, 60, 60, 148, 149,
! 148, 149, 148, 149, 76, 39, 148, 149, 303, 185,
! 39, 0, 25, 25, 25, 25, 25, 25, 0, 25,
25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
! 25, 25, 148, 149, 0, 25, 25, 39, 25, 25,
! 25, 148, 149, 0, 0, 25, 25, 25, 25, 25,
! 0, 0, 25, 25, 0, 56, 0, 0, 56, 25,
! 0, 148, 149, 25, 0, 25, 25, 0, 0, 39,
! 0, 0, 39, 56, 168, 18, 18, 18, 18, 18,
! 18, 0, 18, 18, 18, 18, 18, 18, 18, 18,
! 18, 18, 18, 18, 18, 148, 149, 0, 18, 18,
! 0, 18, 18, 18, 168, 0, 150, 56, 18, 18,
! 18, 18, 18, 0, 0, 18, 18, 0, 0, 0,
! 148, 149, 18, 0, 0, 0, 18, 0, 18, 18,
! 144, 145, 146, 147, 156, 168, 150, 156, 156, 156,
! 0, 156, 143, 156, 156, 143, 156, 0, 148, 149,
! 0, 151, 148, 149, 0, 152, 153, 154, 155, 143,
! 143, 18, 0, 21, 143, 156, 0, 150, 156, 158,
! 159, 160, 161, 0, 162, 163, 0, 0, 164, 0,
! 0, 165, 166, 167, 0, 0, 92, 93, 0, 0,
! 0, 0, 143, 0, 143, 136, 0, 0, 136, 0,
! 0, 168, 39, 39, 39, 39, 39, 39, 0, 39,
! 39, 39, 136, 136, 0, 39, 0, 136, 39, 39,
! 39, 39, 0, 0, 143, 39, 39, 156, 39, 39,
! 39, 0, 0, 150, 0, 39, 39, 39, 39, 39,
! 0, 0, 39, 39, 0, 136, 0, 136, 0, 39,
! 0, 0, 0, 39, 157, 39, 39, 157, 157, 157,
! 0, 157, 102, 157, 157, 102, 157, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 136, 0, 102,
! 102, 0, 0, 0, 102, 157, 56, 56, 56, 56,
! 0, 164, 0, 0, 165, 166, 167, 0, 152, 153,
! 154, 155, 0, 0, 0, 0, 0, 0, 56, 0,
! 0, 0, 0, 0, 102, 161, 0, 162, 163, 0,
! 74, 164, 0, 74, 165, 166, 167, 0, 0, 152,
! 153, 154, 155, 0, 0, 0, 0, 74, 74, 0,
! 0, 0, 74, 158, 159, 160, 161, 157, 162, 163,
! 0, 0, 164, 0, 0, 165, 166, 167, 156, 156,
! 156, 156, 156, 0, 156, 156, 156, 0, 0, 0,
! 156, 0, 74, 143, 143, 143, 143, 0, 0, 0,
! 0, 156, 143, 156, 156, 156, 143, 143, 143, 143,
! 156, 156, 156, 156, 156, 143, 143, 156, 156, 143,
! 143, 143, 143, 143, 156, 143, 143, 0, 156, 143,
! 156, 156, 143, 143, 143, 163, 0, 0, 164, 168,
! 0, 165, 166, 167, 0, 0, 136, 136, 136, 136,
! 0, 0, 0, 0, 0, 136, 0, 0, 0, 136,
! 136, 136, 136, 0, 0, 0, 0, 0, 136, 136,
! 0, 150, 136, 136, 136, 136, 136, 0, 136, 136,
! 0, 0, 136, 0, 0, 136, 136, 136, 168, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 157, 157,
! 157, 157, 157, 0, 157, 157, 157, 0, 0, 0,
! 157, 0, 0, 102, 102, 102, 102, 0, 0, 0,
! 150, 157, 102, 157, 157, 157, 102, 102, 102, 102,
! 157, 157, 157, 157, 157, 102, 102, 157, 157, 102,
! 102, 102, 102, 102, 157, 102, 102, 0, 157, 102,
! 157, 157, 102, 102, 102, 51, 118, 120, 61, 63,
! 47, 0, 56, 0, 64, 59, 0, 58, 0, 0,
! 0, 74, 74, 74, 74, 0, 0, 0, 0, 0,
! 74, 57, 0, 0, 74, 74, 62, 74, 0, 0,
! 120, 0, 0, 74, 74, 0, 120, 74, 74, 74,
! 74, 74, 0, 74, 0, 0, 0, 0, 0, 0,
! 0, 39, 0, 60, 39, 39, 39, 0, 39, 0,
! 39, 39, 0, 39, 120, 0, 0, 0, 0, 0,
! 0, 210, 0, 152, 153, 154, 155, 39, 0, 0,
! 0, 0, 39, 0, 0, 23, 0, 0, 52, 160,
! 161, 0, 162, 163, 0, 0, 164, 0, 0, 165,
! 166, 167, 0, 0, 0, 0, 0, 51, 0, 39,
! 61, 63, 47, 0, 56, 0, 64, 59, 0, 58,
! 0, 0, 0, 0, 154, 155, 0, 0, 0, 0,
! 0, 0, 120, 0, 0, 0, 0, 0, 62, 0,
! 0, 39, 163, 0, 39, 164, 0, 0, 165, 166,
! 167, 0, 0, 0, 135, 0, 0, 135, 0, 0,
! 0, 0, 0, 0, 0, 60, 0, 89, 0, 0,
! 51, 135, 135, 61, 63, 47, 0, 56, 0, 64,
! 59, 0, 58, 108, 0, 0, 0, 0, 117, 0,
! 123, 0, 0, 0, 0, 0, 0, 23, 0, 0,
! 52, 62, 137, 138, 139, 140, 135, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 22, 24,
! 25, 26, 27, 28, 0, 29, 30, 31, 60, 0,
! 0, 32, 0, 0, 33, 34, 35, 36, 0, 0,
! 0, 37, 38, 0, 39, 40, 41, 0, 204, 0,
! 0, 42, 43, 44, 45, 46, 0, 0, 48, 49,
! 23, 0, 0, 52, 168, 50, 0, 0, 0, 53,
! 0, 54, 55, 0, 39, 39, 39, 39, 39, 39,
! 0, 39, 39, 39, 0, 0, 0, 39, 0, 0,
! 39, 39, 39, 39, 0, 0, 150, 39, 39, 0,
! 39, 39, 39, 0, 0, 0, 0, 39, 39, 39,
! 39, 39, 0, 0, 39, 39, 0, 0, 0, 0,
! 168, 39, 0, 0, 0, 39, 0, 39, 39, 0,
! 0, 119, 25, 26, 27, 28, 85, 29, 30, 31,
! 319, 0, 0, 32, 0, 0, 0, 0, 0, 0,
! 0, 0, 150, 0, 38, 0, 39, 40, 41, 0,
! 0, 0, 157, 42, 43, 44, 45, 46, 0, 0,
! 48, 49, 0, 0, 0, 0, 0, 50, 0, 0,
! 0, 53, 0, 54, 55, 135, 135, 135, 135, 0,
! 168, 0, 0, 0, 109, 25, 26, 27, 28, 0,
! 29, 30, 31, 0, 0, 0, 32, 135, 135, 0,
! 0, 0, 0, 0, 0, 0, 0, 38, 0, 39,
! 40, 41, 150, 0, 0, 0, 42, 43, 44, 45,
! 46, 0, 0, 48, 49, 0, 0, 0, 0, 0,
! 50, 0, 0, 0, 53, 51, 54, 55, 61, 63,
! 47, 0, 56, 0, 64, 59, 0, 58, 152, 153,
! 154, 155, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 114, 0, 159, 160, 161, 62, 162, 163, 0,
0, 164, 0, 0, 165, 166, 167, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 51, 0, 60, 61, 63, 47, 0, 56, 0,
! 64, 59, 0, 58, 152, 153, 154, 155, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 62, 162, 163, 0, 0, 164, 52, 0,
! 165, 166, 167, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 51, 0, 60,
! 61, 63, 47, 0, 56, 131, 64, 59, 0, 58,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 151, 0, 0, 0, 152, 153, 154, 155, 62, 0,
! 0, 23, 0, 0, 52, 0, 0, 156, 158, 159,
! 160, 161, 0, 162, 163, 0, 0, 164, 0, 0,
! 165, 166, 167, 0, 0, 60, 0, 0, 0, 0,
! 51, 0, 0, 61, 63, 47, 0, 56, 0, 64,
! 59, 0, 58, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 52, 62, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 24,
! 25, 26, 27, 28, 0, 29, 30, 31, 60, 0,
! 135, 32, 0, 0, 0, 168, 0, 0, 0, 0,
! 0, 0, 38, 0, 39, 40, 41, 0, 0, 0,
! 0, 42, 43, 44, 45, 46, 0, 157, 48, 49,
! 0, 0, 0, 52, 0, 50, 0, 150, 0, 53,
! 0, 54, 55, 0, 0, 24, 25, 26, 27, 28,
! 0, 29, 30, 31, 0, 168, 0, 32, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 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, 0, 0, 82, 0, 50, 0, 0,
! 0, 53, 0, 54, 55, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 24, 25, 26, 27, 28, 0,
! 29, 30, 31, 0, 51, 0, 32, 61, 63, 47,
! 0, 56, 0, 64, 59, 0, 58, 38, 0, 39,
! 40, 41, 0, 0, 0, 0, 42, 43, 44, 45,
! 46, 154, 155, 48, 49, 62, 0, 0, 0, 0,
! 50, 0, 0, 0, 53, 0, 54, 55, 162, 163,
! 0, 0, 164, 0, 0, 165, 166, 167, 0, 0,
! 51, 0, 60, 61, 63, 47, 0, 56, 200, 64,
! 59, 0, 58, 0, 0, 151, 0, 0, 0, 152,
! 153, 154, 155, 0, 0, 0, 0, 0, 0, 0,
! 0, 62, 156, 158, 159, 160, 161, 52, 162, 163,
! 0, 0, 164, 0, 0, 165, 166, 167, 0, 0,
! 152, 0, 154, 155, 0, 0, 51, 0, 60, 61,
! 63, 47, 0, 56, 248, 64, 59, 0, 58, 162,
! 163, 0, 0, 164, 0, 0, 165, 166, 167, 0,
! 0, 0, 0, 0, 0, 0, 0, 62, 0, 0,
! 0, 0, 0, 52, 82, 82, 82, 82, 0, 0,
! 0, 0, 0, 82, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 60, 0, 82, 82, 0, 51,
! 82, 82, 61, 63, 47, 0, 56, 276, 64, 59,
! 0, 58, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 52,
! 62, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 22, 24, 25,
! 26, 27, 28, 0, 29, 30, 31, 60, 0, 0,
! 32, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 38, 0, 39, 40, 41, 0, 0, 0, 0,
! 42, 43, 44, 45, 46, 0, 0, 48, 49, 0,
! 0, 0, 52, 0, 50, 0, 119, 0, 53, 119,
! 54, 55, 0, 0, 24, 25, 26, 27, 28, 0,
! 29, 30, 31, 119, 119, 0, 32, 0, 119, 0,
! 0, 0, 0, 0, 0, 0, 0, 38, 0, 39,
40, 41, 0, 0, 0, 0, 42, 43, 44, 45,
! 46, 0, 0, 48, 49, 0, 119, 0, 119, 0,
! 50, 0, 143, 0, 53, 143, 54, 55, 0, 0,
! 24, 25, 26, 27, 28, 0, 29, 30, 31, 143,
! 143, 0, 32, 0, 143, 0, 0, 0, 119, 0,
0, 0, 0, 38, 0, 39, 40, 41, 0, 0,
0, 0, 42, 43, 44, 45, 46, 0, 0, 48,
! 49, 0, 143, 0, 143, 0, 50, 0, 0, 0,
! 53, 0, 54, 55, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 24, 25, 26, 27, 28, 0, 29,
! 30, 31, 0, 51, 143, 32, 61, 63, 47, 0,
! 56, 278, 64, 59, 0, 58, 38, 0, 39, 40,
! 41, 0, 0, 0, 0, 42, 43, 44, 45, 46,
! 0, 0, 48, 49, 62, 0, 87, 87, 0, 50,
! 0, 0, 0, 53, 0, 54, 55, 0, 103, 0,
! 0, 0, 0, 87, 112, 0, 0, 0, 87, 51,
! 121, 60, 61, 63, 47, 0, 56, 0, 64, 59,
! 0, 58, 87, 87, 87, 87, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 62, 0, 0, 0, 0, 0, 52, 119, 119, 119,
! 119, 0, 0, 0, 0, 0, 119, 0, 0, 0,
! 119, 119, 119, 119, 0, 0, 0, 60, 121, 119,
! 119, 0, 0, 119, 119, 119, 119, 119, 0, 119,
! 119, 0, 130, 119, 0, 130, 119, 119, 119, 0,
! 0, 0, 0, 129, 0, 0, 129, 0, 0, 130,
! 130, 0, 52, 143, 143, 143, 143, 0, 0, 0,
! 129, 129, 143, 0, 0, 129, 143, 143, 143, 143,
! 0, 0, 0, 0, 0, 143, 143, 0, 240, 143,
! 143, 143, 143, 143, 130, 143, 143, 0, 104, 143,
! 0, 104, 143, 143, 143, 129, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 104, 104, 0, 0, 0,
! 104, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 129, 0, 24, 25, 26,
! 27, 28, 0, 29, 30, 31, 0, 0, 104, 32,
! 104, 0, 0, 0, 0, 0, 0, 0, 0, 0,
38, 0, 39, 40, 41, 0, 0, 0, 0, 42,
43, 44, 45, 46, 0, 0, 48, 49, 0, 0,
! 0, 0, 0, 50, 0, 145, 0, 53, 145, 54,
55, 0, 0, 24, 25, 26, 27, 28, 0, 29,
! 30, 31, 145, 145, 0, 32, 0, 145, 0, 0,
0, 0, 0, 0, 0, 0, 38, 0, 39, 40,
41, 0, 0, 0, 0, 42, 43, 44, 45, 46,
! 0, 0, 48, 49, 0, 0, 0, 145, 0, 50,
! 131, 0, 0, 53, 0, 54, 55, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 131, 131, 0,
! 0, 0, 131, 0, 0, 0, 0, 145, 0, 0,
! 0, 0, 0, 130, 130, 130, 130, 0, 0, 0,
! 0, 0, 0, 0, 129, 129, 129, 129, 0, 0,
! 131, 0, 131, 129, 0, 130, 130, 129, 129, 129,
! 129, 0, 0, 0, 0, 0, 129, 129, 0, 0,
! 129, 129, 129, 129, 129, 0, 129, 129, 0, 0,
! 129, 0, 131, 129, 129, 129, 0, 0, 0, 104,
! 104, 104, 104, 0, 0, 0, 0, 0, 104, 0,
! 0, 0, 104, 104, 104, 104, 0, 0, 0, 0,
! 0, 104, 104, 0, 146, 104, 104, 104, 104, 104,
! 0, 104, 104, 0, 0, 104, 0, 0, 104, 104,
! 104, 146, 146, 0, 0, 0, 146, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 146, 0, 146, 0, 0, 0,
0, 0, 0, 0, 0, 0, 145, 145, 145, 145,
! 0, 0, 0, 0, 0, 145, 0, 0, 0, 145,
! 145, 145, 145, 0, 0, 0, 146, 0, 145, 145,
0, 0, 145, 145, 145, 145, 145, 0, 145, 145,
! 59, 0, 145, 59, 0, 145, 145, 145, 0, 0,
! 0, 96, 0, 0, 96, 0, 0, 59, 59, 0,
! 0, 131, 131, 131, 131, 0, 0, 0, 96, 96,
! 131, 0, 0, 96, 131, 131, 131, 131, 0, 0,
! 0, 0, 0, 131, 131, 0, 0, 131, 131, 131,
! 131, 131, 59, 131, 131, 0, 0, 131, 0, 0,
! 131, 131, 131, 96, 58, 0, 0, 58, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 58, 58, 0, 0, 0, 58, 0, 0, 0,
- 0, 0, 0, 96, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 95, 0, 0,
! 95, 0, 0, 0, 0, 0, 58, 0, 0, 0,
! 0, 0, 0, 0, 95, 95, 0, 0, 0, 95,
! 0, 0, 0, 0, 0, 146, 146, 146, 146, 0,
! 0, 0, 0, 0, 146, 0, 58, 0, 146, 146,
! 146, 146, 0, 0, 0, 61, 0, 146, 146, 95,
! 0, 146, 146, 146, 146, 146, 0, 146, 146, 0,
! 0, 146, 61, 61, 146, 146, 146, 61, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 95,
! 0, 0, 0, 0, 0, 0, 0, 145, 0, 0,
! 145, 0, 0, 0, 0, 61, 0, 61, 0, 0,
! 0, 0, 0, 0, 145, 145, 0, 0, 0, 145,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 59, 59, 59, 59, 0, 0, 61, 0, 0,
! 0, 0, 96, 96, 96, 96, 0, 0, 0, 145,
! 0, 96, 0, 59, 59, 96, 96, 96, 96, 0,
! 0, 0, 0, 0, 96, 96, 0, 0, 96, 96,
! 96, 96, 96, 0, 96, 96, 0, 0, 96, 0,
! 0, 96, 96, 96, 0, 132, 0, 0, 132, 0,
! 0, 0, 0, 0, 0, 58, 58, 58, 58, 0,
! 0, 0, 132, 132, 58, 0, 0, 132, 58, 58,
! 58, 58, 0, 0, 0, 0, 0, 58, 58, 0,
! 0, 58, 58, 58, 58, 58, 0, 58, 58, 0,
! 0, 58, 0, 0, 58, 58, 58, 132, 95, 95,
! 95, 95, 0, 0, 0, 71, 0, 95, 71, 0,
! 0, 95, 95, 95, 95, 0, 0, 0, 0, 0,
! 95, 95, 71, 71, 95, 95, 95, 95, 95, 0,
! 95, 95, 0, 0, 95, 0, 0, 95, 95, 95,
! 0, 0, 0, 0, 0, 0, 61, 61, 61, 61,
! 0, 0, 0, 0, 0, 61, 0, 71, 0, 61,
! 61, 61, 61, 0, 0, 0, 0, 0, 61, 61,
! 0, 157, 61, 61, 61, 61, 61, 0, 61, 61,
! 0, 0, 61, 0, 0, 61, 61, 61, 145, 145,
! 145, 145, 0, 0, 0, 0, 0, 145, 0, 168,
! 0, 145, 145, 145, 145, 0, 0, 0, 0, 0,
! 145, 145, 0, 0, 145, 145, 145, 145, 145, 102,
! 145, 145, 102, 0, 145, 0, 0, 145, 145, 145,
! 0, 150, 0, 0, 0, 0, 102, 102, 0, 0,
! 0, 102, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 109, 0, 0, 109,
! 0, 102, 0, 0, 0, 0, 132, 132, 132, 132,
! 0, 0, 0, 109, 109, 132, 0, 0, 109, 132,
! 132, 132, 132, 0, 0, 0, 0, 0, 132, 132,
! 0, 0, 132, 132, 132, 132, 132, 0, 132, 132,
! 92, 0, 132, 92, 0, 132, 132, 132, 109, 0,
! 0, 0, 0, 0, 0, 0, 0, 92, 92, 0,
! 0, 0, 92, 0, 0, 0, 71, 71, 71, 71,
! 0, 0, 0, 0, 0, 0, 0, 93, 0, 0,
! 93, 0, 0, 0, 0, 0, 0, 0, 71, 71,
! 0, 0, 92, 0, 93, 93, 0, 0, 0, 93,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 87, 0, 0, 87, 0, 151,
! 0, 0, 0, 152, 153, 154, 155, 0, 0, 93,
! 0, 87, 87, 0, 0, 0, 87, 158, 159, 160,
! 161, 0, 162, 163, 0, 0, 164, 0, 0, 165,
! 166, 167, 88, 0, 0, 88, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 87, 0, 0, 88,
! 88, 0, 0, 0, 88, 0, 0, 0, 0, 0,
! 102, 102, 102, 102, 0, 0, 0, 0, 0, 102,
! 0, 0, 0, 102, 102, 102, 102, 0, 0, 0,
! 0, 0, 102, 102, 88, 0, 102, 102, 102, 102,
! 102, 0, 102, 102, 0, 0, 102, 0, 0, 102,
! 102, 102, 0, 0, 0, 0, 0, 109, 109, 109,
! 109, 0, 0, 0, 0, 0, 109, 0, 0, 0,
! 109, 109, 109, 109, 0, 0, 0, 0, 0, 109,
! 109, 0, 0, 109, 109, 109, 109, 109, 0, 109,
! 109, 89, 0, 109, 89, 0, 109, 109, 109, 0,
! 0, 92, 92, 92, 92, 0, 0, 0, 89, 89,
! 92, 0, 0, 89, 92, 92, 92, 92, 0, 0,
! 0, 0, 0, 92, 92, 0, 0, 92, 92, 92,
! 92, 92, 0, 92, 92, 0, 0, 92, 93, 93,
! 93, 93, 0, 89, 0, 0, 0, 93, 0, 0,
! 0, 93, 93, 93, 93, 0, 0, 0, 0, 0,
! 93, 93, 0, 0, 93, 93, 93, 93, 93, 0,
! 93, 93, 0, 0, 93, 87, 87, 87, 87, 0,
! 0, 0, 0, 0, 87, 0, 0, 0, 87, 87,
! 87, 87, 0, 0, 0, 0, 0, 87, 87, 0,
! 0, 87, 87, 87, 87, 87, 0, 87, 87, 0,
! 0, 0, 0, 88, 88, 88, 88, 0, 0, 0,
! 0, 0, 88, 0, 0, 0, 88, 88, 88, 88,
! 85, 0, 0, 85, 0, 88, 88, 0, 0, 88,
! 88, 88, 88, 88, 0, 88, 88, 85, 85, 0,
! 0, 0, 85, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 86, 0, 0, 86,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 85, 86, 86, 0, 0, 0, 86, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 84, 0, 0, 84, 0, 0, 0, 0, 86, 0,
! 0, 0, 89, 89, 89, 89, 0, 84, 84, 0,
! 0, 89, 84, 0, 0, 89, 89, 89, 89, 0,
! 0, 0, 0, 0, 89, 89, 0, 0, 89, 89,
! 89, 89, 89, 72, 89, 89, 72, 0, 0, 0,
0, 0, 84, 0, 0, 0, 0, 0, 0, 0,
! 72, 72, 0, 0, 0, 72, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 73,
! 0, 0, 73, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 72, 73, 73, 0, 0,
! 0, 73, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 75, 0, 0, 75,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 73, 0, 75, 75, 0, 0, 0, 75, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 85, 85, 85, 85, 0, 0, 0, 0, 0,
! 85, 0, 0, 0, 85, 85, 85, 85, 75, 0,
! 0, 0, 0, 85, 85, 0, 0, 85, 85, 85,
! 85, 85, 0, 85, 85, 0, 0, 86, 86, 86,
! 86, 0, 0, 0, 0, 0, 86, 0, 0, 0,
! 86, 86, 86, 86, 123, 0, 0, 123, 0, 86,
! 86, 0, 0, 86, 86, 86, 86, 86, 0, 86,
! 86, 123, 123, 0, 0, 0, 123, 0, 0, 0,
! 0, 84, 84, 84, 84, 0, 0, 0, 0, 0,
! 84, 0, 0, 0, 84, 84, 84, 84, 0, 0,
! 0, 0, 0, 84, 84, 0, 123, 84, 84, 84,
! 84, 84, 94, 84, 84, 94, 0, 0, 0, 0,
! 0, 0, 0, 0, 72, 72, 72, 72, 0, 94,
! 94, 0, 0, 72, 94, 0, 0, 72, 72, 72,
! 72, 0, 0, 0, 0, 0, 72, 72, 0, 0,
! 72, 72, 72, 72, 72, 0, 72, 72, 0, 0,
! 73, 73, 73, 73, 94, 0, 0, 0, 0, 73,
! 0, 0, 0, 73, 73, 73, 73, 0, 0, 0,
! 0, 0, 73, 73, 0, 0, 73, 73, 73, 73,
! 73, 134, 73, 0, 134, 0, 0, 75, 75, 75,
! 75, 0, 0, 0, 0, 0, 75, 0, 134, 134,
! 75, 75, 0, 134, 0, 0, 0, 0, 0, 75,
! 75, 0, 0, 75, 75, 75, 75, 75, 76, 75,
! 0, 76, 0, 0, 0, 0, 0, 0, 77, 0,
! 0, 77, 0, 134, 0, 76, 76, 0, 0, 0,
! 76, 0, 0, 0, 0, 77, 77, 0, 0, 0,
! 77, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 78, 0, 0, 78, 0, 0,
! 76, 0, 0, 0, 0, 123, 123, 123, 123, 0,
! 77, 78, 78, 0, 123, 0, 78, 0, 123, 123,
! 0, 0, 0, 0, 0, 0, 79, 123, 123, 79,
! 0, 123, 123, 123, 123, 123, 81, 0, 0, 81,
! 0, 0, 0, 79, 79, 0, 78, 0, 79, 0,
! 0, 0, 0, 81, 81, 0, 0, 0, 81, 0,
! 0, 0, 0, 94, 94, 94, 94, 0, 0, 284,
! 0, 0, 94, 0, 157, 0, 94, 94, 79, 0,
! 0, 0, 0, 0, 0, 94, 94, 0, 81, 94,
! 94, 94, 94, 94, 0, 0, 0, 0, 0, 0,
! 0, 0, 168, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 150, 0, 0, 0, 0, 0,
! 0, 0, 134, 134, 134, 134, 0, 0, 0, 0,
! 0, 134, 0, 0, 0, 134, 134, 0, 0, 0,
! 0, 0, 0, 0, 134, 134, 0, 0, 134, 134,
! 134, 134, 134, 0, 0, 0, 0, 0, 0, 76,
! 76, 76, 76, 0, 0, 0, 0, 0, 76, 77,
! 77, 77, 77, 76, 0, 0, 0, 0, 77, 0,
! 0, 76, 76, 0, 0, 76, 76, 76, 76, 76,
! 0, 77, 77, 0, 0, 77, 77, 77, 77, 77,
! 0, 0, 0, 0, 0, 78, 78, 78, 78, 0,
! 0, 0, 0, 0, 78, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 78, 78, 0,
! 0, 78, 78, 78, 78, 78, 0, 79, 79, 79,
! 79, 0, 0, 0, 0, 0, 79, 81, 81, 81,
! 81, 0, 0, 0, 0, 0, 81, 0, 0, 79,
! 79, 0, 0, 79, 79, 79, 79, 0, 0, 81,
! 81, 0, 151, 81, 81, 81, 152, 153, 154, 155,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 156,
! 158, 159, 160, 161, 0, 162, 163, 91, 0, 164,
! 0, 0, 165, 166, 167, 104, 0, 0, 0, 0,
! 111, 113, 0, 0, 0, 0, 0, 125, 126, 127,
! 128, 129, 130, 0, 0, 133, 134, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 183, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 215, 0, 0, 0, 0, 0, 0, 0, 223, 224,
- 225, 226, 227, 228, 229, 230, 231, 232, 233, 234,
- 235, 236, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 296, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 312,
};
short yycheck[] = { 13,
! 257, 13, 91, 17, 44, 41, 59, 182, 36, 41,
! 59, 257, 44, 194, 41, 188, 59, 190, 41, 33,
! 34, 35, 36, 59, 82, 40, 58, 59, 41, 43,
! 88, 63, 125, 45, 123, 59, 50, 40, 59, 59,
! 40, 91, 123, 91, 56, 41, 257, 41, 60, 41,
! 41, 41, 278, 41, 36, 41, 44, 93, 116, 40,
! 91, 93, 41, 91, 78, 41, 40, 40, 59, 41,
! 58, 59, 40, 123, 123, 123, 91, 41, 92, 41,
! 40, 95, 94, 97, 96, 99, 98, 101, 100, 41,
! 102, 40, 123, 41, 106, 123, 44, 59, 41, 123,
! 59, 41, 294, 295, 41, 93, 0, 59, 123, 59,
! 58, 59, 287, 59, 44, 59, 59, 59, 299, 59,
! 123, 302, 59, 123, 297, 298, 184, 141, 276, 277,
! 123, 304, 144, 145, 146, 147, 148, 149, 150, 33,
! 40, 123, 36, 37, 38, 93, 40, 260, 42, 43,
! 123, 45, 123, 334, 327, 93, 168, 169, 170, 171,
! 172, 173, 174, 123, 178, 59, 40, 40, 36, 0,
! 64, 185, 40, 266, 267, 268, 257, 270, 271, 41,
! 40, 93, 91, 266, 267, 268, 198, 270, 271, 125,
! 93, 41, 204, 205, 206, 59, 59, 91, 287, 211,
! 41, 125, 33, 91, 257, 36, 37, 38, 295, 40,
! 93, 42, 43, 40, 45, 41, 305, 40, 125, 308,
! 125, 125, 311, 312, 313, 237, 125, 239, 59, 123,
! 258, 125, 126, 64, 59, 125, 272, 273, 274, 275,
! 272, 273, 274, 275, 93, 259, 41, 261, 41, 263,
! 264, 294, 295, 267, 294, 295, 270, 269, 294, 295,
! 91, 41, 294, 295, 44, 313, 298, 294, 295, 93,
! 282, 294, 295, 294, 295, 257, 272, 273, 274, 275,
! 262, 294, 295, 63, 272, 273, 274, 275, 59, 301,
! 123, 305, 123, 41, 125, 126, 0, 93, 294, 295,
! 294, 295, 294, 295, 294, 295, 294, 295, 294, 295,
! 298, 91, 59, 325, 41, 294, 295, 331, 294, 295,
! 59, 335, 294, 295, 272, 273, 274, 275, 41, 33,
! 294, 295, 36, 37, 38, 59, 40, 83, 42, 43,
! 41, 45, 325, 123, 294, 295, 294, 295, 294, 295,
! 294, 295, 294, 295, 13, 59, 294, 295, 269, 93,
! 64, -1, 256, 257, 258, 259, 260, 261, -1, 263,
264, 265, 266, 267, 268, 269, 270, 271, 272, 273,
! 274, 275, 294, 295, -1, 279, 280, 91, 282, 283,
! 284, 294, 295, -1, -1, 289, 290, 291, 292, 293,
! -1, -1, 296, 297, -1, 41, -1, -1, 44, 303,
! -1, 294, 295, 307, -1, 309, 310, -1, -1, 123,
! -1, -1, 126, 59, 91, 256, 257, 258, 259, 260,
! 261, -1, 263, 264, 265, 266, 267, 268, 269, 270,
! 271, 272, 273, 274, 275, 294, 295, -1, 279, 280,
! -1, 282, 283, 284, 91, -1, 123, 93, 289, 290,
! 291, 292, 293, -1, -1, 296, 297, -1, -1, -1,
! 294, 295, 303, -1, -1, -1, 307, -1, 309, 310,
! 272, 273, 274, 275, 33, 91, 123, 36, 37, 38,
! -1, 40, 41, 42, 43, 44, 45, -1, 294, 295,
! -1, 281, 294, 295, -1, 285, 286, 287, 288, 58,
! 59, 6, -1, 8, 63, 64, -1, 123, 298, 299,
! 300, 301, 302, -1, 304, 305, -1, -1, 308, -1,
! -1, 311, 312, 313, -1, -1, 31, 32, -1, -1,
! -1, -1, 91, -1, 93, 41, -1, -1, 44, -1,
! -1, 91, 256, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, 58, 59, -1, 269, -1, 63, 272, 273,
! 274, 275, -1, -1, 123, 279, 280, 126, 282, 283,
! 284, -1, -1, 123, -1, 289, 290, 291, 292, 293,
! -1, -1, 296, 297, -1, 91, -1, 93, -1, 303,
! -1, -1, -1, 307, 33, 309, 310, 36, 37, 38,
! -1, 40, 41, 42, 43, 44, 45, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 123, -1, 58,
! 59, -1, -1, -1, 63, 64, 272, 273, 274, 275,
! -1, 308, -1, -1, 311, 312, 313, -1, 285, 286,
! 287, 288, -1, -1, -1, -1, -1, -1, 294, -1,
! -1, -1, -1, -1, 93, 302, -1, 304, 305, -1,
! 41, 308, -1, 44, 311, 312, 313, -1, -1, 285,
! 286, 287, 288, -1, -1, -1, -1, 58, 59, -1,
! -1, -1, 63, 299, 300, 301, 302, 126, 304, 305,
! -1, -1, 308, -1, -1, 311, 312, 313, 257, 258,
! 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
! 269, -1, 93, 272, 273, 274, 275, -1, -1, -1,
! -1, 280, 281, 282, 283, 284, 285, 286, 287, 288,
! 289, 290, 291, 292, 293, 294, 295, 296, 297, 298,
! 299, 300, 301, 302, 303, 304, 305, -1, 307, 308,
! 309, 310, 311, 312, 313, 305, -1, -1, 308, 91,
! -1, 311, 312, 313, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, -1, -1, 281, -1, -1, -1, 285,
! 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
! -1, 123, 298, 299, 300, 301, 302, -1, 304, 305,
! -1, -1, 308, -1, -1, 311, 312, 313, 91, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 257, 258,
! 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
! 269, -1, -1, 272, 273, 274, 275, -1, -1, -1,
! 123, 280, 281, 282, 283, 284, 285, 286, 287, 288,
! 289, 290, 291, 292, 293, 294, 295, 296, 297, 298,
! 299, 300, 301, 302, 303, 304, 305, -1, 307, 308,
! 309, 310, 311, 312, 313, 33, 48, 49, 36, 37,
! 38, -1, 40, -1, 42, 43, -1, 45, -1, -1,
! -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
! 281, 59, -1, -1, 285, 286, 64, 288, -1, -1,
! 82, -1, -1, 294, 295, -1, 88, 298, 299, 300,
! 301, 302, -1, 304, -1, -1, -1, -1, -1, -1,
! -1, 33, -1, 91, 36, 37, 38, -1, 40, -1,
! 42, 43, -1, 45, 116, -1, -1, -1, -1, -1,
! -1, 123, -1, 285, 286, 287, 288, 59, -1, -1,
! -1, -1, 64, -1, -1, 123, -1, -1, 126, 301,
! 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
! 312, 313, -1, -1, -1, -1, -1, 33, -1, 91,
! 36, 37, 38, -1, 40, -1, 42, 43, -1, 45,
! -1, -1, -1, -1, 287, 288, -1, -1, -1, -1,
! -1, -1, 184, -1, -1, -1, -1, -1, 64, -1,
! -1, 123, 305, -1, 126, 308, -1, -1, 311, 312,
! 313, -1, -1, -1, 41, -1, -1, 44, -1, -1,
! -1, -1, -1, -1, -1, 91, -1, 26, -1, -1,
! 33, 58, 59, 36, 37, 38, -1, 40, -1, 42,
! 43, -1, 45, 42, -1, -1, -1, -1, 47, -1,
! 49, -1, -1, -1, -1, -1, -1, 123, -1, -1,
! 126, 64, 61, 62, 63, 64, 93, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 256, 257,
! 258, 259, 260, 261, -1, 263, 264, 265, 91, -1,
! -1, 269, -1, -1, 272, 273, 274, 275, -1, -1,
! -1, 279, 280, -1, 282, 283, 284, -1, 107, -1,
! -1, 289, 290, 291, 292, 293, -1, -1, 296, 297,
! 123, -1, -1, 126, 91, 303, -1, -1, -1, 307,
! -1, 309, 310, -1, 256, 257, 258, 259, 260, 261,
! -1, 263, 264, 265, -1, -1, -1, 269, -1, -1,
! 272, 273, 274, 275, -1, -1, 123, 279, 280, -1,
! 282, 283, 284, -1, -1, -1, -1, 289, 290, 291,
! 292, 293, -1, -1, 296, 297, -1, -1, -1, -1,
! 91, 303, -1, -1, -1, 307, -1, 309, 310, -1,
! -1, 257, 258, 259, 260, 261, 262, 263, 264, 265,
! 41, -1, -1, 269, -1, -1, -1, -1, -1, -1,
! -1, -1, 123, -1, 280, -1, 282, 283, 284, -1,
! -1, -1, 63, 289, 290, 291, 292, 293, -1, -1,
! 296, 297, -1, -1, -1, -1, -1, 303, -1, -1,
! -1, 307, -1, 309, 310, 272, 273, 274, 275, -1,
! 91, -1, -1, -1, 257, 258, 259, 260, 261, -1,
! 263, 264, 265, -1, -1, -1, 269, 294, 295, -1,
! -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 123, -1, -1, -1, 289, 290, 291, 292,
! 293, -1, -1, 296, 297, -1, -1, -1, -1, -1,
! 303, -1, -1, -1, 307, 33, 309, 310, 36, 37,
! 38, -1, 40, -1, 42, 43, -1, 45, 285, 286,
! 287, 288, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 59, -1, 300, 301, 302, 64, 304, 305, -1,
-1, 308, -1, -1, 311, 312, 313, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 33, -1, 91, 36, 37, 38, -1, 40, -1,
! 42, 43, -1, 45, 285, 286, 287, 288, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, 64, 304, 305, -1, -1, 308, 126, -1,
! 311, 312, 313, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 33, -1, 91,
! 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 281, -1, -1, -1, 285, 286, 287, 288, 64, -1,
! -1, 123, -1, -1, 126, -1, -1, 298, 299, 300,
! 301, 302, -1, 304, 305, -1, -1, 308, -1, -1,
! 311, 312, 313, -1, -1, 91, -1, -1, -1, -1,
! 33, -1, -1, 36, 37, 38, -1, 40, -1, 42,
! 43, -1, 45, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 126, 64, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 257,
! 258, 259, 260, 261, -1, 263, 264, 265, 91, -1,
! 93, 269, -1, -1, -1, 91, -1, -1, -1, -1,
! -1, -1, 280, -1, 282, 283, 284, -1, -1, -1,
! -1, 289, 290, 291, 292, 293, -1, 63, 296, 297,
! -1, -1, -1, 126, -1, 303, -1, 123, -1, 307,
! -1, 309, 310, -1, -1, 257, 258, 259, 260, 261,
! -1, 263, 264, 265, -1, 91, -1, 269, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 280, -1,
! 282, 283, 284, -1, -1, -1, -1, 289, 290, 291,
! 292, 293, -1, -1, 296, 297, 91, 123, -1, -1,
! -1, 303, -1, 41, -1, 307, 44, 309, 310, -1,
! -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
! 58, 59, -1, 269, -1, 63, -1, -1, 123, -1,
! -1, -1, -1, -1, 280, -1, 282, 283, 284, -1,
! -1, -1, -1, 289, 290, 291, 292, 293, -1, -1,
! 296, 297, -1, -1, -1, 93, -1, 303, -1, -1,
! -1, 307, -1, 309, 310, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 257, 258, 259, 260, 261, -1,
! 263, 264, 265, -1, 33, -1, 269, 36, 37, 38,
! -1, 40, -1, 42, 43, -1, 45, 280, -1, 282,
! 283, 284, -1, -1, -1, -1, 289, 290, 291, 292,
! 293, 287, 288, 296, 297, 64, -1, -1, -1, -1,
! 303, -1, -1, -1, 307, -1, 309, 310, 304, 305,
! -1, -1, 308, -1, -1, 311, 312, 313, -1, -1,
! 33, -1, 91, 36, 37, 38, -1, 40, 41, 42,
! 43, -1, 45, -1, -1, 281, -1, -1, -1, 285,
! 286, 287, 288, -1, -1, -1, -1, -1, -1, -1,
! -1, 64, 298, 299, 300, 301, 302, 126, 304, 305,
! -1, -1, 308, -1, -1, 311, 312, 313, -1, -1,
! 285, -1, 287, 288, -1, -1, 33, -1, 91, 36,
! 37, 38, -1, 40, 41, 42, 43, -1, 45, 304,
! 305, -1, -1, 308, -1, -1, 311, 312, 313, -1,
! -1, -1, -1, -1, -1, -1, -1, 64, -1, -1,
! -1, -1, -1, 126, 272, 273, 274, 275, -1, -1,
! -1, -1, -1, 281, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 91, -1, 294, 295, -1, 33,
! 298, 299, 36, 37, 38, -1, 40, 41, 42, 43,
! -1, 45, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 126,
! 64, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, 256, 257, 258,
259, 260, 261, -1, 263, 264, 265, 91, -1, -1,
! 269, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 280, -1, 282, 283, 284, -1, -1, -1, -1,
289, 290, 291, 292, 293, -1, -1, 296, 297, -1,
! -1, -1, 126, -1, 303, -1, 41, -1, 307, 44,
! 309, 310, -1, -1, 257, 258, 259, 260, 261, -1,
! 263, 264, 265, 58, 59, -1, 269, -1, 63, -1,
! -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
283, 284, -1, -1, -1, -1, 289, 290, 291, 292,
! 293, -1, -1, 296, 297, -1, 91, -1, 93, -1,
! 303, -1, 41, -1, 307, 44, 309, 310, -1, -1,
! 257, 258, 259, 260, 261, -1, 263, 264, 265, 58,
! 59, -1, 269, -1, 63, -1, -1, -1, 123, -1,
-1, -1, -1, 280, -1, 282, 283, 284, -1, -1,
-1, -1, 289, 290, 291, 292, 293, -1, -1, 296,
! 297, -1, 91, -1, 93, -1, 303, -1, -1, -1,
! 307, -1, 309, 310, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, -1, 33, 123, 269, 36, 37, 38, -1,
! 40, 41, 42, 43, -1, 45, 280, -1, 282, 283,
! 284, -1, -1, -1, -1, 289, 290, 291, 292, 293,
! -1, -1, 296, 297, 64, -1, 25, 26, -1, 303,
! -1, -1, -1, 307, -1, 309, 310, -1, 37, -1,
! -1, -1, -1, 42, 43, -1, -1, -1, 47, 33,
! 49, 91, 36, 37, 38, -1, 40, -1, 42, 43,
! -1, 45, 61, 62, 63, 64, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 64, -1, -1, -1, -1, -1, 126, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
- 285, 286, 287, 288, -1, -1, -1, 91, 107, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
- 305, -1, 41, 308, -1, 44, 311, 312, 313, -1,
- -1, -1, -1, 41, -1, -1, 44, -1, -1, 58,
- 59, -1, 126, 272, 273, 274, 275, -1, -1, -1,
- 58, 59, 281, -1, -1, 63, 285, 286, 287, 288,
- -1, -1, -1, -1, -1, 294, 295, -1, 167, 298,
- 299, 300, 301, 302, 93, 304, 305, -1, 41, 308,
- -1, 44, 311, 312, 313, 93, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 58, 59, -1, -1, -1,
- 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 123, -1, 257, 258, 259,
- 260, 261, -1, 263, 264, 265, -1, -1, 91, 269,
- 93, -1, -1, -1, -1, -1, -1, -1, -1, -1,
280, -1, 282, 283, 284, -1, -1, -1, -1, 289,
290, 291, 292, 293, -1, -1, 296, 297, -1, -1,
! -1, -1, -1, 303, -1, 41, -1, 307, 44, 309,
310, -1, -1, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, 58, 59, -1, 269, -1, 63, -1, -1,
-1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
284, -1, -1, -1, -1, 289, 290, 291, 292, 293,
! -1, -1, 296, 297, -1, -1, -1, 93, -1, 303,
! 41, -1, -1, 307, -1, 309, 310, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 58, 59, -1,
! -1, -1, 63, -1, -1, -1, -1, 123, -1, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
! -1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
! 91, -1, 93, 281, -1, 294, 295, 285, 286, 287,
! 288, -1, -1, -1, -1, -1, 294, 295, -1, -1,
! 298, 299, 300, 301, 302, -1, 304, 305, -1, -1,
! 308, -1, 123, 311, 312, 313, -1, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, -1, -1, 281, -1,
! -1, -1, 285, 286, 287, 288, -1, -1, -1, -1,
! -1, 294, 295, -1, 41, 298, 299, 300, 301, 302,
! -1, 304, 305, -1, -1, 308, -1, -1, 311, 312,
! 313, 58, 59, -1, -1, -1, 63, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 91, -1, 93, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, -1, -1, 281, -1, -1, -1, 285,
! 286, 287, 288, -1, -1, -1, 123, -1, 294, 295,
! -1, -1, 298, 299, 300, 301, 302, -1, 304, 305,
! 41, -1, 308, 44, -1, 311, 312, 313, -1, -1,
! -1, 41, -1, -1, 44, -1, -1, 58, 59, -1,
-1, 272, 273, 274, 275, -1, -1, -1, 58, 59,
281, -1, -1, 63, 285, 286, 287, 288, -1, -1,
-1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
! 301, 302, 93, 304, 305, -1, -1, 308, -1, -1,
! 311, 312, 313, 93, 41, -1, -1, 44, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 58, 59, -1, -1, -1, 63, -1, -1, -1,
! -1, -1, -1, 123, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
! 44, -1, -1, -1, -1, -1, 93, -1, -1, -1,
! -1, -1, -1, -1, 58, 59, -1, -1, -1, 63,
! -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
! -1, -1, -1, -1, 281, -1, 123, -1, 285, 286,
! 287, 288, -1, -1, -1, 41, -1, 294, 295, 93,
! -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
! -1, 308, 58, 59, 311, 312, 313, 63, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 123,
! -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
! 44, -1, -1, -1, -1, 91, -1, 93, -1, -1,
! -1, -1, -1, -1, 58, 59, -1, -1, -1, 63,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 272, 273, 274, 275, -1, -1, 123, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, -1, -1, 93,
! -1, 281, -1, 294, 295, 285, 286, 287, 288, -1,
! -1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
300, 301, 302, -1, 304, 305, -1, -1, 308, -1,
! -1, 311, 312, 313, -1, 41, -1, -1, 44, -1,
! -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
! -1, -1, 58, 59, 281, -1, -1, 63, 285, 286,
! 287, 288, -1, -1, -1, -1, -1, 294, 295, -1,
! -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
! -1, 308, -1, -1, 311, 312, 313, 93, 272, 273,
! 274, 275, -1, -1, -1, 41, -1, 281, 44, -1,
! -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
! 294, 295, 58, 59, 298, 299, 300, 301, 302, -1,
! 304, 305, -1, -1, 308, -1, -1, 311, 312, 313,
! -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, -1, -1, 281, -1, 93, -1, 285,
! 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
! -1, 63, 298, 299, 300, 301, 302, -1, 304, 305,
! -1, -1, 308, -1, -1, 311, 312, 313, 272, 273,
! 274, 275, -1, -1, -1, -1, -1, 281, -1, 91,
! -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
! 294, 295, -1, -1, 298, 299, 300, 301, 302, 41,
! 304, 305, 44, -1, 308, -1, -1, 311, 312, 313,
! -1, 123, -1, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 41, -1, -1, 44,
! -1, 93, -1, -1, -1, -1, 272, 273, 274, 275,
-1, -1, -1, 58, 59, 281, -1, -1, 63, 285,
! 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
-1, -1, 298, 299, 300, 301, 302, -1, 304, 305,
41, -1, 308, 44, -1, 311, 312, 313, 93, -1,
! -1, -1, -1, -1, -1, -1, -1, 58, 59, -1,
! -1, -1, 63, -1, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
! 44, -1, -1, -1, -1, -1, -1, -1, 294, 295,
! -1, -1, 93, -1, 58, 59, -1, -1, -1, 63,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 41, -1, -1, 44, -1, 281,
! -1, -1, -1, 285, 286, 287, 288, -1, -1, 93,
! -1, 58, 59, -1, -1, -1, 63, 299, 300, 301,
! 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
! 312, 313, 41, -1, -1, 44, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 93, -1, -1, 58,
! 59, -1, -1, -1, 63, -1, -1, -1, -1, -1,
! 272, 273, 274, 275, -1, -1, -1, -1, -1, 281,
! -1, -1, -1, 285, 286, 287, 288, -1, -1, -1,
! -1, -1, 294, 295, 93, -1, 298, 299, 300, 301,
! 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
! 312, 313, -1, -1, -1, -1, -1, 272, 273, 274,
! 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
285, 286, 287, 288, -1, -1, -1, -1, -1, 294,
295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
! 305, 41, -1, 308, 44, -1, 311, 312, 313, -1,
-1, 272, 273, 274, 275, -1, -1, -1, 58, 59,
281, -1, -1, 63, 285, 286, 287, 288, -1, -1,
-1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
! 301, 302, -1, 304, 305, -1, -1, 308, 272, 273,
! 274, 275, -1, 93, -1, -1, -1, 281, -1, -1,
! -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
! 294, 295, -1, -1, 298, 299, 300, 301, 302, -1,
! 304, 305, -1, -1, 308, 272, 273, 274, 275, -1,
! -1, -1, -1, -1, 281, -1, -1, -1, 285, 286,
! 287, 288, -1, -1, -1, -1, -1, 294, 295, -1,
! -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
! -1, -1, 281, -1, -1, -1, 285, 286, 287, 288,
! 41, -1, -1, 44, -1, 294, 295, -1, -1, 298,
! 299, 300, 301, 302, -1, 304, 305, 58, 59, -1,
! -1, -1, 63, -1, -1, -1, -1, -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,
! 41, -1, -1, 44, -1, -1, -1, -1, 93, -1,
! -1, -1, 272, 273, 274, 275, -1, 58, 59, -1,
! -1, 281, 63, -1, -1, 285, 286, 287, 288, -1,
-1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
! 300, 301, 302, 41, 304, 305, 44, -1, -1, -1,
! -1, -1, 93, -1, -1, -1, -1, -1, -1, -1,
58, 59, -1, -1, -1, 63, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, 41,
-1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, 93, 58, 59, -1, -1,
-1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 41, -1, -1, 44,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 93, -1, 58, 59, -1, -1, -1, 63, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
! 281, -1, -1, -1, 285, 286, 287, 288, 93, -1,
! -1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
! 301, 302, -1, 304, 305, -1, -1, 272, 273, 274,
275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
285, 286, 287, 288, 41, -1, -1, 44, -1, 294,
! 295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
305, 58, 59, -1, -1, -1, 63, -1, -1, -1,
! -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
! 281, -1, -1, -1, 285, 286, 287, 288, -1, -1,
! -1, -1, -1, 294, 295, -1, 93, 298, 299, 300,
! 301, 302, 41, 304, 305, 44, -1, -1, -1, -1,
! -1, -1, -1, -1, 272, 273, 274, 275, -1, 58,
! 59, -1, -1, 281, 63, -1, -1, 285, 286, 287,
! 288, -1, -1, -1, -1, -1, 294, 295, -1, -1,
! 298, 299, 300, 301, 302, -1, 304, 305, -1, -1,
! 272, 273, 274, 275, 93, -1, -1, -1, -1, 281,
! -1, -1, -1, 285, 286, 287, 288, -1, -1, -1,
-1, -1, 294, 295, -1, -1, 298, 299, 300, 301,
! 302, 41, 304, -1, 44, -1, -1, 272, 273, 274,
! 275, -1, -1, -1, -1, -1, 281, -1, 58, 59,
! 285, 286, -1, 63, -1, -1, -1, -1, -1, 294,
! 295, -1, -1, 298, 299, 300, 301, 302, 41, 304,
! -1, 44, -1, -1, -1, -1, -1, -1, 41, -1,
! -1, 44, -1, 93, -1, 58, 59, -1, -1, -1,
! 63, -1, -1, -1, -1, 58, 59, -1, -1, -1,
! 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 41, -1, -1, 44, -1, -1,
! 93, -1, -1, -1, -1, 272, 273, 274, 275, -1,
! 93, 58, 59, -1, 281, -1, 63, -1, 285, 286,
! -1, -1, -1, -1, -1, -1, 41, 294, 295, 44,
! -1, 298, 299, 300, 301, 302, 41, -1, -1, 44,
! -1, -1, -1, 58, 59, -1, 93, -1, 63, -1,
! -1, -1, -1, 58, 59, -1, -1, -1, 63, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, -1, 58,
! -1, -1, 281, -1, 63, -1, 285, 286, 93, -1,
! -1, -1, -1, -1, -1, 294, 295, -1, 93, 298,
! 299, 300, 301, 302, -1, -1, -1, -1, -1, -1,
! -1, -1, 91, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 123, -1, -1, -1, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, -1, -1, -1,
! -1, 281, -1, -1, -1, 285, 286, -1, -1, -1,
! -1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
! 300, 301, 302, -1, -1, -1, -1, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, -1, -1, 281, 272,
! 273, 274, 275, 286, -1, -1, -1, -1, 281, -1,
! -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
! -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
-1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
! -1, -1, -1, -1, 281, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 294, 295, -1,
! -1, 298, 299, 300, 301, 302, -1, 272, 273, 274,
! 275, -1, -1, -1, -1, -1, 281, 272, 273, 274,
! 275, -1, -1, -1, -1, -1, 281, -1, -1, 294,
! 295, -1, -1, 298, 299, 300, 301, -1, -1, 294,
! 295, -1, 281, 298, 299, 300, 285, 286, 287, 288,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 298,
! 299, 300, 301, 302, -1, 304, 305, 30, -1, 308,
! -1, -1, 311, 312, 313, 38, -1, -1, -1, -1,
! 43, 44, -1, -1, -1, -1, -1, 50, 51, 52,
! 53, 54, 55, -1, -1, 58, 59, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 90, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 143, -1, -1, -1, -1, -1, -1, -1, 151, 152,
! 153, 154, 155, 156, 157, 158, 159, 160, 161, 162,
! 163, 164, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
--- 92,1098 ----
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,
};
short yyrindex[] = { 0,
! 0, 0, 269, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 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, 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, 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, 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, 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,
};
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,
};
! #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,
! 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, 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, 0, 0, 0, 0, 0, 0, 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, 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, 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, 0, 0, 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, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 215, 0, 0, 0, 0,
! 0, 0, 0, 223, 224, 225, 226, 227, 228, 229,
! 230, 231, 232, 233, 234, 235, 236, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 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,
};
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,
! 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,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 294, 295, 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, -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, -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, -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, -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, -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, -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,
! -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,
! 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,
-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, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
***************
*** 1107,1116 ****
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 256, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 284,
};
#define YYFINAL 1
#ifndef YYDEBUG
--- 1101,1110 ----
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 256, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 284,
};
#define YYFINAL 1
#ifndef YYDEBUG
***************
*** 1190,1196 ****
"startsub :",
"package : PACKAGE WORD ';'",
"package : PACKAGE ';'",
! "use : USE startsub WORD listexpr ';'",
"expr : expr ANDOP expr",
"expr : expr OROP expr",
"expr : argexpr",
--- 1184,1190 ----
"startsub :",
"package : PACKAGE WORD ';'",
"package : PACKAGE ';'",
! "use : USE startsub WORD WORD listexpr ';'",
"expr : expr ANDOP expr",
"expr : expr OROP expr",
"expr : argexpr",
***************
*** 1320,1326 ****
YYSTYPE yylval;
#line 571 "perly.y"
/* PROGRAM */
! #line 1394 "y.tab.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
--- 1314,1320 ----
YYSTYPE yylval;
#line 571 "perly.y"
/* PROGRAM */
! #line 1388 "y.tab.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
***************
*** 1341,1355 ****
void* ptr;
{
struct ysv* ysave = (struct ysv*)ptr;
! if (ysave->yyss) Safefree(ysave->yyss);
! if (ysave->yyvs) Safefree(ysave->yyvs);
yydebug = ysave->oldyydebug;
yynerrs = ysave->oldyynerrs;
yyerrflag = ysave->oldyyerrflag;
yychar = ysave->oldyychar;
yyval = ysave->oldyyval;
yylval = ysave->oldyylval;
! Safefree(ysave);
}
int
--- 1335,1349 ----
void* ptr;
{
struct ysv* ysave = (struct ysv*)ptr;
! if (ysave->yyss) safefree((char *)ysave->yyss);
! if (ysave->yyvs) safefree((char *)ysave->yyvs);
yydebug = ysave->oldyydebug;
yynerrs = ysave->oldyynerrs;
yyerrflag = ysave->oldyyerrflag;
yychar = ysave->oldyychar;
yyval = ysave->oldyyval;
yylval = ysave->oldyylval;
! safefree((char *)ysave);
}
int
***************
*** 1412,1418 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
#endif
--- 1406,1412 ----
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,
yychar, yys);
}
#endif
***************
*** 1422,1428 ****
{
#if YYDEBUG
if (yydebug)
! fprintf(stderr, "yydebug: state %d, shifting to state %d\n",
yystate, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
--- 1416,1422 ----
{
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n",
yystate, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
***************
*** 1477,1483 ****
{
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
"yydebug: state %d, error recovery shifting to state %d\n",
*yyssp, yytable[yyn]);
#endif
--- 1471,1477 ----
{
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log,
"yydebug: state %d, error recovery shifting to state %d\n",
*yyssp, yytable[yyn]);
#endif
***************
*** 1507,1513 ****
{
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
"yydebug: error recovery discarding state %d\n",
*yyssp);
#endif
--- 1501,1507 ----
{
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log,
"yydebug: error recovery discarding state %d\n",
*yyssp);
#endif
***************
*** 1526,1532 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(stderr,
"yydebug: state %d, error recovery discards token %d (%s)\n",
yystate, yychar, yys);
}
--- 1520,1526 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(Perl_debug_log,
"yydebug: state %d, error recovery discards token %d (%s)\n",
yystate, yychar, yys);
}
***************
*** 1537,1543 ****
yyreduce:
#if YYDEBUG
if (yydebug)
! fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
yym = yylen[yyn];
--- 1531,1537 ----
yyreduce:
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
yym = yylen[yyn];
***************
*** 1785,1791 ****
break;
case 54:
#line 271 "perly.y"
! { utilize(yyvsp[-4].ival, yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
case 55:
#line 275 "perly.y"
--- 1779,1785 ----
break;
case 54:
#line 271 "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"
***************
*** 2246,2252 ****
#line 568 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! #line 2236 "y.tab.c"
}
yyssp -= yym;
yystate = *yyssp;
--- 2240,2246 ----
#line 568 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! #line 2230 "y.tab.c"
}
yyssp -= yym;
yystate = *yyssp;
***************
*** 2256,2262 ****
{
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
"yydebug: after reduction, shifting from state 0 to state %d\n",
YYFINAL);
#endif
--- 2250,2256 ----
{
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log,
"yydebug: after reduction, shifting from state 0 to state %d\n",
YYFINAL);
#endif
***************
*** 2272,2278 ****
yys = 0;
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,2272 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
#endif
***************
*** 2287,2293 ****
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
"yydebug: after reduction, shifting from state %d to state %d\n",
*yyssp, yystate);
#endif
--- 2281,2287 ----
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log,
"yydebug: after reduction, shifting from state %d to state %d\n",
*yyssp, yystate);
#endif
#~ Update to reflect new perly.c
#~ Use safefree instead of Safefree to free memory allocated by safemalloc
diff -Pcr perl5_003/perly.c.diff perl5_003_01/perly.c.diff
*** perl5_003/perly.c.diff Wed Feb 14 18:48:37 1996
--- perl5_003_01/perly.c.diff Sun Jul 7 19:31:35 1996
***************
*** 1,5 ****
! *** perly.c.orig Wed Feb 14 15:29:04 1996
! --- perly.c Wed Feb 14 15:29:05 1996
***************
*** 12,82 ****
deprecate("\"do\" to call subroutines");
--- 1,5 ----
! *** perly.c.orig Sun Jul 7 23:27:45 1996
! --- perly.c Sun Jul 7 23:27:46 1996
***************
*** 12,82 ****
deprecate("\"do\" to call subroutines");
***************
*** 75,81 ****
31, 0, 5, 3, 6, 6, 6, 7, 7, 7,
--- 12,17 ----
***************
! *** 1381,1393 ****
int yynerrs;
int yyerrflag;
int yychar;
--- 75,81 ----
31, 0, 5, 3, 6, 6, 6, 7, 7, 7,
--- 12,17 ----
***************
! *** 1375,1387 ****
int yynerrs;
int yyerrflag;
int yychar;
***************
*** 88,98 ****
- #define yystacksize YYSTACKSIZE
#line 571 "perly.y"
/* PROGRAM */
! #line 1394 "y.tab.c"
! --- 1316,1323 ----
***************
! *** 1394,1407 ****
! --- 1324,1382 ----
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
--- 88,98 ----
- #define yystacksize YYSTACKSIZE
#line 571 "perly.y"
/* PROGRAM */
! #line 1388 "y.tab.c"
! --- 1310,1317 ----
***************
! *** 1388,1401 ****
! --- 1318,1376 ----
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
***************
*** 113,127 ****
+ void* ptr;
+ {
+ struct ysv* ysave = (struct ysv*)ptr;
! + if (ysave->yyss) Safefree(ysave->yyss);
! + if (ysave->yyvs) Safefree(ysave->yyvs);
+ yydebug = ysave->oldyydebug;
+ yynerrs = ysave->oldyynerrs;
+ yyerrflag = ysave->oldyyerrflag;
+ yychar = ysave->oldyychar;
+ yyval = ysave->oldyyval;
+ yylval = ysave->oldyylval;
! + Safefree(ysave);
+ }
+
int
--- 113,127 ----
+ void* ptr;
+ {
+ struct ysv* ysave = (struct ysv*)ptr;
! + if (ysave->yyss) safefree((char *)ysave->yyss);
! + if (ysave->yyvs) safefree((char *)ysave->yyvs);
+ yydebug = ysave->oldyydebug;
+ yynerrs = ysave->oldyynerrs;
+ yyerrflag = ysave->oldyyerrflag;
+ yychar = ysave->oldyychar;
+ yyval = ysave->oldyyval;
+ yylval = ysave->oldyylval;
! + safefree((char *)ysave);
+ }
+
int
***************
*** 153,160 ****
{
yyn = *yys;
***************
! *** 1414,1419 ****
! --- 1389,1402 ----
yyerrflag = 0;
yychar = (-1);
--- 153,160 ----
{
yyn = *yys;
***************
! *** 1408,1413 ****
! --- 1383,1396 ----
yyerrflag = 0;
yychar = (-1);
***************
*** 170,176 ****
yyvsp = yyvs;
*yyssp = yystate = 0;
***************
! *** 1429,1435 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
--- 170,176 ----
yyvsp = yyvs;
*yyssp = yystate = 0;
***************
! *** 1423,1429 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
***************
*** 178,184 ****
yychar, yys);
}
#endif
! --- 1412,1418 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
--- 178,184 ----
yychar, yys);
}
#endif
! --- 1406,1412 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
***************
*** 187,193 ****
}
#endif
***************
! *** 1439,1450 ****
{
#if YYDEBUG
if (yydebug)
--- 187,193 ----
}
#endif
***************
! *** 1433,1444 ****
{
#if YYDEBUG
if (yydebug)
***************
*** 200,206 ****
}
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
! --- 1422,1447 ----
{
#if YYDEBUG
if (yydebug)
--- 200,206 ----
}
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
! --- 1416,1441 ----
{
#if YYDEBUG
if (yydebug)
***************
*** 228,234 ****
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
***************
! *** 1480,1491 ****
{
#if YYDEBUG
if (yydebug)
--- 228,234 ----
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
***************
! *** 1474,1485 ****
{
#if YYDEBUG
if (yydebug)
***************
*** 241,247 ****
}
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
! --- 1477,1503 ----
{
#if YYDEBUG
if (yydebug)
--- 241,247 ----
}
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
! --- 1471,1497 ----
{
#if YYDEBUG
if (yydebug)
***************
*** 270,276 ****
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
***************
! *** 1495,1502 ****
{
#if YYDEBUG
if (yydebug)
--- 270,276 ----
*++yyssp = yystate = yytable[yyn];
*++yyvsp = yylval;
***************
! *** 1489,1496 ****
{
#if YYDEBUG
if (yydebug)
***************
*** 279,285 ****
#endif
if (yyssp <= yyss) goto yyabort;
--yyssp;
! --- 1507,1515 ----
{
#if YYDEBUG
if (yydebug)
--- 279,285 ----
#endif
if (yyssp <= yyss) goto yyabort;
--yyssp;
! --- 1501,1509 ----
{
#if YYDEBUG
if (yydebug)
***************
*** 290,296 ****
if (yyssp <= yyss) goto yyabort;
--yyssp;
***************
! *** 1513,1520 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
--- 290,296 ----
if (yyssp <= yyss) goto yyabort;
--yyssp;
***************
! *** 1507,1514 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
***************
*** 299,305 ****
}
#endif
yychar = (-1);
! --- 1526,1534 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
--- 299,305 ----
}
#endif
yychar = (-1);
! --- 1520,1528 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
***************
*** 310,316 ****
#endif
yychar = (-1);
***************
! *** 1523,1529 ****
yyreduce:
#if YYDEBUG
if (yydebug)
--- 310,316 ----
#endif
yychar = (-1);
***************
! *** 1517,1523 ****
yyreduce:
#if YYDEBUG
if (yydebug)
***************
*** 318,324 ****
yystate, yyn, yyrule[yyn]);
#endif
yym = yylen[yyn];
! --- 1537,1543 ----
yyreduce:
#if YYDEBUG
if (yydebug)
--- 318,324 ----
yystate, yyn, yyrule[yyn]);
#endif
yym = yylen[yyn];
! --- 1531,1537 ----
yyreduce:
#if YYDEBUG
if (yydebug)
***************
*** 327,333 ****
#endif
yym = yylen[yyn];
***************
! *** 2242,2249 ****
{
#if YYDEBUG
if (yydebug)
--- 327,333 ----
#endif
yym = yylen[yyn];
***************
! *** 2236,2243 ****
{
#if YYDEBUG
if (yydebug)
***************
*** 336,342 ****
#endif
yystate = YYFINAL;
*++yyssp = YYFINAL;
! --- 2256,2264 ----
{
#if YYDEBUG
if (yydebug)
--- 336,342 ----
#endif
yystate = YYFINAL;
*++yyssp = YYFINAL;
! --- 2250,2258 ----
{
#if YYDEBUG
if (yydebug)
***************
*** 347,353 ****
yystate = YYFINAL;
*++yyssp = YYFINAL;
***************
! *** 2257,2263 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
--- 347,353 ----
yystate = YYFINAL;
*++yyssp = YYFINAL;
***************
! *** 2251,2257 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
***************
*** 355,361 ****
YYFINAL, yychar, yys);
}
#endif
! --- 2272,2278 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
--- 355,361 ----
YYFINAL, yychar, yys);
}
#endif
! --- 2266,2272 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
***************
*** 364,370 ****
}
#endif
***************
! *** 2272,2291 ****
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
--- 364,370 ----
}
#endif
***************
! *** 2266,2285 ****
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
***************
*** 385,391 ****
yyaccept:
! return (0);
}
! --- 2287,2321 ----
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
--- 385,391 ----
yyaccept:
! return (0);
}
! --- 2281,2315 ----
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
#~ Eliminate duplicate declaration of yylval
diff -Pcr perl5_003/perly.h perl5_003_01/perly.h
*** perl5_003/perly.h Wed Feb 28 17:38:06 1996
--- perl5_003_01/perly.h Tue Jul 9 11:07:58 1996
***************
*** 62,65 ****
GV *gvval;
} YYSTYPE;
extern YYSTYPE yylval;
- extern YYSTYPE yylval;
--- 62,64 ----
#~ Add version check option to "use"
diff -Pcr perl5_003/perly.y perl5_003_01/perly.y
*** perl5_003/perly.y Wed Feb 14 18:48:45 1996
--- perl5_003_01/perly.y Sat Jul 6 09:03:14 1996
***************
*** 267,274 ****
{ package(Nullop); }
;
! use : USE startsub WORD listexpr ';'
! { utilize($1, $2, $3, $4); }
;
expr : expr ANDOP expr
--- 267,274 ----
{ package(Nullop); }
;
! use : USE startsub WORD WORD listexpr ';'
! { utilize($1, $2, $3, $4, $5); }
;
expr : expr ANDOP expr
#~ New Plan9 port
diff -Pcr perl5_003/plan9/aperl perl5_003_01/plan9/aperl
*** perl5_003/plan9/aperl Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/aperl Mon Jul 15 16:39:22 1996
***************
*** 0 ****
--- 1,7 ----
+ #!/bin/rc
+
+ # aperl:
+ # Executes perl command and alters stderr to produce Acme-friendly error messages
+ # Created 02-JUL-1996, Luther Huffman, lutherh@stratcom.com
+
+ /bin/perl $* |[2] /bin/perl -pe 's/ line (\d+)/:$1/' >[1=2]
#~ New Plan9 port
diff -Pcr perl5_003/plan9/arpa/inet.h perl5_003_01/plan9/arpa/inet.h
*** perl5_003/plan9/arpa/inet.h Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/arpa/inet.h Wed Jul 17 15:21:10 1996
***************
*** 0 ****
--- 1,7 ----
+ /* Declarations which would have been found in <arpa/inet.h> */
+ /* On Plan 9, these are found in <netinet/in.h> */
+
+ /* extern unsigned long inet_addr(const char *); */
+ /* extern char *inet_ntoa(struct in_addr); */
+
+ #include <netinet/in.h>
diff -Pcr perl5_003/plan9/buildinfo perl5_003_01/plan9/buildinfo
*** perl5_003/plan9/buildinfo Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/buildinfo Mon Jul 15 16:39:22 1996
***************
*** 0 ****
--- 1 ----
+ p9pvers = 5.00301
#~ New Plan9 port
diff -Pcr perl5_003/plan9/config.plan9 perl5_003_01/plan9/config.plan9
*** perl5_003/plan9/config.plan9 Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/config.plan9 Tue Jul 16 15:26:12 1996
***************
*** 0 ****
--- 1,1573 ----
+ /* 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 $
+ */
+
+ /* Configuration time: Thu Feb 8 17:15:11 EST 1996
+ * Configured by: doughera
+ * Target system: sunos fractal 5.4 generic_101946-29 i86pc i386
+ */
+
+ #ifndef _config_h_
+ #define _config_h_
+
+ /* CAT2:
+ * This macro catenates 2 tokens together.
+ */
+
+ #define CAT2(a,b)a ## b
+ #define CAT3(a,b,c)a ## b ## c
+ #define CAT4(a,b,c,d)a ## b ## c ## d
+ #define CAT5(a,b,c,d,e)a ## b ## c ## d ## e
+ #define StGiFy(a)# a
+ #define STRINGIFY(a)StGiFy(a)
+ #define SCAT2(a,b)StGiFy(a) StGiFy(b)
+ #define SCAT3(a,b,c)StGiFy(a) StGiFy(b) StGiFy(c)
+ #define SCAT4(a,b,c,d)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d)
+ #define SCAT5(a,b,c,d,e)StGiFy(a) StGiFy(b) StGiFy(c) StGiFy(d) StGiFy(e)
+
+ /* config-start */
+
+ /* MEM_ALIGNBYTES:
+ * This symbol contains the number of bytes required to align a
+ * double. Usual values are 2, 4 and 8.
+ */
+ #define MEM_ALIGNBYTES 8 /* config-skip */
+
+ /* BIN:
+ * This symbol holds the path of the bin directory where the package will
+ * be installed. Program must be prepared to deal with ~name substitution.
+ */
+ #define BIN "/_P9P_OBJTYPE/bin" /* */
+
+ /* CPPSTDIN:
+ * This symbol contains the first part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. Typical value of "cc -E" or "/lib/cpp", but it can also
+ * call a wrapper. See CPPRUN.
+ */
+ /* CPPMINUS:
+ * This symbol contains the second part of the string which will invoke
+ * the C preprocessor on the standard input and produce to standard
+ * output. This symbol will have the value "-" if CPPSTDIN needs a minus
+ * to specify standard input, otherwise the value is "".
+ */
+ #define CPPSTDIN "cpp"
+ #define CPPMINUS ""
+
+ /* HAS_ALARM:
+ * This symbol, if defined, indicates that the alarm routine is
+ * available.
+ */
+ #define HAS_ALARM /**/
+
+ /* HASATTRIBUTE:
+ * This symbol indicates the C compiler can check for function attributes,
+ * such as printf formats. This is normally only supported by GNU cc.
+ */
+ #undef HASATTRIBUTE /* config-skip*/
+ #ifndef HASATTRIBUTE
+ #define __attribute__(_arg_)
+ #endif
+
+ /* HAS_BCMP:
+ * This symbol is defined if the bcmp() routine is available to
+ * compare blocks of memory.
+ */
+ #define HAS_BCMP /**/
+
+ /* HAS_BCOPY:
+ * This symbol is defined if the bcopy() routine is available to
+ * copy blocks of memory.
+ */
+ #define HAS_BCOPY /**/
+
+ /* HAS_BZERO:
+ * This symbol is defined if the bzero() routine is available to
+ * set a memory block to 0.
+ */
+ #define HAS_BZERO /**/
+
+ /* CASTI32:
+ * This symbol is defined if the C compiler can cast negative
+ * or large floating point numbers to 32-bit ints.
+ */
+ #undef CASTI32 /**/
+
+ /* CASTNEGFLOAT:
+ * This symbol is defined if the C compiler can cast negative
+ * numbers to unsigned longs, ints and shorts.
+ */
+ /* CASTFLAGS:
+ * This symbol contains flags that say what difficulties the compiler
+ * has casting odd floating values to unsigned long:
+ * 0 = ok
+ * 1 = couldn't cast < 0
+ * 2 = couldn't cast >= 0x80000000
+ * 4 = couldn't cast in argument expression list
+ */
+ #define CASTNEGFLOAT /**/
+ #if _P9P_OBJTYPE == 386
+ # define CASTFLAGS 2 /**/ /* config-skip */
+ #else
+ # define CASTFLAGS 0 /**/ /* config-skip */
+ #endif
+
+ /* HAS_CHOWN:
+ * This symbol, if defined, indicates that the chown routine is
+ * available.
+ */
+ #undef HAS_CHOWN /**/
+
+ /* HAS_CHROOT:
+ * This symbol, if defined, indicates that the chroot routine is
+ * available.
+ */
+ #undef HAS_CHROOT /**/
+
+ /* HAS_CHSIZE:
+ * This symbol, if defined, indicates that the chsize routine is available
+ * to truncate files. You might need a -lx to get this routine.
+ */
+ #undef HAS_CHSIZE /**/
+
+ /* VOID_CLOSEDIR:
+ * This symbol, if defined, indicates that the closedir() routine
+ * does not return a value.
+ */
+ #define VOID_CLOSEDIR /**/
+
+ /* HASCONST:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the const type. There is no need to actually test for that symbol
+ * within your programs. The mere use of the "const" keyword will
+ * trigger the necessary tests.
+ */
+ #define HASCONST /**/
+
+ /* HAS_CRYPT:
+ * This symbol, if defined, indicates that the crypt routine is available
+ * to encrypt passwords and the like.
+ */
+ /* #define HAS_CRYPT /**/
+
+ /* HAS_CUSERID:
+ * This symbol, if defined, indicates that the cuserid routine is
+ * available to get character login names.
+ */
+ #define HAS_CUSERID /**/
+
+ /* HAS_DBL_DIG:
+ * This symbol, if defined, indicates that this system's <float.h>
+ * or <limits.h> defines the symbol DBL_DIG, which is the number
+ * of significant digits in a double precision number. If this
+ * symbol is not defined, a guess of 15 is usually pretty good.
+ */
+ #undef HAS_DBL_DIG /* */
+
+ /* HAS_DIFFTIME:
+ * This symbol, if defined, indicates that the difftime routine is
+ * available.
+ */
+ #define HAS_DIFFTIME /**/
+
+ /* HAS_DLERROR:
+ * This symbol, if defined, indicates that the dlerror routine is
+ * available to return a string describing the last error that
+ * occurred from a call to dlopen(), dlclose() or dlsym().
+ */
+ #undef HAS_DLERROR /**/
+
+ /* HAS_DUP2:
+ * This symbol, if defined, indicates that the dup2 routine is
+ * available to duplicate file descriptors.
+ */
+ #define HAS_DUP2 /**/
+
+ /* HAS_FCHMOD:
+ * This symbol, if defined, indicates that the fchmod routine is available
+ * to change mode of opened files. If unavailable, use chmod().
+ */
+ #undef HAS_FCHMOD /**/
+
+ /* HAS_FCHOWN:
+ * This symbol, if defined, indicates that the fchown routine is available
+ * to change ownership of opened files. If unavailable, use chown().
+ */
+ #undef HAS_FCHOWN /**/
+
+ /* HAS_FCNTL:
+ * This symbol, if defined, indicates to the C program that
+ * the fcntl() function exists.
+ */
+ #define HAS_FCNTL /**/
+
+ /* HAS_FGETPOS:
+ * This symbol, if defined, indicates that the fgetpos routine is
+ * available to get the file position indicator, similar to ftell().
+ */
+ #define HAS_FGETPOS /**/
+
+ /* FLEXFILENAMES:
+ * This symbol, if defined, indicates that the system supports filenames
+ * longer than 14 characters.
+ */
+ #define FLEXFILENAMES /**/
+
+ /* HAS_FLOCK:
+ * This symbol, if defined, indicates that the flock routine is
+ * available to do file locking.
+ */
+ #undef HAS_FLOCK /**/
+
+ /* HAS_FORK:
+ * This symbol, if defined, indicates that the fork routine is
+ * available.
+ */
+ #define HAS_FORK /**/
+
+ /* HAS_FSETPOS:
+ * This symbol, if defined, indicates that the fsetpos routine is
+ * available to set the file position indicator, similar to fseek().
+ */
+ #define HAS_FSETPOS /**/
+
+ /* HAS_GETGROUPS:
+ * This symbol, if defined, indicates that the getgroups() routine is
+ * available to get the list of process groups. If unavailable, multiple
+ * groups are probably not supported.
+ */
+ #undef HAS_GETGROUPS /* config-skip */
+
+ /* HAS_GETHOSTENT:
+ * This symbol, if defined, indicates that the gethostent routine is
+ * available to lookup host names in some data base or other.
+ */
+ #undef HAS_GETHOSTENT /* config-skip */
+
+ /* HAS_UNAME:
+ * This symbol, if defined, indicates that the C program may use the
+ * uname() routine to derive the host name. See also HAS_GETHOSTNAME
+ * and PHOSTNAME.
+ */
+ #undef HAS_UNAME /**/
+
+ /* HAS_GETLOGIN:
+ * This symbol, if defined, indicates that the getlogin routine is
+ * available to get the login name.
+ */
+ #define HAS_GETLOGIN /**/
+
+ /* HAS_GETPGRP:
+ * This symbol, if defined, indicates that the getpgrp routine is
+ * available to get the current process group.
+ */
+ #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.
+ */
+ #undef HAS_GETPGRP2 /**/
+
+ /* HAS_GETPPID:
+ * This symbol, if defined, indicates that the getppid routine is
+ * available to get the parent process ID.
+ */
+ #define HAS_GETPPID /**/
+
+ /* HAS_GETPRIORITY:
+ * This symbol, if defined, indicates that the getpriority routine is
+ * available to get a process's priority.
+ */
+ #undef HAS_GETPRIORITY /**/
+
+ /* HAS_HTONL:
+ * This symbol, if defined, indicates that the htonl() routine (and
+ * friends htons() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+ /* HAS_HTONS:
+ * This symbol, if defined, indicates that the htons() routine (and
+ * friends htonl() ntohl() ntohs()) are available to do network
+ * order byte swapping.
+ */
+ /* HAS_NTOHL:
+ * This symbol, if defined, indicates that the ntohl() routine (and
+ * friends htonl() htons() ntohs()) are available to do network
+ * order byte swapping.
+ */
+ /* HAS_NTOHS:
+ * This symbol, if defined, indicates that the ntohs() routine (and
+ * friends htonl() htons() ntohl()) are available to do network
+ * order byte swapping.
+ */
+ #define HAS_HTONL /**/
+
+ #define HAS_HTONS /**/
+
+ #define HAS_NTOHL /**/
+
+ #define HAS_NTOHS /**/
+
+ /* HAS_ISASCII:
+ * This manifest constant lets the C program know that isascii
+ * is available.
+ */
+ #undef HAS_ISASCII /**/
+
+ /* HAS_KILLPG:
+ * This symbol, if defined, indicates that the killpg routine is available
+ * to kill process groups. If unavailable, you probably should use kill
+ * with a negative process number.
+ */
+ #undef HAS_KILLPG /**/
+
+ /* HAS_LINK:
+ * This symbol, if defined, indicates that the link routine is
+ * available to create hard links.
+ */
+ #define HAS_LINK /**/
+
+ /* HAS_LOCALECONV:
+ * This symbol, if defined, indicates that the localeconv routine is
+ * available for numeric and monetary formatting conventions.
+ */
+ #define HAS_LOCALECONV /**/
+
+ /* HAS_LOCKF:
+ * This symbol, if defined, indicates that the lockf routine is
+ * available to do file locking.
+ */
+ #undef HAS_LOCKF /**/
+
+ /* HAS_LSTAT:
+ * This symbol, if defined, indicates that the lstat routine is
+ * available to do file stats on symbolic links.
+ */
+ #define HAS_LSTAT /**/
+
+ /* HAS_MBLEN:
+ * This symbol, if defined, indicates that the mblen routine is available
+ * to find the number of bytes in a multibye character.
+ */
+ #define HAS_MBLEN /**/
+
+ /* HAS_MBSTOWCS:
+ * This symbol, if defined, indicates that the mbstowcs routine is
+ * available to covert a multibyte string into a wide character string.
+ */
+ #define HAS_MBSTOWCS /**/
+
+ /* HAS_MBTOWC:
+ * This symbol, if defined, indicates that the mbtowc routine is available
+ * to covert a multibyte to a wide character.
+ */
+ #define HAS_MBTOWC /**/
+
+ /* HAS_MEMCMP:
+ * This symbol, if defined, indicates that the memcmp routine is available
+ * to compare blocks of memory.
+ */
+ #define HAS_MEMCMP /**/
+
+ /* HAS_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy blocks of memory.
+ */
+ #define HAS_MEMCPY /**/
+
+ /* HAS_MEMMOVE:
+ * This symbol, if defined, indicates that the memmove routine is available
+ * to copy potentially overlapping blocks of memory. This should be used
+ * only when HAS_SAFE_BCOPY is not defined. If neither is there, roll your
+ * own version.
+ */
+ #define HAS_MEMMOVE /**/
+
+ /* HAS_MEMSET:
+ * This symbol, if defined, indicates that the memset routine is available
+ * to set blocks of memory.
+ */
+ #define HAS_MEMSET /**/
+
+ /* HAS_MKDIR:
+ * This symbol, if defined, indicates that the mkdir routine is available
+ * to create directories. Otherwise you should fork off a new process to
+ * exec /bin/mkdir.
+ */
+ #define HAS_MKDIR /**/
+
+ /* HAS_MKFIFO:
+ * This symbol, if defined, indicates that the mkfifo routine is
+ * available to create FIFOs. Otherwise, mknod should be able to
+ * do it for you. However, if mkfifo is there, mknod might require
+ * super-user privileges which mkfifo will not.
+ */
+ #define HAS_MKFIFO /**/
+
+ /* HAS_MKTIME:
+ * This symbol, if defined, indicates that the mktime routine is
+ * available.
+ */
+ #define HAS_MKTIME /**/
+
+ /* HAS_MSG:
+ * This symbol, if defined, indicates that the entire msg*(2) library is
+ * supported (IPC mechanism based on message queues).
+ */
+ #undef HAS_MSG /**/
+
+ /* HAS_NICE:
+ * This symbol, if defined, indicates that the nice routine is
+ * available.
+ */
+ #undef HAS_NICE /**/
+
+ /* HAS_OPEN3:
+ * This manifest constant lets the C program know that the three
+ * argument form of open(2) is available.
+ */
+ #define HAS_OPEN3 /**/
+
+ /* HAS_PATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given filename.
+ */
+ /* HAS_FPATHCONF:
+ * This symbol, if defined, indicates that pathconf() is available
+ * to determine file-system related limits and options associated
+ * with a given open file descriptor.
+ */
+ #define HAS_PATHCONF /**/
+ #define HAS_FPATHCONF /**/
+
+ /* HAS_PAUSE:
+ * This symbol, if defined, indicates that the pause routine is
+ * available to suspend a process until a signal is received.
+ */
+ #define HAS_PAUSE /**/
+
+ /* HAS_PIPE:
+ * This symbol, if defined, indicates that the pipe routine is
+ * available to create an inter-process channel.
+ */
+ #define HAS_PIPE /**/
+
+ /* HAS_POLL:
+ * This symbol, if defined, indicates that the poll routine is
+ * available to poll active file descriptors.
+ */
+ #undef HAS_POLL /**/
+
+ /* HAS_READDIR:
+ * This symbol, if defined, indicates that the readdir routine is
+ * available to read directory entries. You may have to include
+ * <dirent.h>. See I_DIRENT.
+ */
+ #define HAS_READDIR /**/
+
+ /* HAS_SEEKDIR:
+ * This symbol, if defined, indicates that the seekdir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+ #undef HAS_SEEKDIR /**/
+
+ /* HAS_TELLDIR:
+ * This symbol, if defined, indicates that the telldir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+ #undef HAS_TELLDIR /**/
+
+ /* HAS_REWINDDIR:
+ * This symbol, if defined, indicates that the rewinddir routine is
+ * available. You may have to include <dirent.h>. See I_DIRENT.
+ */
+ #define HAS_REWINDDIR /**/
+
+ /* HAS_READLINK:
+ * This symbol, if defined, indicates that the readlink routine is
+ * available to read the value of a symbolic link.
+ */
+ #define HAS_READLINK /**/
+
+ /* HAS_RENAME:
+ * This symbol, if defined, indicates that the rename routine is available
+ * to rename files. Otherwise you should do the unlink(), link(), unlink()
+ * trick.
+ */
+ #define HAS_RENAME /**/
+
+ /* HAS_RMDIR:
+ * This symbol, if defined, indicates that the rmdir routine is
+ * available to remove directories. Otherwise you should fork off a
+ * new process to exec /bin/rmdir.
+ */
+ #define HAS_RMDIR /**/
+
+ /* HAS_SAFE_BCOPY:
+ * This symbol, if defined, indicates that the bcopy routine is available
+ * to copy potentially overlapping memory blocks. Otherwise you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+ #undef HAS_SAFE_BCOPY /**/
+
+ /* HAS_SAFE_MEMCPY:
+ * This symbol, if defined, indicates that the memcpy routine is available
+ * to copy potentially overlapping memory blocks. Otherwise you should
+ * probably use memmove() or memcpy(). If neither is defined, roll your
+ * own version.
+ */
+ #undef HAS_SAFE_MEMCPY /**/
+
+ /* HAS_SELECT:
+ * This symbol, if defined, indicates that the select routine is
+ * available to select active file descriptors. If the timeout field
+ * is used, <sys/time.h> may need to be included.
+ */
+ #define HAS_SELECT /* config-skip */
+
+ /* HAS_SEM:
+ * This symbol, if defined, indicates that the entire sem*(2) library is
+ * supported.
+ */
+ #undef HAS_SEM /**/
+
+ /* HAS_SETEGID:
+ * This symbol, if defined, indicates that the setegid routine is available
+ * to change the effective gid of the current program.
+ */
+ #undef HAS_SETEGID /**/
+
+ /* HAS_SETEUID:
+ * This symbol, if defined, indicates that the seteuid routine is available
+ * to change the effective uid of the current program.
+ */
+ #undef HAS_SETEUID /**/
+
+ /* HAS_SETLINEBUF:
+ * This symbol, if defined, indicates that the setlinebuf routine is
+ * available to change stderr or stdout from block-buffered or unbuffered
+ * to a line-buffered mode.
+ */
+ #undef HAS_SETLINEBUF /**/
+
+ /* HAS_SETLOCALE:
+ * This symbol, if defined, indicates that the setlocale routine is
+ * available to handle locale-specific ctype implementations.
+ */
+ #define HAS_SETLOCALE /**/
+
+ /* HAS_SETPGID:
+ * This symbol, if defined, indicates that the setpgid routine is
+ * available to set process group ID.
+ */
+ #define HAS_SETPGID /**/
+
+ /* HAS_SETPGRP:
+ * This symbol, if defined, indicates that the setpgrp routine is
+ * available to set the current process group.
+ */
+ /* USE_BSDPGRP:
+ * This symbol, if defined, indicates that the BSD notion of process
+ * group is to be used. For instance, you have to say setpgrp(pid, pgrp)
+ * instead of the USG setpgrp().
+ */
+ #undef HAS_SETPGRP /**/
+ #undef 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.
+ */
+ #undef HAS_SETPGRP2 /**/
+
+ /* HAS_SETPRIORITY:
+ * This symbol, if defined, indicates that the setpriority routine is
+ * available to set a process's priority.
+ */
+ #undef HAS_SETPRIORITY /**/
+
+ /* HAS_SETREGID:
+ * This symbol, if defined, indicates that the setregid routine is
+ * available to change the real and effective gid of the current
+ * process.
+ */
+ /* HAS_SETRESGID:
+ * This symbol, if defined, indicates that the setresgid routine is
+ * available to change the real, effective and saved gid of the current
+ * process.
+ */
+ #undef HAS_SETREGID /**/
+ #undef HAS_SETRESGID /**/
+
+ /* HAS_SETREUID:
+ * This symbol, if defined, indicates that the setreuid routine is
+ * available to change the real and effective uid of the current
+ * process.
+ */
+ /* HAS_SETRESUID:
+ * This symbol, if defined, indicates that the setresuid routine is
+ * available to change the real, effective and saved uid of the current
+ * process.
+ */
+ #undef HAS_SETREUID /**/
+ #undef HAS_SETRESUID /**/
+
+ /* HAS_SETRGID:
+ * This symbol, if defined, indicates that the setrgid routine is available
+ * to change the real gid of the current program.
+ */
+ #undef HAS_SETRGID /**/
+
+ /* HAS_SETRUID:
+ * This symbol, if defined, indicates that the setruid routine is available
+ * to change the real uid of the current program.
+ */
+ #undef HAS_SETRUID /**/
+
+ /* HAS_SETSID:
+ * This symbol, if defined, indicates that the setsid routine is
+ * available to set the process group ID.
+ */
+ #define HAS_SETSID /**/
+
+ /* HAS_SHM:
+ * This symbol, if defined, indicates that the entire shm*(2) library is
+ * supported.
+ */
+ #undef HAS_SHM /**/
+
+ /* Shmat_t:
+ * This symbol holds the return type of the shmat() system call.
+ * Usually set to 'void *' or 'char *'.
+ */
+ /* HAS_SHMAT_PROTOTYPE:
+ * This symbol, if defined, indicates that the sys/shm.h includes
+ * a prototype for shmat(). Otherwise, it is up to the program to
+ * guess one. Shmat_t shmat _((int, Shmat_t, int)) is a good guess,
+ * but not always right so it should be emitted by the program only
+ * when HAS_SHMAT_PROTOTYPE is not defined to avoid conflicting defs.
+ */
+ #undef Shmat_t /* config-skip */
+ #undef HAS_SHMAT_PROTOTYPE /**/
+
+ /* HAS_SIGACTION:
+ * This symbol, if defined, indicates that Vr4's sigaction() routine
+ * is available.
+ */
+ #define HAS_SIGACTION /**/
+
+ /* HAS_SOCKET:
+ * This symbol, if defined, indicates that the BSD socket interface is
+ * supported.
+ */
+ /* HAS_SOCKETPAIR:
+ * This symbol, if defined, indicates that the BSD socketpair() call is
+ * supported.
+ */
+ #define HAS_SOCKET /**/
+ #define HAS_SOCKETPAIR /**/
+
+ /* USE_STAT_BLOCKS:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_blksize and st_blocks.
+ */
+ #undef USE_STAT_BLOCKS /**/
+
+ /* USE_STDIO_PTR:
+ * This symbol is defined if the _ptr and _cnt fields (or similar)
+ * of the stdio FILE structure can be used to access the stdio buffer
+ * for a file handle. If this is defined, then the FILE_ptr(fp)
+ * and FILE_cnt(fp) macros will also be defined and should be used
+ * to access these fields.
+ */
+ /* USE_STDIO_BASE:
+ * This symbol is defined if the _base field (or similar) of the
+ * stdio FILE structure can be used to access the stdio buffer for
+ * a file handle. If this is defined, then the FILE_base(fp) macro
+ * will also be defined and should be used to access this field.
+ * Also, the FILE_bufsiz(fp) macro will be defined and should be used
+ * to determine the number of bytes in the buffer. USE_STDIO_BASE
+ * will never be defined unless USE_STDIO_PTR is.
+ */
+ #undef USE_STDIO_PTR /**/
+ #undef USE_STDIO_BASE /**/
+
+ /* FILE_ptr:
+ * This macro is used to access the _ptr field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+ /* STDIO_PTR_LVALUE:
+ * This symbol is defined if the FILE_ptr macro can be used as an
+ * lvalue.
+ */
+ /* FILE_cnt:
+ * This macro is used to access the _cnt field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_PTR is defined.
+ */
+ /* STDIO_CNT_LVALUE:
+ * This symbol is defined if the FILE_cnt macro can be used as an
+ * lvalue.
+ */
+ #ifdef USE_STDIO_PTR
+ #define FILE_ptr(fp) ((fp)->_ptr)
+ #define STDIO_PTR_LVALUE /**/
+ #define FILE_cnt(fp) ((fp)->_cnt)
+ #define STDIO_CNT_LVALUE /**/
+ #endif
+
+ /* FILE_base:
+ * This macro is used to access the _base field (or equivalent) of the
+ * FILE structure pointed to by its argument. This macro will always be
+ * defined if USE_STDIO_BASE is defined.
+ */
+ /* FILE_bufsiz:
+ * This macro is used to determine the number of bytes in the I/O
+ * buffer pointed to by _base field (or equivalent) of the FILE
+ * structure pointed to its argument. This macro will always be defined
+ * if USE_STDIO_BASE is defined.
+ */
+ #ifdef USE_STDIO_BASE
+ #define FILE_base(fp) ((fp)->_base)
+ #define FILE_bufsiz(fp) ((fp)->_cnt + (fp)->_ptr - (fp)->_base)
+ #endif
+
+ /* HAS_STRCHR:
+ * This symbol is defined to indicate that the strchr()/strrchr()
+ * functions are available for string searching. If not, try the
+ * index()/rindex() pair.
+ */
+ /* HAS_INDEX:
+ * This symbol is defined to indicate that the index()/rindex()
+ * functions are available for string searching.
+ */
+ #define HAS_STRCHR /**/
+ #undef HAS_INDEX /**/
+
+ /* HAS_STRCOLL:
+ * This symbol, if defined, indicates that the strcoll routine is
+ * available to compare strings using collating information.
+ */
+ #define HAS_STRCOLL /**/
+
+ /* USE_STRUCT_COPY:
+ * This symbol, if defined, indicates that this C compiler knows how
+ * to copy structures. If undefined, you'll need to use a block copy
+ * routine of some sort instead.
+ */
+ #define USE_STRUCT_COPY /**/
+
+ /* HAS_STRERROR:
+ * This symbol, if defined, indicates that the strerror routine is
+ * available to translate error numbers to strings. See the writeup
+ * of Strerror() in this file before you try to define your own.
+ */
+ /* HAS_SYS_ERRLIST:
+ * This symbol, if defined, indicates that the sys_errlist array is
+ * available to translate error numbers to strings. The extern int
+ * sys_nerr gives the size of that table.
+ */
+ /* Strerror:
+ * This preprocessor symbol is defined as a macro if strerror() is
+ * not available to translate error numbers to strings but sys_errlist[]
+ * array is there.
+ */
+ #define HAS_STRERROR /**/
+ #define HAS_SYS_ERRLIST /**/
+ #define Strerror(e) strerror(e)
+
+ /* HAS_STRXFRM:
+ * This symbol, if defined, indicates that the strxfrm() routine is
+ * available to transform strings.
+ */
+ #define HAS_STRXFRM /**/
+
+ /* HAS_SYMLINK:
+ * This symbol, if defined, indicates that the symlink routine is available
+ * to create symbolic links.
+ */
+ #define HAS_SYMLINK /**/
+
+ /* HAS_SYSCALL:
+ * This symbol, if defined, indicates that the syscall routine is
+ * available to call arbitrary system calls. If undefined, that's tough.
+ */
+ #undef HAS_SYSCALL /**/
+
+ /* HAS_SYSCONF:
+ * This symbol, if defined, indicates that sysconf() is available
+ * to determine system related limits and options.
+ */
+ #define HAS_SYSCONF /**/
+
+ /* HAS_SYSTEM:
+ * This symbol, if defined, indicates that the system routine is
+ * available to issue a shell command.
+ */
+ #define HAS_SYSTEM /**/
+
+ /* HAS_TCGETPGRP:
+ * This symbol, if defined, indicates that the tcgetpgrp routine is
+ * available to get foreground process group ID.
+ */
+ #define HAS_TCGETPGRP /**/
+
+ /* HAS_TCSETPGRP:
+ * This symbol, if defined, indicates that the tcsetpgrp routine is
+ * available to set foreground process group ID.
+ */
+ #define HAS_TCSETPGRP /**/
+
+ /* Time_t:
+ * This symbol holds the type returned by time(). It can be long,
+ * or time_t on BSD sites (in which case <sys/types.h> should be
+ * included).
+ */
+ #define Time_t time_t /* Time type */
+
+ /* HAS_TIMES:
+ * This symbol, if defined, indicates that the times() routine exists.
+ * Note that this became obsolete on some systems (SUNOS), which now
+ * use getrusage(). It may be necessary to include <sys/times.h>.
+ */
+ #define HAS_TIMES /**/
+
+ /* HAS_TRUNCATE:
+ * This symbol, if defined, indicates that the truncate routine is
+ * available to truncate files.
+ */
+ #undef HAS_TRUNCATE /**/
+
+ /* HAS_TZNAME:
+ * This symbol, if defined, indicates that the tzname[] array is
+ * available to access timezone names.
+ */
+ #define HAS_TZNAME /**/
+
+ /* HAS_UMASK:
+ * This symbol, if defined, indicates that the umask routine is
+ * available to set and get the value of the file creation mask.
+ */
+ #define HAS_UMASK /**/
+
+ /* HAS_VFORK:
+ * This symbol, if defined, indicates that vfork() exists.
+ */
+ #undef HAS_VFORK /**/
+
+ /* Signal_t:
+ * This symbol's value is either "void" or "int", corresponding to the
+ * appropriate return type of a signal handler. Thus, you can declare
+ * a signal handler using "Signal_t (*handler)()", and define the
+ * handler using "Signal_t handler(sig)".
+ */
+ #define Signal_t void /* Signal handler's return type */
+
+ /* HASVOLATILE:
+ * This symbol, if defined, indicates that this C compiler knows about
+ * the volatile declaration.
+ */
+ #define HASVOLATILE /**/
+ #ifndef HASVOLATILE
+ #define volatile /* config-skip */
+ #endif
+
+ /* HAS_VPRINTF:
+ * This symbol, if defined, indicates that the vprintf routine is available
+ * to printf with a pointer to an argument list. If unavailable, you
+ * may need to write your own, probably in terms of _doprnt().
+ */
+ /* USE_CHAR_VSPRINTF:
+ * This symbol is defined if this system has vsprintf() returning type
+ * (char*). The trend seems to be to declare it as "int vsprintf()". It
+ * is up to the package author to declare vsprintf correctly based on the
+ * symbol.
+ */
+ #define HAS_VPRINTF /**/
+ #define USE_CHAR_VSPRINTF /**/
+
+ /* HAS_WAIT4:
+ * This symbol, if defined, indicates that wait4() exists.
+ */
+ #undef HAS_WAIT4 /**/
+
+ /* HAS_WAITPID:
+ * This symbol, if defined, indicates that the waitpid routine is
+ * available to wait for child process.
+ */
+ #undef HAS_WAITPID /**/
+
+ /* HAS_WCSTOMBS:
+ * This symbol, if defined, indicates that the wcstombs routine is
+ * available to convert wide character strings to multibyte strings.
+ */
+ #define HAS_WCSTOMBS /**/
+
+ /* HAS_WCTOMB:
+ * This symbol, if defined, indicates that the wctomb routine is available
+ * to covert a wide character to a multibyte.
+ */
+ #define HAS_WCTOMB /**/
+
+ /* Fpos_t:
+ * This symbol holds the type used to declare file positions in libc.
+ * It can be fpos_t, long, uint, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+ #define Fpos_t fpos_t /* File position type */
+
+ /* Gid_t:
+ * This symbol holds the return type of getgid() and the type of
+ * argument to setrgid() and related functions. Typically,
+ * it is the type of group ids in the kernel. It can be int, ushort,
+ * uid_t, etc... It may be necessary to include <sys/types.h> to get
+ * any typedef'ed information.
+ */
+ #define Gid_t gid_t /* config-skip */
+
+ /* Groups_t:
+ * This symbol holds the type used for the second argument to
+ * getgroups(). Usually, this is the same of gidtype, but
+ * sometimes it isn't. It can be int, ushort, uid_t, etc...
+ * It may be necessary to include <sys/types.h> to get any
+ * typedef'ed information. This is only required if you have
+ * getgroups().
+ */
+ #ifdef HAS_GETGROUPS
+ #define Groups_t gid_t /* Type for 2nd arg to getgroups() */
+ #endif
+
+ /* DB_Prefix_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is u_int32_t.
+ */
+ /* DB_Hash_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is size_t.
+ */
+ #define DB_Hash_t int /**/
+ #define DB_Prefix_t int /**/
+
+ /* I_DIRENT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <dirent.h>. Using this symbol also triggers the definition
+ * of the Direntry_t define which ends up being 'struct dirent' or
+ * 'struct direct' depending on the availability of <dirent.h>.
+ */
+ /* DIRNAMLEN:
+ * This symbol, if defined, indicates to the C program that the length
+ * of directory entry names is provided by a d_namlen field. Otherwise
+ * you need to do strlen() on the d_name field.
+ */
+ /* Direntry_t:
+ * This symbol is set to 'struct direct' or 'struct dirent' depending on
+ * whether dirent is available or not. You should use this pseudo type to
+ * portably declare your directory entries.
+ */
+ #define I_DIRENT /**/
+ #undef DIRNAMLEN /**/
+ #define Direntry_t struct dirent
+
+ /* I_DLFCN:
+ * This symbol, if defined, indicates that <dlfcn.h> exists and should
+ * be included.
+ */
+ #undef I_DLFCN /**/
+
+ /* I_FCNTL:
+ * This manifest constant tells the C program to include <fcntl.h>.
+ */
+ #define I_FCNTL /**/
+
+ /* I_FLOAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <float.h> to get definition of symbols like DBL_MAX or
+ * DBL_MIN, i.e. machine dependent floating point values.
+ */
+ #define I_FLOAT /**/
+
+ /* I_GRP:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <grp.h>.
+ */
+ #define I_GRP /**/
+
+ /* I_LIMITS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <limits.h> to get definition of symbols like WORD_BIT or
+ * LONG_MAX, i.e. machine dependant limitations.
+ */
+ #define I_LIMITS /**/
+
+ /* I_MATH:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <math.h>.
+ */
+ #define I_MATH /**/
+
+ /* I_MEMORY:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <memory.h>.
+ */
+ #undef I_MEMORY /**/
+
+ /* I_NDBM:
+ * This symbol, if defined, indicates that <ndbm.h> exists and should
+ * be included.
+ */
+ #undef I_NDBM /**/
+
+ /* I_NET_ERRNO:
+ * This symbol, if defined, indicates that <net/errno.h> exists and
+ * should be included.
+ */
+ #undef I_NET_ERRNO /* config-skip */
+
+ /* I_NETINET_IN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <netinet/in.h>. Otherwise, you may try <sys/in.h>.
+ */
+ #define I_NETINET_IN /* config-skip */
+
+ /* I_PWD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <pwd.h>.
+ */
+ /* PWQUOTA:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_quota.
+ */
+ /* PWAGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_age.
+ */
+ /* PWCHANGE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_change.
+ */
+ /* PWCLASS:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_class.
+ */
+ /* PWEXPIRE:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_expire.
+ */
+ /* PWCOMMENT:
+ * This symbol, if defined, indicates to the C program that struct passwd
+ * contains pw_comment.
+ */
+ #define I_PWD /**/
+ #undef PWQUOTA /**/
+ #undef PWAGE /**/
+ #undef PWCHANGE /**/
+ #undef PWCLASS /**/
+ #undef PWEXPIRE /**/
+ #undef PWCOMMENT /**/
+
+ /* I_STDDEF:
+ * This symbol, if defined, indicates that <stddef.h> exists and should
+ * be included.
+ */
+ #define I_STDDEF /**/
+
+ /* I_STDLIB:
+ * This symbol, if defined, indicates that <stdlib.h> exists and should
+ * be included.
+ */
+ #define I_STDLIB /**/
+
+ /* I_STRING:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <string.h> (USG systems) instead of <strings.h> (BSD systems).
+ */
+ #define I_STRING /**/
+
+ /* I_SYS_DIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/dir.h>.
+ */
+ #undef I_SYS_DIR /**/
+
+ /* I_SYS_FILE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/file.h> to get definition of R_OK and friends.
+ */
+ #undef I_SYS_FILE /**/
+
+ /* I_SYS_IOCTL:
+ * This symbol, if defined, indicates that <sys/ioctl.h> exists and should
+ * be included. Otherwise, include <sgtty.h> or <termio.h>.
+ */
+ #define I_SYS_IOCTL /**/
+
+ /* I_SYS_NDIR:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/ndir.h>.
+ */
+ #undef I_SYS_NDIR /**/
+
+ /* I_SYS_PARAM:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/param.h>.
+ */
+ #define I_SYS_PARAM /**/
+
+ /* Plan 9: file position in Plan 9 is <select.h> */
+ /* I_SYS_SELECT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/select.h> in order to get definition of struct timeval.
+ */
+ #undef I_SYS_SELECT /**/
+
+ /* I_SYS_TIMES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/times.h>.
+ */
+ #define I_SYS_TIMES /**/
+
+ /* I_SYS_TYPES:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/types.h>.
+ */
+ #define I_SYS_TYPES /**/
+
+ /* I_SYS_UN:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/un.h> to get UNIX domain socket definitions.
+ */
+ #define I_SYS_UN /**/
+
+ /* I_TERMIO:
+ * This symbol, if defined, indicates that the program should include
+ * <termio.h> rather than <sgtty.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+ /* I_TERMIOS:
+ * This symbol, if defined, indicates that the program should include
+ * the POSIX termios.h rather than sgtty.h or termio.h.
+ * There are also differences in the ioctl() calls that depend on the
+ * value of this symbol.
+ */
+ /* I_SGTTY:
+ * This symbol, if defined, indicates that the program should include
+ * <sgtty.h> rather than <termio.h>. There are also differences in
+ * the ioctl() calls that depend on the value of this symbol.
+ */
+ #undef I_TERMIO /**/
+ #define I_TERMIOS /**/
+ #undef I_SGTTY /**/
+
+ /* Plan 9: P9 has both <time.h> and <sys/time.h> */
+ /* I_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <time.h>.
+ */
+ /* I_SYS_TIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h>.
+ */
+ /* I_SYS_TIME_KERNEL:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/time.h> with KERNEL defined.
+ */
+ #define I_TIME /**/
+ #define I_SYS_TIME /**/
+ #undef I_SYS_TIME_KERNEL /**/
+
+ /* I_UNISTD:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <unistd.h>.
+ */
+ #define I_UNISTD /**/
+
+ /* I_UTIME:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <utime.h>.
+ */
+ #define I_UTIME /**/
+
+ /* I_VFORK:
+ * This symbol, if defined, indicates to the C program that it should
+ * include vfork.h.
+ */
+ #undef I_VFORK /**/
+
+ /* Off_t:
+ * This symbol holds the type used to declare offsets in the kernel.
+ * It can be int, long, off_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+ #define Off_t off_t /* <offset> type */
+
+ /* Mode_t:
+ * This symbol holds the type used to declare file modes
+ * for systems calls. It is usually mode_t, but may be
+ * int or unsigned short. It may be necessary to include <sys/types.h>
+ * to get any typedef'ed information.
+ */
+ #define Mode_t mode_t /* file mode parameter for system calls */
+
+ /* CAN_PROTOTYPE:
+ * If defined, this macro indicates that the C compiler can handle
+ * function prototypes.
+ */
+ /* _:
+ * This macro is used to declare function parameters for folks who want
+ * to make declarations with prototypes using a different style than
+ * the above macros. Use double parentheses. For example:
+ *
+ * int main _((int argc, char *argv[]));
+ */
+ #define CAN_PROTOTYPE /**/
+ #ifdef CAN_PROTOTYPE
+ #define _(args) args /* config-skip */
+ #else
+ #define _(args) () /* config-skip */
+ #endif
+
+ /* RANDBITS:
+ * This symbol contains the number of bits of random number the rand()
+ * function produces. Usual values are 15, 16, and 31.
+ */
+ #define RANDBITS 15 /**/
+
+ /* SCRIPTDIR:
+ * This symbol holds the name of the directory in which the user wants
+ * to put publicly executable scripts for the package in question. It
+ * is often a directory that is mounted across diverse architectures.
+ * Programs must be prepared to deal with ~name expansion.
+ */
+ #define SCRIPTDIR "/bin"
+
+ /* Select_fd_set_t:
+ * This symbol holds the type used for the 2nd, 3rd, and 4th
+ * arguments to select. Usually, this is 'fd_set *', if HAS_FD_SET
+ * is defined, and 'int *' otherwise. This is only useful if you
+ * have select(), of course.
+ */
+ #define Select_fd_set_t fd_set * /**/
+
+ /* Size_t:
+ * This symbol holds the type used to declare length parameters
+ * for string functions. It is usually size_t, but may be
+ * unsigned long, int, etc. It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+ #define Size_t size_t /* length paramater for string functions */
+
+ /* SSize_t:
+ * This symbol holds the type used by functions that return
+ * a count of bytes or an error condition. It must be a signed type.
+ * It is usually ssize_t, but may be long or int, etc.
+ * It may be necessary to include <sys/types.h> or <unistd.h>
+ * to get any typedef'ed information.
+ * We will pick a type such that sizeof(SSize_t) == sizeof(Size_t).
+ */
+ #define SSize_t ssize_t /* signed count of bytes */
+
+ /* STDCHAR:
+ * This symbol is defined to be the type of char used in stdio.h.
+ * It has the values "unsigned char" or "char".
+ */
+ #define STDCHAR char /**/
+
+ /* Uid_t:
+ * This symbol holds the type used to declare user ids in the kernel.
+ * It can be int, ushort, uid_t, etc... It may be necessary to include
+ * <sys/types.h> to get any typedef'ed information.
+ */
+ #define Uid_t uid_t /* UID type */
+
+ /* PLAN9:
+ This symbol, if defined, indicates that the program is running under the
+ * Plan 9 operating system.
+ */
+ #define PLAN9 /**/
+
+ #define OSNAME "plan9"
+
+ #define BIN_SH "/bin/rc"
+
+ /* MYMALLOC:
+ * This symbol, if defined, indicates that we're using our own malloc.
+ */
+ #undef MYMALLOC /**/
+
+
+ #undef VMS
+
+ /* LOC_SED:
+ * This symbol holds the complete pathname to the sed program.
+ */
+ #define LOC_SED "/bin/sed" /**/
+
+ /* ARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of ARCHLIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+ #define ARCHLIB_EXP "/_P9P_OBJTYPE/lib/perl/_P9P_VERSION"
+
+ /* BYTEORDER:
+ * This symbol hold the hexadecimal constant defined in byteorder,
+ * i.e. 0x1234 or 0x4321, etc...
+ */
+ #define BYTEORDER 0x1234 /* large digits for MSB */
+
+ /* CSH:
+ * This symbol, if defined, indicates that the C-shell exists.
+ * If defined, contains the full pathname of csh.
+ */
+ #undef CSH /**/
+
+ /* DLSYM_NEEDS_UNDERSCORE:
+ * This symbol, if defined, indicates that we need to prepend an
+ * underscore to the symbol name before calling dlsym(). This only
+ * makes sense if you *have* dlsym, which we will presume is the
+ * case if you're using dl_dlopen.xs.
+ */
+ #undef DLSYM_NEEDS_UNDERSCORE /* */
+
+ /* SETUID_SCRIPTS_ARE_SECURE_NOW:
+ * This symbol, if defined, indicates that the bug that prevents
+ * setuid scripts from being secure is not present in this kernel.
+ */
+ /* DOSUID:
+ * This symbol, if defined, indicates that the C program should
+ * check the script that it is executing for setuid/setgid bits, and
+ * attempt to emulate setuid/setgid on systems that have disabled
+ * setuid #! scripts because the kernel can't do it securely.
+ * It is up to the package designer to make sure that this emulation
+ * is done securely. Among other things, it should do an fstat on
+ * the script it just opened to make sure it really is a setuid/setgid
+ * script, it should make sure the arguments passed correspond exactly
+ * to the argument on the #! line, and it should not trust any
+ * subprocesses to which it must pass the filename rather than the
+ * file descriptor of the script to be executed.
+ */
+ #define SETUID_SCRIPTS_ARE_SECURE_NOW /**/
+ #undef DOSUID /**/
+
+ /* Gconvert:
+ * This preprocessor macro is defined to convert a floating point
+ * number to a string without a trailing decimal point. This
+ * emulates the behavior of sprintf("%g"), but is sometimes much more
+ * efficient. If gconvert() is not available, but gcvt() drops the
+ * trailing decimal point, then gcvt() is used. If all else fails,
+ * a macro using sprintf("%g") is used. Arguments for the Gconvert
+ * macro are: value, number of digits, whether trailing zeros should
+ * be retained, and the output buffer.
+ * Possible values are:
+ * d_Gconvert='gconvert((x),(n),(t),(b))'
+ * d_Gconvert='gcvt((x),(n),(b))'
+ * d_Gconvert='sprintf((b),"%.*g",(n),(x))'
+ * The last two assume trailing zeros should not be kept.
+ */
+ #define Gconvert(x,n,t,b) sprintf((b),"%.*g",(n),(x))
+
+ /* Sigjmp_buf:
+ * This is the buffer type to be used with Sigsetjmp and Siglongjmp.
+ */
+ /* Sigsetjmp:
+ * This macro is used in the same way as sigsetjmp(), but will invoke
+ * traditional setjmp() if sigsetjmp isn't available.
+ */
+ /* Siglongjmp:
+ * This macro is used in the same way as siglongjmp(), but will invoke
+ * traditional longjmp() if siglongjmp isn't available.
+ */
+ #define HAS_SIGSETJMP /**/ /* config-skip */
+ #define Sigjmp_buf sigjmp_buf /* config-skip */
+ #define Sigsetjmp(buf,save_mask) sigsetjmp(buf,save_mask) /* config-skip */
+ #define Siglongjmp(buf,retval) siglongjmp(buf,retval) /* config-skip */
+
+ /* USE_DYNAMIC_LOADING:
+ * This symbol, if defined, indicates that dynamic loading of
+ * some sort is available.
+ */
+ #undef USE_DYNAMIC_LOADING /**/
+
+ /* I_DBM:
+ * This symbol, if defined, indicates that <dbm.h> exists and should
+ * be included.
+ */
+ /* I_RPCSVC_DBM:
+ * This symbol, if defined, indicates that <rpcsvc/dbm.h> exists and
+ * should be included.
+ */
+ #undef I_DBM /**/
+ #undef I_RPCSVC_DBM /**/
+
+ /* I_LOCALE:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <locale.h>.
+ */
+ #define I_LOCALE /**/
+
+ /* I_SYS_STAT:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <sys/stat.h>.
+ */
+ #define I_SYS_STAT /**/
+
+ /* I_STDARG:
+ * This symbol, if defined, indicates that <stdarg.h> exists and should
+ * be included.
+ */
+ /* I_VARARGS:
+ * This symbol, if defined, indicates to the C program that it should
+ * include <varargs.h>.
+ */
+ #define I_STDARG /**/
+ #undef I_VARARGS /**/
+
+ /* INTSIZE:
+ * This symbol contains the size of an int, so that the C preprocessor
+ * can make decisions based on it.
+ */
+ #define INTSIZE 4 /**/
+
+ /* Free_t:
+ * This variable contains the return type of free(). It is usually
+ * void, but occasionally int.
+ */
+ /* Malloc_t:
+ * This symbol is the type of pointer returned by malloc and realloc.
+ */
+ #define Malloc_t void * /**/
+ #define Free_t void /**/
+
+ /* VAL_O_NONBLOCK:
+ * This symbol is to be used during open() or fcntl(F_SETFL) to turn on
+ * non-blocking I/O for the file descriptor. Note that there is no way
+ * back, i.e. you cannot turn it blocking again this way. If you wish to
+ * alternatively switch between blocking and non-blocking, use the
+ * ioctl(FIOSNBIO) call instead, but that is not supported by all devices.
+ */
+ /* VAL_EAGAIN:
+ * This symbol holds the errno error code set by read() when no data was
+ * present on the non-blocking file descriptor.
+ */
+ /* RD_NODATA:
+ * This symbol holds the return code from read() when no data is present
+ * on the non-blocking file descriptor. Be careful! If EOF_NONBLOCK is
+ * not defined, then you can't distinguish between no data and EOF by
+ * issuing a read(). You'll have to find another way to tell for sure!
+ */
+ /* EOF_NONBLOCK:
+ * This symbol, if defined, indicates to the C program that a read() on
+ * a non-blocking file descriptor will return 0 on EOF, and not the value
+ * held in RD_NODATA (-1 usually, in that case!).
+ */
+ #define VAL_O_NONBLOCK O_NONBLOCK
+ #define VAL_EAGAIN EAGAIN
+ #define RD_NODATA -1
+ #define EOF_NONBLOCK
+
+ /* OLDARCHLIB_EXP:
+ * This symbol contains the ~name expanded version of OLDARCHLIB, to be
+ * used in programs that are not prepared to deal with ~ expansion at
+ * run-time.
+ */
+ #undef OLDARCHLIB_EXP /**/
+
+ /* 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" /* */
+
+ /* SIG_NAME:
+ * This symbol contains a list of signal names in order of
+ * signal number. This is intended
+ * to be used as a static array initialization, like this:
+ * char *sig_name[] = { SIG_NAME };
+ * The signals in the list are separated with commas, and each signal
+ * is surrounded by double quotes. There is no leading SIG in the signal
+ * name, i.e. SIGQUIT is known as "QUIT".
+ * Gaps in the signal numbers (up to NSIG) are filled in with NUMnn,
+ * etc., where nn is the actual signal number (e.g. NUM37).
+ * The signal number for sig_name[i] is stored in sig_num[i].
+ * The last element is 0 to terminate the list with a NULL. This
+ * corresponds to the 0 at the end of the sig_num list.
+ */
+ /* SIG_NUM:
+ * This symbol contains a list of signal numbers, in the same order as the
+ * SIG_NAME list. It is suitable for static array initialization, as in:
+ * int sig_num[] = { SIG_NUM };
+ * The signals in the list are separated with commas, and the indices
+ * within that list and the SIG_NAME list match, so it's easy to compute
+ * the signal name from a number or vice versa at the price of a small
+ * dynamic linear lookup.
+ * Duplicates are allowed, but are moved to the end of the list.
+ * The signal number corresponding to sig_name[i] is sig_number[i].
+ * if (i < NSIG) then sig_number[i] == i.
+ * The last element is 0, corresponding to the 0 at the end of
+ * the sig_name list.
+ */
+ #define SIG_NAME "ZERO","HUP","INT","QUIT","ILL","ABRT","FPE","KILL","SEGV","PIPE","ALRM","TERM","USR1","USR2","CHLD","CONT","STOP","TSTP","TTIN","TTOU",0 /* config-skip */
+ #define SIG_NUM 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,0 /* config-skip */
+
+ /* SITELIB_EXP:
+ * This symbol contains the ~name expanded version of SITELIB, to be used
+ * in programs that are not prepared to deal with ~ expansion at run-time.
+ */
+ #define SITELIB_EXP "/sys/lib/perl/site_perl" /* */
+
+ /* 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" /* */
+
+ /* STARTPERL:
+ * This variable contains the string to put in front of a perl
+ * script to make sure (one hopes) that it runs with perl and not
+ * some shell.
+ */
+ #define STARTPERL "#!/bin/perl" /**/
+
+ /* VOIDFLAGS:
+ * This symbol indicates how much support of the void type is given by this
+ * compiler. What various bits mean:
+ *
+ * 1 = supports declaration of void
+ * 2 = supports arrays of pointers to functions returning void
+ * 4 = supports comparisons between pointers to void functions and
+ * addresses of void functions
+ * 8 = suports declaration of generic void pointers
+ *
+ * The package designer should define VOIDUSED to indicate the requirements
+ * of the package. This can be done either by #defining VOIDUSED before
+ * including config.h, or by defining defvoidused in Myinit.U. If the
+ * latter approach is taken, only those flags will be tested. If the
+ * level of void support necessary is not present, defines void to int.
+ */
+ #ifndef VOIDUSED
+ #define VOIDUSED 15
+ #endif
+ #define VOIDFLAGS 15
+ #if (VOIDFLAGS & VOIDUSED) != VOIDUSED
+ #define void int /* is void to be avoided? */ /* config-skip */
+ #define M_VOID /* Xenix strikes again */ /* config-skip */
+ #endif
+
+ #endif
#~ New Plan9 port
diff -Pcr perl5_003/plan9/exclude perl5_003_01/plan9/exclude
*** perl5_003/plan9/exclude Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/exclude Wed Jul 17 20:37:00 1996
***************
*** 0 ****
--- 1,29 ----
+ 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/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
#~ New Plan9 port
diff -Pcr perl5_003/plan9/fndvers perl5_003_01/plan9/fndvers
*** perl5_003/plan9/fndvers Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/fndvers Tue Jul 16 11:29:13 1996
***************
*** 0 ****
--- 1,9 ----
+ #!/bin/rc
+
+ . plan9/buildinfo
+
+ ed config.plan9 <<!
+ g/_P9P_VERSION/s//$p9pvers/g
+ g/_P9P_OBJTYPE/s//$objtype/g
+ w $1
+ !
#~ New Plan9 port
diff -Pcr perl5_003/plan9/genconfig.pl perl5_003_01/plan9/genconfig.pl
*** perl5_003/plan9/genconfig.pl Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/genconfig.pl Tue Jul 16 15:24:28 1996
***************
*** 0 ****
--- 1,272 ----
+ #!../miniperl
+ # Habit . . .
+ #
+ # Extract info from config.h, and add extra data here, to generate config.sh
+ # Edit the static information after __END__ to reflect your site and options
+ # that went into your perl binary. In addition, values which change from run
+ # to run may be supplied on the command line as key=val pairs.
+ #
+ # Last Modified: 28-Jun-1996 Luther Huffman lutherh@stratcom.com
+ #
+
+ #==== Locations of installed Perl components
+ $p9pvers="5.00301";
+ $prefix='';
+ $p9p_objtype=$ENV{'objtype'};
+ $builddir="/sys/src/cmd/perl/$p9pvers";
+ $installbin="/$p9p_objtype/bin";
+ $installman1dir="/sys/man/1";
+ $installman3dir="/sys/man/2";
+ $installprivlib="/sys/lib/perl";
+ $installarchlib = "/$p9p_objtype/lib/perl/$p9pvers";
+ $archname="plan9_$p9p_objtype";
+ $installsitelib="$installprivlib/site_perl";
+ $installsitearch="$installarchlib/site_perl";
+ $installscript="/bin";
+
+ unshift(@INC,'lib'); # In case someone didn't define Perl_Root
+ # before the build
+
+ if ($ARGV[0] eq '-f') {
+ open(ARGS,$ARGV[1]) or die "Can't read data from $ARGV[1]: $!\n";
+ @ARGV = ();
+ while (<ARGS>) {
+ push(@ARGV,split(/\|/,$_));
+ }
+ close ARGS;
+ }
+
+ if (-f "config.h") { $infile = "config.h"; $outdir = "../"; }
+ elsif (-f "plan9/config.h") { $infile = "plan9/config.h"; $outdir = "./"; }
+
+ if ($infile) { print "Generating config.sh from $infile . . .\n"; }
+ else { die <<EndOfGasp;
+ Can't find config.h to read!
+ Please run this script from the perl source directory or
+ the plan9 subdirectory in the distribution.
+ EndOfGasp
+ }
+ $outdir = '';
+ open(IN,"$infile") || die "Can't open $infile: $!\n";
+ open(OUT,">${outdir}config.sh") || die "Can't open ${outdir}config.sh: $!\n";
+
+ $time = localtime;
+ $cf_by = $ENV{'user'};
+ ($vers = $]) =~ tr/./_/;
+
+ # Plan 9 doesn't actually use version numbering. Following the original Unix
+ # precedent of assigning a Unix edition number based on the edition number
+ # of the manuals, I am referring to this as Plan 9, 1st edition.
+ $osvers = '1';
+
+ print OUT <<EndOfIntro;
+ # This file generated by genconfig.pl on a Plan 9 system.
+ # Input obtained from:
+ # $infile
+ # $0
+ # Time: $time
+
+ package='perl5'
+ CONFIG='true'
+ cf_time='$time'
+ cf_by='$cf_by'
+ ccdlflags=''
+ cccdlflags=''
+ libpth='$installprivlib'
+ ld='pcc'
+ lddlflags=''
+ ranlib=''
+ ar='ar'
+ nroff='/bin/nroff'
+ eunicefix=':'
+ hint='none'
+ hintfile=''
+ intsize='4'
+ alignbytes='8'
+ shrplib='define'
+ usemymalloc='n'
+ usevfork='true'
+ useposix='true'
+ spitshell='cat'
+ dlsrc='dl_none.c'
+ binexp='$installbin'
+ man1ext=''
+ man3ext=''
+ arch='$archname'
+ archname='$archname'
+ osname='plan9'
+ extensions='IO Socket Opcode Fcntl POSIX DynaLoader FileHandle'
+ osvers='$osvers'
+ sig_maxsig='19'
+ sig_name='ZERO HUP INT QUIT ILL ABRT FPE KILL SEGV PIPE ALRM TERM USR1 USR2 CHLD CONT STOP TSTP TTIN TTOU'
+ sig_num='0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19'
+ sig_numsig='20'
+ prefix='$prefix'
+ builddir='$builddir'
+ installbin='$installbin'
+ installman1dir='$installman1dir'
+ installman3dir='$installman3dir'
+ installprivlib='$installprivlib'
+ installarchlib='$installarchlib'
+ installsitelib='$installsitelib'
+ installsitearch='$installsitearch'
+ installscript='$installscript'
+ scriptdir='$installscript'
+ scriptdirexp='$installscript'
+ EndOfIntro
+
+ # Plan 9 compiler stuff
+ print OUT "cc='pcc'\n";
+ print OUT "d_attribut='undef'\n";
+ print OUT "d_socket='define'\n";
+ print OUT "d_sockpair='define'\n";
+ print OUT "d_sigsetjmp='define'\n";
+ print OUT "sigjmp_buf='sigjmp_buf'\n";
+ print OUT "sigsetjmp='sigsetjmp(buf,save_mask)'\n";
+ print OUT "siglongjmp='siglongjmp(buf,retval) '\n";
+ print OUT "exe_ext=''\n";
+ if ($p9p_objtype eq '386') {
+ $objext = '.8';
+ }
+ elsif ($p9p_objtype eq '68020') {
+ $objext = '.2';
+ }
+ elsif ($p9p_objtype eq 'mips') {
+ $objext = '.v';
+ }
+ elsif ($p9p_objtype eq 'sparc') {
+ $objext = '.k';
+ }
+ print OUT "obj_ext='$objext'\n";
+
+ if ($p9p_objtype eq '386') {
+ $cstflags = 2;
+ }
+ else {
+ $cstflags = 0;
+ }
+ print OUT "castflags='$cstflags'\n";
+
+ $myname = $ENV{'site'} ;
+ ($myhostname,$mydomain) = split(/\./,$myname,2);
+ print OUT "myhostname='$myhostname'\n" if $myhostname;
+ if ($mydomain) {
+ print OUT "mydomain='.$mydomain'\n";
+ print OUT "perladmin='$cf_by\@$myhostname.$mydomain'\n";
+ print OUT "cf_email='$cf_by\@$myhostname.$mydomain'\n";
+ }
+ else {
+ print OUT "perladmin='$cf_by'\n";
+ print OUT "cf_email='$cf_by'\n";
+ }
+ print OUT "myuname='Plan9 $myname $osvers $p9p_objtype'\n";
+
+ # Before we read the C header file, find out what config.sh constants are
+ # equivalent to the C preprocessor macros
+ if (open(SH,"${outdir}config_h.SH")) {
+ while (<SH>) {
+ next unless m%^#(?!if).*\$%;
+ s/^#//; s!(.*?)\s*/\*.*!$1!;
+ my(@words) = split;
+ $words[1] =~ s/\(.*//; # Clip off args from macro
+ # Did we use a shell variable for the preprocessor directive?
+ if ($words[0] =~ m!^\$(\w+)!) { $pp_vars{$words[1]} = $1; }
+ if (@words > 2) { # We may also have a shell var in the value
+ shift @words; # Discard preprocessor directive
+ my($token) = shift @words; # and keep constant name
+ my($word);
+ foreach $word (@words) {
+ next unless $word =~ m!\$(\w+)!;
+ $val_vars{$token} = $1;
+ last;
+ }
+ }
+ }
+ close SH;
+ }
+ else { warn "Couldn't read ${outfile}config_h.SH: $!\n"; }
+ $pp_vars{PLAN9} = 'define'; #Plan 9 specific
+
+ # OK, now read the C header file, and retcon statements into config.sh
+ while (<IN>) { # roll through the comment header in config.h
+ last if /config-start/;
+ }
+
+ while (<IN>) {
+ chop;
+ while (/\\\s*$/) { # pick up contination lines
+ my $line = $_;
+ $line =~ s/\\\s*$//;
+ $_ = <IN>;
+ s/^\s*//;
+ $_ = $line . $_;
+ }
+ next unless my ($blocked,$un,$token,$val) =
+ m%^(\/\*)?\s*\#\s*(un)?def\w*\s+([A-Za-z0-9]\w+)\S*\s*(.*)%;
+ if (/config-skip/) {
+ delete $pp_vars{$token} if exists $pp_vars{$token};
+ delete $val_vars{$token} if exists $val_vars{$token};
+ next;
+ }
+ $val =~ s!\s*/\*.*!!; # strip off trailing comment
+ my($had_val); # Maybe a macro with args that we just #undefd or commented
+ if (!length($val) and $val_vars{$token} and ($un || $blocked)) {
+ print OUT "$val_vars{$token}=''\n";
+ delete $val_vars{$token};
+ $had_val = 1;
+ }
+ $state = ($blocked || $un) ? 'undef' : 'define';
+ if ($pp_vars{$token}) {
+ print OUT "$pp_vars{$token}='$state'\n";
+ delete $pp_vars{$token};
+ }
+ elsif (not length $val and not $had_val) {
+ # Wups -- should have been shell var for C preprocessor directive
+ warn "Constant $token not found in config_h.SH\n";
+ $token =~ tr/A-Z/a-z/;
+ $token = "d_$token" unless $token =~ /^i_/;
+ print OUT "$token='$state'\n";
+ }
+ next unless length $val;
+ $val =~ s/^"//; $val =~ s/"$//; # remove end quotes
+ $val =~ s/","/ /g; # make signal list look nice
+
+ if ($val_vars{$token}) {
+ print OUT "$val_vars{$token}='$val'\n";
+ if ($val_vars{$token} =~ s/exp$//) {print OUT "$val_vars{$token}='$val'\n";}
+ delete $val_vars{$token};
+ }
+ elsif (!$pp_vars{$token}) { # Haven't seen it previously, either
+ warn "Constant $token not found in config_h.SH (val=|$val|)\n";
+ $token =~ tr/A-Z/a-z/;
+ print OUT "$token='$val'\n";
+ if ($token =~ s/exp$//) {print OUT "$token='$val'\n";}
+ }
+ }
+ close IN;
+
+ foreach (sort keys %pp_vars) {
+ warn "Didn't see $_ in $infile\n";
+ }
+ foreach (sort keys %val_vars) {
+ warn "Didn't see $_ in $infile(val)\n";
+ }
+
+
+ # print OUT "libs='",join(' ',@libs),"'\n";
+ # print OUT "libc='",join(' ',@crtls),"'\n";
+
+ if (open(PL,"${outdir}patchlevel.h")) {
+ while (<PL>) {
+ if (/^#define PATCHLEVEL\s+(\S+)/) { print OUT "PATCHLEVEL='$1'\n"; }
+ elsif (/^#define SUBVERSION\s+(\S+)/) { print OUT "SUBVERSION='$1'\n"; }
+ }
+ close PL;
+ }
+ else { warn "Can't read ${outdir}patchlevel.h - skipping 'PATCHLEVEL'"; }
+
+ print OUT "pager='/bin/p'\n";
+
+ close OUT;
+
+
#~ New Plan9 port
diff -Pcr perl5_003/plan9/mkfile perl5_003_01/plan9/mkfile
*** perl5_003/plan9/mkfile Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/mkfile Fri Jul 26 16:53:27 1996
***************
*** 0 ****
--- 1,149 ----
+ Content-type: text/plain; charset="us-ascii"
+ Content-disposition: attachment; filename="mkfile"
+
+ APE=/sys/src/ape
+ < $APE/config
+ <plan9/buildinfo
+ sourcedir = /sys/src/cmd/perl/$p9pvers
+ archname = plan9_$objtype
+ privlib=/sys/lib/perl
+ archlib = /$objtype/lib/perl/$p9pvers
+ sitelib = $privlib/site_perl
+ sitearch = $archlib/site_perl
+
+ CFLAGS = -B -D_POSIX_SOURCE -D_BSD_EXTENSION -DNO_EMBED
+ LDFLAGS = -B
+
+ CCCMD = $CC -c $CFLAGS
+
+ perllib = $archlib/CORE/libperl.a
+
+ perlshr = $archlib/CORE/libperlshr.a
+
+ installman1dir = /sys/man/1
+ installman3dir = /sys/man/2
+
+ podnames = perl perlbook perlbot perlcall perldata perldebug perldiag perldsc perlembed perlform perlfunc perlguts perlipc perllol perlmod perlobj perlop perlovl perlpod perlre perlref perlrun perlsec perlstyle perlsub perlsyn perltie perltoc perltrap perlvar perlxs perlxstut
+
+ libpods = ${podnames:%=pod/%.pod}
+
+ perlpods = $libpods
+
+ extensions = IO Socket Opcode DynaLoader Fcntl FileHandle POSIX
+ 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
+
+ OBJS = perl.$O $obj
+
+ testlist = base/*.t comp/*.t cmd/*.t io/*.t op/*.t
+
+ install:V: perl preplibrary
+ cp perl /$objtype/bin/perl
+ cp plan9/aperl /rc/bin/aperl
+
+ perl: config.h miniperlmain.$O miniperl $archlib/Config.pm perlmain.$O $perlshr
+ $LD $CFLAGS -o perl perlmain.$O $perllib $perlshr
+
+ miniperl: config.h $perllib miniperlmain.$O
+ $LD $CFLAGS -o miniperl miniperlmain.$O $perllib
+
+ preplibrary:V: miniperl $archlib/Config.pm
+ cd $privlib
+ for (file in *.pm */*.pm $archlib/Config.pm) $sourcedir/miniperl -e 'use AutoSplit; autosplit(@ARGV)' $file $privlib/auto
+
+ $perllib(%):N: %
+ $perllib: ${OBJS:%=$perllib(%)}
+ ar rv $perllib $OBJS
+ $RANLIB $perllib
+
+ miniperlmain.$O: config.h
+ $CCCMD miniperlmain.c
+
+ perlmain.$O: config.h perlmain.c
+ $CCCMD perlmain.c
+
+ perlmain.c: miniperl vms/writemain.pl
+ ./miniperl vms/writemain.pl $extensions
+
+ config.h: config.plan9 plan9/fndvers
+ plan9/fndvers config.h
+ cp config.h $archlib/CORE
+
+ $perlshr(%):N: %
+ $perlshr: ${ext_obj:%=$perlshr(%)}
+ ar rv $perlshr $ext_obj
+ $RANLIB $perlshr
+
+ IO.c: miniperl ext/IO/IO.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/IO/IO.xs > $target
+ cp ext/IO/*.pm $privlib
+ if (test !-d $privlib/IO) mkdir $privlib/IO
+ cp ext/IO/lib/IO/*.pm $privlib/IO
+
+ Socket.$O: config.h Socket.c
+ $CCCMD -I plan9 Socket.c
+
+ Socket.c: miniperl ext/Socket/Socket.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Socket/Socket.xs > $target
+ cp ext/Socket/Socket.pm $privlib
+
+ Opcode.c: miniperl ext/Opcode/Opcode.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Opcode/Opcode.xs > $target
+ cp ext/Opcode/*.pm $privlib
+
+ Fcntl.c: miniperl ext/Fcntl/Fcntl.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/Fcntl/Fcntl.xs > $target
+ cp ext/Fcntl/Fcntl.pm $privlib
+
+ FileHandle.c: miniperl ext/FileHandle/FileHandle.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/FileHandle/FileHandle.xs > $target
+ cp ext/FileHandle/FileHandle.pm $privlib
+
+ POSIX.c: miniperl ext/POSIX/POSIX.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/POSIX/POSIX.xs > $target
+ cp ext/POSIX/POSIX.pm $privlib
+
+ dl_none.c: miniperl ext/DynaLoader/dl_none.xs
+ ./miniperl $privlib/ExtUtils/xsubpp -noprototypes -typemap $privlib/ExtUtils/typemap ext/DynaLoader/dl_none.xs > $target
+ cp ext/DynaLoader/DynaLoader.pm $privlib
+
+ test:V:
+ bind -b $privlib $sourcedir/lib
+ bind -b $archlib $sourcedir/lib
+ cd $sourcedir/t
+ rm -f perl
+ cp /$objtype/bin/perl $sourcedir/t
+ perl TEST `{ ls */*.t | comm -23 - ../plan9/exclude }
+
+ plan9.$O: config.h ./plan9/plan9.c
+ cp ./plan9/plan9.c ./plan9.c
+ $CCCMD plan9.c
+
+ %.$O: config.h %.c
+ $CCCMD $stem.c
+
+ $archlib/Config.pm: miniperl config.sh
+ ./miniperl configpm $archlib/Config.pm
+
+ config.sh: miniperl config.h
+ ./miniperl ./plan9/genconfig.pl
+
+ installall:V:
+ for (objtype in 386 mips 68020 sparc) mk install
+
+ man:V: $perlpods pod/pod2man.PL perl
+ perl pod/pod2man.PL
+ for (i in $podnames) pod/pod2man pod/$i.pod > $installman3dir/$i
+ pod/pod2man plan9/perlplan9.pod > $installman3dir/perlplan9
+
+ nuke: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
+
+ deleteman:V:
+ rm -f $installman1dir/perl* $installman3dir/perl*
#~ New Plan9 port
diff -Pcr perl5_003/plan9/myconfig.plan9 perl5_003_01/plan9/myconfig.plan9
*** perl5_003/plan9/myconfig.plan9 Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/myconfig.plan9 Mon Jul 15 16:39:22 1996
***************
*** 0 ****
--- 1,39 ----
+ #!/bin/rc
+
+ # This script is designed to provide a handy summary of the configuration
+ # information being used to build perl. This is especially useful if you
+ # are requesting help from comp.lang.perl.misc on usenet or via mail.
+
+ #This script is the "myconfig" script altered to run on Plan 9.
+ #Last Modified: 28-Jun-96 Luther Huffman lutherh@stratcom.com
+
+
+ . config.sh
+
+ # Note that the text lines /^Summary of/ .. /^\s*$/ are copied into Config.pm.
+ # XXX Add d_sigaction (?) once it's defined.
+
+ $spitshell<<!GROK!THIS!
+
+ Summary of my $package ($baserev patchlevel $PATCHLEVEL) configuration:
+ Platform:
+ osname=$osname, osver=$osvers, archname=$archname
+ uname='$myuname'
+ hint=$hint, useposix=$useposix
+ Compiler:
+ cc='$cc', optimize='$optimize', gccversion=$gccversion
+ cppflags='$cppflags'
+ ccflags ='$ccflags'
+ stdchar='$stdchar', d_stdstdio=$d_stdstdio, usevfork=$usevfork
+ voidflags=$voidflags, castflags=$castflags, d_casti32=$d_casti32, d_castneg=$d_castneg
+ intsize=$intsize, alignbytes=$alignbytes, usemymalloc=$usemymalloc, randbits=$randbits
+ Linker and Libraries:
+ ld='$ld', ldflags ='$ldflags'
+ libpth=$libpth
+ libs=$libs
+ libc=$libc, so=$so
+ Dynamic Linking:
+ dlsrc=$dlsrc, dlext=$dlext, d_dlsymun=$d_dlsymun, ccdlflags='$ccdlflags'
+ cccdlflags='$cccdlflags', lddlflags='$lddlflags'
+
+ !GROK!THIS!
#~ New Plan9 port
diff -Pcr perl5_003/plan9/perlplan9.doc perl5_003_01/plan9/perlplan9.doc
*** perl5_003/plan9/perlplan9.doc Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/perlplan9.doc Mon Jul 15 16:39:22 1996
***************
*** 0 ****
--- 1,91 ----
+
+ PERLTEST/PLAN9/PERLPLAN9(1) (perl ) PERLTEST/PLAN9/PERLPLAN9(1)
+
+ NNNNAAAAMMMMEEEE
+ perlplan9 - Plan 9-specific documentation for Perl
+
+ DDDDEEEESSSSCCCCRRRRIIIIPPPPTTTTIIIIOOOONNNN
+ These are a few notes describing features peculiar to Plan 9
+ Perl. As such, it is not intended to be a replacement for
+ the rest of the Perl 5 documentation (which is both copious
+ and excellent). If you have any questions to which you can't
+ find answers in these man pages, contact Luther Huffman at
+ lutherh@stratcom.com and we'll try to answer them.
+
+ IIIInnnnvvvvooookkkkiiiinnnngggg PPPPeeeerrrrllll
+
+ Perl is invoked from the command line as described in the
+ _p_e_r_l manpage. Most perl scripts, however, do have a first
+ line such as "#!/usr/local/bin/perl". This is known as a
+ shebang (shell-bang) statement and tells the OS shell where
+ to find the perl interpreter. In Plan 9 Perl this statement
+ should be "#!/bin/perl" if you wish to be able to directly
+ invoke the script by its name.
+ Alternatively, you may invoke perl with the command
+ "aperl" instead of "perl". This will produce Acme-friendly
+ error messages of the form "filename:18".
+
+ Some scripts, usually identified with a *.PL extension, are
+ self-configuring and are able to correctly create their own
+ shebang path from config information located in Plan 9 Perl.
+ These you won't need to be worried about.
+
+ WWWWhhhhaaaatttt''''ssss iiiinnnn PPPPllllaaaannnn 9999 PPPPeeeerrrrllll
+
+ Although Plan 9 Perl currently only provides static
+ loading, it is built with a number of useful extensions.
+ These include Safe, FileHandle, Fcntl, and POSIX. Expect to
+ see others (and DynaLoading!) in the future.
+
+ WWWWhhhhaaaatttt''''ssss nnnnooootttt iiiinnnn PPPPllllaaaannnn 9999 PPPPeeeerrrrllll
+
+ As mentioned previously, dynamic loading isn't currently
+ available nor is MakeMaker. Both are high-priority items.
+
+ PPPPeeeerrrrllll5555 FFFFuuuunnnnccccttttiiiioooonnnnssss nnnnooootttt ccccuuuurrrrrrrreeeennnnttttllllyyyy ssssuuuuppppppppoooorrrrtttteeeedddd
+
+ Some, such as chown and umask aren't provided because the
+ concept does not exist within Plan 9. Others, such as some
+ of the socket-related functions, simply haven't been written
+ yet. Many in the latter category may be supported in the
+ future.
+
+ The functions not currently implemented include:
+
+ Page 1 4/Jul/96 (printed 7/4/96)
+
+ PERLTEST/PLAN9/PERLPLAN9(1) (perl ) PERLTEST/PLAN9/PERLPLAN9(1)
+
+ chown, chroot, dbmclose, dbmopen, getsockopt,
+ setsockopt, recvmsg, sendmsg, getnetbyname,
+ getnetbyaddr, getnetent, getprotoent, getservent,
+ sethostent, setnetent, setprotoent, setservent,
+ endservent, endnetent, endprotoent, umask
+
+ There may be several other functions that have undefined
+ behavior so this list shouldn't be considered complete.
+
+ SSSSiiiiggggnnnnaaaallllssss
+
+ For compatibility with perl scripts written for the Unix
+ environment, Plan 9 Perl uses the POSIX signal emulation
+ provided in Plan 9's ANSI POSIX Environment (APE). Signal
+ stacking isn't supported. The signals provided are:
+
+ SIGHUP, SIGINT, SIGQUIT, SIGILL, SIGABRT,
+ SIGFPE, SIGKILL, SIGSEGV, SIGPIPE, SIGPIPE, SIGALRM,
+ SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT,
+ SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU
+
+ BBBBUUUUGGGGSSSS
+ "As many as there are grains of sand on all the beaches of
+ the world . . ." - Carl Sagan
+
+ RRRReeeevvvviiiissssiiiioooonnnn ddddaaaatttteeee
+ This document was revised 04-July-1996 for Perl 5.003_1.
+
+ AAAAUUUUTTTTHHHHOOOORRRR
+ Luther Huffman, lutherh@stratcom.com
+
+ Page 2 4/Jul/96 (printed 7/4/96)
+
#~ New Plan9 port
diff -Pcr perl5_003/plan9/perlplan9.pod perl5_003_01/plan9/perlplan9.pod
*** perl5_003/plan9/perlplan9.pod Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/perlplan9.pod Mon Jul 15 16:39:22 1996
***************
*** 0 ****
--- 1,87 ----
+ =head1 NAME
+
+ perlplan9 - Plan 9-specific documentation for Perl
+
+ =head1 DESCRIPTION
+
+ These are a few notes describing features peculiar to
+ Plan 9 Perl. As such, it is not intended to be a replacement
+ for the rest of the Perl 5 documentation (which is both
+ copious and excellent). If you have any questions to
+ which you can't find answers in these man pages, contact
+ Luther Huffman at lutherh@stratcom.com and we'll try to
+ answer them.
+
+ =head2 Invoking Perl
+
+ Perl is invoked from the command line as described in
+ L<perl>. Most perl scripts, however, do have a first line
+ such as "#!/usr/local/bin/perl". This is known as a shebang
+ (shell-bang) statement and tells the OS shell where to find
+ the perl interpreter. In Plan 9 Perl this statement should be
+ "#!/bin/perl" if you wish to be able to directly invoke the
+ script by its name.
+ Alternatively, you may invoke perl with the command "aperl"
+ instead of "perl". This will produce Acme-friendly error
+ messages of the form "filename:18".
+
+ Some scripts, usually identified with a *.PL extension, are
+ self-configuring and are able to correctly create their own
+ shebang path from config information located in Plan 9
+ Perl. These you won't need to be worried about.
+
+ =head2 What's in Plan 9 Perl
+
+ Although Plan 9 Perl currently only provides static
+ loading, it is built with a number of useful extensions.
+ These include Safe, FileHandle, Fcntl, and POSIX. Expect
+ to see others (and DynaLoading!) in the future.
+
+ =head2 What's not in Plan 9 Perl
+
+ As mentioned previously, dynamic loading isn't currently
+ available nor is MakeMaker. Both are high-priority items.
+
+ =head2 Perl5 Functions not currently supported
+
+ Some, such as C<chown> and C<umask> aren't provided
+ because the concept does not exist within Plan 9. Others,
+ such as some of the socket-related functions, simply
+ haven't been written yet. Many in the latter category
+ may be supported in the future.
+
+ The functions not currently implemented include:
+
+ chown, chroot, dbmclose, dbmopen, getsockopt,
+ setsockopt, recvmsg, sendmsg, getnetbyname,
+ getnetbyaddr, getnetent, getprotoent, getservent,
+ sethostent, setnetent, setprotoent, setservent,
+ endservent, endnetent, endprotoent, umask
+
+ There may be several other functions that have undefined
+ behavior so this list shouldn't be considered complete.
+
+ =head2 Signals
+
+ For compatibility with perl scripts written for the Unix
+ environment, Plan 9 Perl uses the POSIX signal emulation
+ provided in Plan 9's ANSI POSIX Environment (APE). Signal stacking
+ isn't supported. The signals provided are:
+
+ SIGHUP, SIGINT, SIGQUIT, SIGILL, SIGABRT,
+ SIGFPE, SIGKILL, SIGSEGV, SIGPIPE, SIGPIPE, SIGALRM,
+ SIGTERM, SIGUSR1, SIGUSR2, SIGCHLD, SIGCONT,
+ SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU
+
+ =head1 BUGS
+
+ "As many as there are grains of sand on all the beaches of the
+ world . . ." - Carl Sagan
+
+ =head1 Revision date
+
+ This document was revised 04-July-1996 for Perl 5.003_1.
+
+ =head1 AUTHOR
+
+ Luther Huffman, lutherh@stratcom.com
\ No newline at end of file
#~ New Plan9 port
diff -Pcr perl5_003/plan9/plan9.c perl5_003_01/plan9/plan9.c
*** perl5_003/plan9/plan9.c Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/plan9.c Wed Jul 17 15:16:52 1996
***************
*** 0 ****
--- 1,134 ----
+ #include "EXTERN.h"
+ #include "perl.h"
+
+ /* Functions mentioned in <sys/socket.h> but not implemented */
+
+ int getsockopt(int a, int b, int c, void *d, int *e)
+ {
+ croak("Function \"getsockopt\" not implemented in this version of perl.");
+ return (int)NULL;
+ }
+
+ int setsockopt(int a, int b, int c, void *d, int *e)
+ {
+ croak("Function \"setsockopt\" not implemented in this version of perl.");
+ return (int)NULL;
+ }
+
+
+ int recvmsg(int a, struct msghdr *b, int c)
+ {
+ croak("Function \"recvmsg\" not implemented in this version of perl.");
+ return (int)NULL;
+ }
+
+ int sendmsg(int a, struct msghdr *b, int c)
+ {
+ croak("Function \"sendmsg\" not implemented in this version of perl.");
+ return (int)NULL;
+ }
+
+
+ /* Functions mentioned in <netdb.h> but not implemented */
+ struct netent *getnetbyname(const char *a)
+ {
+ croak("Function \"getnetbyname\" not implemented in this version of perl.");
+ return (struct netent *)NULL;
+ }
+
+ struct netent *getnetbyaddr(long a, int b)
+ {
+ croak("Function \"getnetbyaddr\" not implemented in this version of perl.");
+ return (struct netent *)NULL;
+ }
+
+ struct netent *getnetent()
+ {
+ croak("Function \"getnetent\" not implemented in this version of perl.");
+ return (struct netent *)NULL;
+ }
+
+ struct protoent *getprotobyname(const char *a)
+ {
+ croak("Function \"getprotobyname\" not implemented in this version of perl.");
+ return (struct protoent *)NULL;
+ }
+
+ struct protoent *getprotobynumber(int a)
+ {
+ croak("Function \"getprotobynumber\" not implemented in this version of perl.");
+ return (struct protoent *)NULL;
+ }
+
+ struct protoent *getprotoent()
+ {
+ croak("Function \"getprotoent\" not implemented in this version of perl.");
+ return (struct protoent *)NULL;
+ }
+
+ struct servent *getservbyport(int a, const char *b)
+ {
+ croak("Function \"getservbyport\" not implemented in this version of perl.");
+ return (struct servent *)NULL;
+ }
+
+ struct servent *getservent()
+ {
+ croak("Function \"getservent\" not implemented in this version of perl.");
+ return (struct servent *)NULL;
+ }
+
+ void sethostent(int a)
+ {
+ croak("Function \"sethostent\" not implemented in this version of perl.");
+ }
+
+ void setnetent(int a)
+ {
+ croak("Function \"setnetent\" not implemented in this version of perl.");
+ }
+
+ void setprotoent(int a)
+ {
+ croak("Function \"setprotoent\" not implemented in this version of perl.");
+ }
+
+ void setservent(int a)
+ {
+ croak("Function \"setservent\" not implemented in this version of perl.");
+ }
+
+ void endnetent()
+ {
+ croak("Function \"endnetent\" not implemented in this version of perl.");
+ }
+
+ void endprotoent()
+ {
+ croak("Function \"endprotoent\" not implemented in this version of perl.");
+ }
+
+ void endservent()
+ {
+ croak("Function \"endservent\" not implemented in this version of perl.");
+ }
+
+ int tcdrain(int)
+ {
+ croak("Function \"tcdrain\" not implemented in this version of perl.");
+ }
+
+ int tcflow(int, int)
+ {
+ croak("Function \"tcflow\" not implemented in this version of perl.");
+ }
+
+ int tcflush(int, int)
+ {
+ croak("Function \"tcflush\" not implemented in this version of perl.");
+ }
+
+ int tcsendbreak(int, int)
+ {
+ croak("Function \"tcsendbreak\" not implemented in this version of perl.");
+ }
#~ New Plan9 port
diff -Pcr perl5_003/plan9/plan9ish.h perl5_003_01/plan9/plan9ish.h
*** perl5_003/plan9/plan9ish.h Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/plan9ish.h Thu Jul 25 16:13:19 1996
***************
*** 0 ****
--- 1,113 ----
+ #ifndef __PLAN9ISH_H__
+ #define __PLAN9ISH_H__
+
+ /*
+ * The following symbols are defined if your operating system supports
+ * functions by that name. All Unixes I know of support them, thus they
+ * are not checked by the configuration script, but are directly defined
+ * here.
+ */
+
+ /* HAS_IOCTL:
+ * This symbol, if defined, indicates that the ioctl() routine is
+ * available to set I/O characteristics
+ */
+ #define HAS_IOCTL /**/
+
+ /* HAS_UTIME:
+ * This symbol, if defined, indicates that the routine utime() is
+ * available to update the access and modification times of files.
+ */
+ #define HAS_UTIME /**/
+
+ /* HAS_GROUP
+ * This symbol, if defined, indicates that the getgrnam(),
+ * getgrgid(), and getgrent() routines are available to
+ * get group entries.
+ */
+ /*#define HAS_GROUP /**/
+
+ /* HAS_PASSWD
+ * This symbol, if defined, indicates that the getpwnam(),
+ * getpwuid(), and getpwent() routines are available to
+ * get password entries.
+ */
+ /*#define HAS_PASSWD /**/
+
+ #define HAS_KILL
+ #define HAS_WAIT
+
+ /* UNLINK_ALL_VERSIONS:
+ * This symbol, if defined, indicates that the program should arrange
+ * to remove all versions of a file if unlink() is called. This is
+ * probably only relevant for VMS.
+ */
+ /* #define UNLINK_ALL_VERSIONS /**/
+
+ /* PLAN9:
+ * This symbol, if defined, indicates that the program is running under
+ * Plan 9.
+ */
+ #ifndef PLAN9
+ #define PLAN9 /**/
+ #endif
+
+ /* USEMYBINMODE
+ * This symbol, if defined, indicates that the program should
+ * use the routine my_binmode(FILE *fp, char iotype) to insure
+ * that a file is in "binary" mode -- that is, that no translation
+ * of bytes occurs on read or write operations.
+ */
+ #undef USEMYBINMODE
+
+ /* USE_STAT_RDEV:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_rdev
+ */
+ #undef USE_STAT_RDEV /**/
+
+ /* ACME_MESS:
+ * This symbol, if defined, indicates that error messages should be
+ * should be generated in a format that allows the use of the Acme
+ * GUI/editor's autofind feature.
+ */
+ #define ACME_MESS /**/
+
+ #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
+ # include <signal.h>
+ #endif
+
+ #ifndef SIGABRT
+ # define SIGABRT SIGILL
+ #endif
+ #ifndef SIGILL
+ # define SIGILL 6 /* blech */
+ #endif
+ #define ABORT() kill(getpid(),SIGABRT);
+
+ #define BIT_BUCKET "/dev/null"
+ #define PERL_SYS_INIT(c,v)
+ #define dXSUB_SYS int dummy
+ #define PERL_SYS_TERM()
+
+ /*
+ * fwrite1() should be a routine with the same calling sequence as fwrite(),
+ * but which outputs all of the bytes requested as a single stream (unlike
+ * fwrite() itself, which on some systems outputs several distinct records
+ * if the number_of_items parameter is >1).
+ */
+ #define fwrite1 fwrite
+
+ #define Stat(fname,bufptr) stat((fname),(bufptr))
+ #define Fstat(fd,bufptr) fstat((fd),(bufptr))
+ #define Fflush(fp) fflush(fp)
+
+ /* getenv related stuff */
+ #define my_getenv(var) getenv(var)
+ /* Plan 9 prefers getenv("home") to getenv("HOME")
+ #define HOME home
+
+ /* For use by POSIX.xs */
+ extern int tcsendbreak(int, int);
+
+ #endif /* __PLAN9ISH_H__ */
#~ New Plan9 port
diff -Pcr perl5_003/plan9/setup.rc perl5_003_01/plan9/setup.rc
*** perl5_003/plan9/setup.rc Wed Dec 31 19:00:00 1969
--- perl5_003_01/plan9/setup.rc Wed Jul 17 08:26:54 1996
***************
*** 0 ****
--- 1,48 ----
+ #!/bin/rc
+ # This is an rc shell script which unpacks the perl distribution, builds
+ # directories, and puts files where they belong.
+ # To use, just run it from within the plan9 subdirectory with the appropriate
+ # permissions.
+ # Last modified 6/30/96 by:
+ # Luther Huffman, Strategic Computer Solutions, Inc., lutherh@stratcom.com
+
+ . buildinfo
+ builddir = `{ cd .. ; pwd }
+ if(flag a) platforms = (386 mips sparc 68020)
+ if not platforms = $objtype
+ sourcedir=/sys/src/cmd/perl/$p9pvers
+ privlib=/sys/lib/perl
+ sitelib=$privlib/site_perl
+
+ #Build source directory
+ if (test ! -d /sys/src/cmd/perl) mkdir /sys/src/cmd/perl
+ if (test ! -d $sourcedir) mkdir $sourcedir
+
+ #Populate source directory
+ echo Building source directories ...
+ {cd $builddir ; tar c .} | { cd $sourcedir ; tar x}
+ cp $builddir/plan9/config.plan9 $sourcedir/config.plan9
+ cp $builddir/plan9/plan9.c $builddir/plan9/plan9ish.h $builddir/plan9/mkfile $sourcedir
+ cd $sourcedir/lib ; rm -rf *
+
+ #Build library directories
+ echo Building library directories ...
+ if (test ! -d $privlib) mkdir $privlib
+ if (test ! -d $privlib/auto) mkdir $privlib/auto
+ if (test ! -d $sitelib) mkdir $sitelib
+ for(i in $platforms){
+ archlib=/$i/lib/perl/$p9pvers
+ sitearch=$archlib/site_perl
+ corelib=$archlib/CORE
+ arpalib=$corelib/arpa
+ if (test ! -d /$i/lib/perl) mkdir /$i/lib/perl
+ if (test ! -d $archlib) mkdir $archlib
+ if (test ! -d $sitearch) mkdir $sitearch
+ if (test ! -d $corelib) mkdir $corelib
+ if (test ! -d $arpalib) mkdir $arpalib
+ cp $builddir/*.h $builddir/plan9/*.h $corelib
+ cp $builddir/plan9/arpa/*.h $arpalib
+ }
+
+ #Populate library directories
+ {cd $builddir/lib ; tar c . } | {cd $privlib ; tar x }
#~ Replace unclear term "identifier" with "variable name"
diff -Pcr perl5_003/pod/perl.pod perl5_003_01/pod/perl.pod
*** perl5_003/pod/perl.pod Mon Mar 25 01:05:09 1996
--- perl5_003_01/pod/perl.pod Wed May 1 20:19:18 1996
***************
*** 296,302 ****
While none of the built-in data types have any arbitrary size limits
(apart from memory size), there are still a few arbitrary limits: a
! given identifier may not be longer than 255 characters, and no
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.
--- 296,302 ----
While none of the built-in data types have any arbitrary size limits
(apart from memory size), there are still a few arbitrary limits: a
! given variable name may not be longer than 255 characters, and no
component of your PATH may be longer than 255 if you use B<-S>. A regular
expression may not compile to more than 32767 bytes internally.
#~ Quote string argument in example -- necessary if using strict subs
diff -Pcr perl5_003/pod/perlbot.pod perl5_003_01/pod/perlbot.pod
*** perl5_003/pod/perlbot.pod Mon Feb 12 14:58:13 1996
--- perl5_003_01/pod/perlbot.pod Mon Jul 15 13:36:25 1996
***************
*** 277,287 ****
package main;
use Fcntl qw( O_RDWR O_CREAT );
! tie %foo, Mydbm, "Sdbm", O_RDWR|O_CREAT, 0640;
$foo{'bar'} = 123;
print "foo-bar = $foo{'bar'}\n";
! tie %bar, Mydbm, "Sdbm2", O_RDWR|O_CREAT, 0640;
$bar{'Cathy'} = 456;
print "bar-Cathy = $bar{'Cathy'}\n";
--- 277,287 ----
package main;
use Fcntl qw( O_RDWR O_CREAT );
! tie %foo, "Mydbm", "Sdbm", O_RDWR|O_CREAT, 0640;
$foo{'bar'} = 123;
print "foo-bar = $foo{'bar'}\n";
! tie %bar, "Mydbm", "Sdbm2", O_RDWR|O_CREAT, 0640;
$bar{'Cathy'} = 456;
print "bar-Cathy = $bar{'Cathy'}\n";
***************
*** 522,527 ****
package main;
use Fcntl qw( O_RDWR O_CREAT );
! tie %foo, Mydbm, "adbm", O_RDWR|O_CREAT, 0640;
$foo{'bar'} = 123;
print "foo-bar = $foo{'bar'}\n";
--- 522,527 ----
package main;
use Fcntl qw( O_RDWR O_CREAT );
! tie %foo, "Mydbm", "adbm", O_RDWR|O_CREAT, 0640;
$foo{'bar'} = 123;
print "foo-bar = $foo{'bar'}\n";
#~ More complete discussion of variable names
#~ Correction of typos
#~ More complete explanation of effect => has on left-hand expression
diff -Pcr perl5_003/pod/perldata.pod perl5_003_01/pod/perldata.pod
*** perl5_003/pod/perldata.pod Mon Mar 25 01:05:12 1996
--- perl5_003_01/pod/perldata.pod Mon Jun 17 18:30:14 1996
***************
*** 11,16 ****
--- 11,38 ----
indexed by number, starting with 0. (Negative subscripts count from
the end.) Hash arrays are indexed by string.
+ Values are usually referred to by name (or through a named reference).
+ The first character of the name tells you to what sort of data
+ structure it refers. The rest of the name tells you the particular
+ value to which it refers. Most often, it consists of a single
+ I<identifier>, that is, a string beginning with a letter or underscore,
+ and containing letters, underscores, and digits. In some cases, it
+ may be a chain of identifiers, separated by C<::> (or by C<'>, but
+ that's deprecated); all but the last are interpreted as names of
+ packages, in order 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
+ which produces a reference to the value at runtime; this is
+ described in more detail below, and in L<perlref>.
+
+ There are also special variables whose names don't follow these
+ rules, so that they don't accidentally collide with one of your
+ normal variables. Strings which match parenthesized parts of a
+ regular expression are saved under names containing only digits after
+ the C<$> (see L<perlop> and L<perlre>). In addition, several special
+ variables which provide windows into the inner working of Perl have names
+ containing punctuation characters (see L<perlvar>).
+
Scalar values are always named with '$', even when referring to a scalar
that is part of an array. It works like the English word "the". Thus
we have:
***************
*** 122,128 ****
type "filehandle", or anything else. Perl is a contextually polymorphic
language whose scalars can be strings, numbers, or references (which
includes objects). While strings and numbers are considered pretty
! much same thing for nearly all purposes, references are strongly-typed
uncastable pointers with built-in reference-counting and destructor
invocation.
--- 144,150 ----
type "filehandle", or anything else. Perl is a contextually polymorphic
language whose scalars can be strings, numbers, or references (which
includes objects). While strings and numbers are considered pretty
! much the same thing for nearly all purposes, references are strongly-typed
uncastable pointers with built-in reference-counting and destructor
invocation.
***************
*** 141,147 ****
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 the do in I<awk>:
if ($str == 0 && $str ne "0") {
warn "That doesn't look like a number";
--- 163,169 ----
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>:
if ($str == 0 && $str ne "0") {
warn "That doesn't look like a number";
***************
*** 166,172 ****
length of the array. Shortening an array by this method destroys
intervening values. Lengthening an array that was previously shortened
I<NO LONGER> recovers the values that were in those elements. (It used to
! in Perl 4, but we had to break this make to make sure destructors were
called when expected.) You can also gain some measure of efficiency by
preextending an array that is going to get big. (You can also extend
an array by assigning to an element that is off the end of the array.)
--- 188,194 ----
length of the array. Shortening an array by this method destroys
intervening values. Lengthening an array that was previously shortened
I<NO LONGER> recovers the values that were in those elements. (It used to
! in Perl 4, but we had to break this to make sure destructors were
called when expected.) You can also gain some measure of efficiency by
preextending an array that is going to get big. (You can also extend
an array by assigning to an element that is off the end of the array.)
***************
*** 230,243 ****
another line containing the quote character, which may be much further
on in the script. Variable substitution inside strings is limited to
scalar variables, arrays, and array slices. (In other words,
! identifiers beginning with $ or @, followed by an optional bracketed
expression as a subscript.) The following code segment prints out "The
price is $100."
$Price = '$100'; # not interpreted
print "The price is $Price.\n"; # interpreted
! As in some shells, you can put curly brackets around the identifier to
delimit it from following alphanumerics. In fact, an identifier
within such curlies is forced to be a string, as is any single
identifier within a hash subscript. Our earlier example,
--- 252,265 ----
another line containing the quote character, which may be much further
on in the script. Variable substitution inside strings is limited to
scalar variables, arrays, and array slices. (In other words,
! names beginning with $ or @, followed by an optional bracketed
expression as a subscript.) The following code segment prints out "The
price is $100."
$Price = '$100'; # not interpreted
print "The price is $Price.\n"; # interpreted
! As in some shells, you can put curly brackets around the name to
delimit it from following alphanumerics. In fact, an identifier
within such curlies is forced to be a string, as is any single
identifier within a hash subscript. Our earlier example,
***************
*** 254,260 ****
Note that a
single-quoted string must be separated from a preceding word by a
space, since single quote is a valid (though deprecated) character in
! an identifier (see L<perlmod/Packages>).
Two special literals are __LINE__ and __FILE__, which represent the
current line number and filename at that point in your program. They
--- 276,282 ----
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
! 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
***************
*** 457,464 ****
It is often more readable to use the C<=E<gt>> operator between key/value
pairs. The C<=E<gt>> operator is mostly just a more visually distinctive
! synonym for a comma, but it also quotes its left-hand operand, which makes
! it nice for initializing hashes:
%map = (
red => 0x00f,
--- 479,487 ----
It is often more readable to use the C<=E<gt>> operator between key/value
pairs. The C<=E<gt>> operator is mostly just a more visually distinctive
! synonym for a comma, but it also arranges for its left-hand operand to be
! interpreted as a string, if it's a bareword which would be a legal identifier.
! This makes it nice for initializing hashes:
%map = (
red => 0x00f,
#~ Extensive updates to debugger documentation: commands, output, new features
diff -Pcr perl5_003/pod/perldebug.pod perl5_003_01/pod/perldebug.pod
*** perl5_003/pod/perldebug.pod Tue Oct 18 12:39:18 1994
--- perl5_003_01/pod/perldebug.pod Mon Jul 15 14:38:30 1996
***************
*** 6,149 ****
First of all, have you tried using the B<-w> switch?
! =head2 Debugging
! If you invoke Perl with a B<-d> switch, your script will be run under the
! debugger. However, the Perl debugger is not a separate program as it is
! in a C environment. Instead, the B<-d> flag tells the compiler to insert
! source information into the pseudocode it's about to hand to the
! interpreter. (That means your code must compile correctly for the
! debugger to work on it.) Then when the interpreter starts up, it
! pre-loads a Perl library file containing the debugger itself. The program
! will halt before the first executable statement (but see below) and ask
! you for one of the following commands:
=over 12
! =item h
! Prints out a help message.
=item T
! Stack trace.
! If you do bizarre things to your @_ arguments in a subroutine, the stack
! backtrace will not always show the original values.
! =item s
Single step. Executes until it reaches the beginning of another
! statement.
=item n
Next. Executes over subroutine calls, until it reaches the beginning
of the next statement.
! =item f
!
! Finish. Executes statements until it has finished the current
! subroutine.
!
! =item c
! Continue. Executes until the next breakpoint is reached.
! =item c line
! Continue to the specified line. Inserts a one-time-only breakpoint at
! the specified line.
! =item <CR>
! Repeat last n or s.
=item l min+incr
! List incr+1 lines starting at min. If min is omitted, starts where
! last listing left off. If incr is omitted, previous value of incr is
! used.
=item l min-max
! List lines in the indicated range.
=item l line
! List just the indicated line.
! =item l
! List next window.
=item -
! List previous window.
! =item w line
! List window (a few lines worth of code) around line.
! =item l subname
! List subroutine. If it's a long subroutine it just lists the
! beginning. Use "l" to list more.
=item /pattern/
! Regular expression search forward in the source code for pattern; the
! final / is optional.
=item ?pattern?
! Regular expression search backward in the source code for pattern; the
! final ? is optional.
=item L
! List lines that have breakpoints or actions.
! =item S
! Lists the names of all subroutines.
=item t
! Toggle trace mode on or off.
! =item b line [ condition ]
Set a breakpoint. If line is omitted, sets a breakpoint on the line
! that is about to be executed. If a condition is specified, it is
evaluated each time the statement is reached and a breakpoint is taken
only if the condition is true. Breakpoints may only be set on lines
! that begin an executable statement. Conditions don't use C<if>:
b 237 $x > 30
b 33 /pattern/i
! =item b subname [ condition ]
! Set breakpoint at first executable line of subroutine.
! =item d line
! Delete breakpoint. If line is omitted, deletes the breakpoint on the
! line that is about to be executed.
=item D
! Delete all breakpoints.
! =item a line command
! Set an action for line. A multiline command may be entered by
! backslashing the newlines. This command is Perl code, not another
! debugger command.
=item A
! Delete all line actions.
=item < command
--- 6,342 ----
First of all, have you tried using the B<-w> switch?
! =head1 The Perl Debugger
! If you invoke Perl with the B<-d> switch, your script runs under the
! Perl source debugger. This works like an interactive Perl
! environment, prompting for debugger commands that let you examine
! source code, set breakpoints, get stack backtraces, change the values of
! variables, etc. This is so convenient that you often fire up
! the debugger all by itself just to test out Perl constructs
! interactively to see what they do. For example:
!
! perl -d -e 42
!
! In Perl, the debugger is not a separate program as it usually is in the
! typical compiled environment. Instead, the B<-d> flag tells the compiler
! to insert source information into the parse trees it's about to hand off
! to the interpreter. That means your code must first compile correctly
! for the debugger to work on it. Then when the interpreter starts up, it
! pre-loads a Perl library file containing the debugger itself.
!
! The program will halt I<right before> the first run-time executable
! statement (but see below regarding compile-time statements) and ask you
! to enter a debugger command. Contrary to popular expectations, whenever
! the debugger halts and shows you a line of code, it always displays the
! line it's I<about> to execute, rather than the one it has just executed.
!
! Any command not recognized by the debugger is directly executed
! (C<eval>'d) as Perl code in the current package. (The debugger uses the
! DB package for its own state information.)
!
! Leading white space before a command would cause the debugger to think
! it's I<NOT> a debugger command but for Perl, so be careful not to do
! that.
!
! =head2 Debugger Commands
!
! The debugger understands the following commands:
=over 12
! =item h [command]
!
! Prints out a help message.
!
! If you supply another debugger command as an argument to the C<h> command,
! it prints out the description for just that command. The special
! argument of C<h h> produces a more compact help listing, designed to fit
! together on one screen.
!
! If the output the C<h> command (or any command, for that matter) scrolls
! past your screen, either precede the command with a leading pipe symbol so
! it's run through your pager, as in
!
! DB> |h
!
! =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
! 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
! in a pretty-printed fashion. Nested data structures are printed out
! recursively, unlike the C<print> function.
!
! =item V [pkg [vars]]
!
! Display all (or some) variables in package (defaulting to the C<main>
! package) using a data pretty-printer (hashes show their keys and values so
! you see what's what, control characters are made printable, etc.). Make
! sure you don't put the type specifier (like C<$>) there, just the symbol
! names, like this:
! V DB filename line
!
! Use C<~pattern> and C<!pattern> for positive and negative regexps.
!
! Nested data structures are printed out in a legible fashion, unlike
! the C<print> function.
!
! =item X [vars]
!
! Same as C<V currentpackage [vars]>.
=item T
! Produce a stack backtrace. See below for details on its output.
! =item s [expr]
Single step. Executes until it reaches the beginning of another
! statement, descending into subroutine calls. If an expression is
! supplied that includes function calls, it too will be single-stepped.
=item n
Next. Executes over subroutine calls, until it reaches the beginning
of the next statement.
! =item <CR>
! Repeat last C<n> or C<s> command.
! =item c [line]
! Continue, optionally inserting a one-time-only breakpoint
! at the specified line.
! =item l
! List next window of lines.
=item l min+incr
! List C<incr+1> lines starting at C<min>.
=item l min-max
! List lines C<min> through C<max>.
=item l line
! List a single line.
! =item l subname
! List first window of lines from subroutine.
=item -
! List previous window of lines.
! =item w [line]
! List window (a few lines) around the current line.
! =item .
! Return debugger pointer to the last-executed line and
! print it out.
!
! =item f filename
!
! Switch to viewing a different file.
=item /pattern/
! Search forwards for pattern; final / is optional.
=item ?pattern?
! Search backwards for pattern; final ? is optional.
=item L
! List all breakpoints and actions for the current file.
! =item S [[!]pattern]
! List subroutine names [not] matching pattern.
=item t
! Toggle trace mode.
!
! =item t expr
!
! Trace through execution of expr. For example:
! $ perl -de 42
! Stack dump during die enabled outside of evals.
!
! Loading DB routines from perl5db.pl patch level 0.94
! Emacs support available.
!
! Enter h or `h h' for help.
!
! main::(-e:1): 0
! DB<1> sub foo { 14 }
!
! DB<2> sub bar { 3 }
!
! DB<3> t print foo() * bar()
! main::((eval 172):3): print foo() + bar();
! main::foo((eval 168):2):
! main::bar((eval 170):2):
! 42
! DB<4> q
!
! =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
! that begin an executable statement. Conditions don't use B<if>:
b 237 $x > 30
b 33 /pattern/i
! =item b subname [condition]
! Set a breakpoint at the first line of the named subroutine.
! =item d [line]
! Delete a breakpoint at the specified line. If line is omitted, deletes
! the breakpoint on the line that is about to be executed.
=item D
! Delete all installed breakpoints.
!
! =item a [line] command
!
! Set an action to be done before the line is executed.
! The sequence of steps taken by the debugger is
!
! =over 3
!
! =item 1
!
! check for a breakpoint at this line
!
! =item 2
!
! print the line if necessary (tracing)
!
! =item 3
!
! do any actions associated with that line
!
! =item 4
! prompt user if at a breakpoint or in single-step
! =item 5
!
! evaluate line
!
! =back
!
! For example, this will print out C<$foo> every time line
! 53 is passed:
!
! a 53 print "DB FOUND $foo\n"
=item A
! Delete all installed actions.
!
! =item O [opt[=val]] [opt"val"] [opt?]...
!
! Set or query values of options. val defaults to 1. opt can
! be abbreviated. Several options can be listed.
!
! =over 12
!
! =item recallCommand, ShellBang
!
! The characters used to recall command or spawn shell. By
! default, these are both set to C<!>.
!
! =item pager
!
! Program to use for output of pager-piped commands (those
! beginning with a C<|> character.) By default,
! C<$ENV{PAGER}> will be used.
!
! =back
!
! The following options affect what happens with C<V>, C<X>, and C<x>
! commands:
!
! =over 12
!
! =item arrayDepth, hashDepth
!
! Print only first N elements ('' for all).
!
! =item compactDump, veryCompact
!
! Change style of array and hash dump.
!
! =item globPrint
!
! Whether to print contents of globs.
!
! =item DumpDBFiles
!
! Dump arrays holding debugged files.
!
! =item DumpPackages
!
! Dump symbol tables of packages.
!
! =item quote, HighBit, undefPrint
!
! Change style of string dump.
!
! =item tkRunning
!
! Run Tk while prompting (with ReadLine).
!
! =item signalLevel, warnLevel. dieLevel
!
! Level of verbosity.
!
! =back
!
! 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.
!
! 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:
!
! $ PERLDB_OPTS="N f=2" perl -d myprogram
!
! will run the script C<myprogram> without human intervention, printing
! out the call tree with entry and exit points. Note that C<N f=2> is
! equivalent to C<NonStop=1 frame=2>. Note also that at the moment when
! this documentation was written all the options to the debugger could
! be uniquely abbreviated by the first letter.
!
! See "Debugger Internals" below for more details.
=item < command
***************
*** 156,183 ****
command to return to executing the script. A multiline command may be
entered by backslashing the newlines.
! =item V package [symbols]
!
! Display all (or some) variables in package (defaulting to the C<main>
! package) using a data pretty-printer (hashes show their keys and values so
! you see what's what, control characters are made printable, etc.). Make
! sure you don't put the type specifier (like $) there, just the symbol
! names, like this:
! V DB filename line
! =item X [symbols]
! Same as as "V" command, but within the current package.
! =item ! number
! Redo a debugging command. If number is omitted, redoes the previous
! command.
! =item ! -number
! Redo the command that was that many commands ago.
=item H -number
--- 349,371 ----
command to return to executing the script. A multiline command may be
entered by backslashing the newlines.
! =item ! number
! Redo a previous command (default previous command).
! =item ! -number
! Redo number'th-to-last command.
! =item ! pattern
! Redo last command that started with pattern.
! See C<O recallCommand>, too.
! =item !! cmd
! Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)
! See C<O shellBang> too.
=item H -number
***************
*** 188,193 ****
--- 376,403 ----
Quit. ("quit" doesn't work for this.)
+ =item R
+
+ Restart the debugger by B<exec>ing a new session. It tries to maintain
+ your history across this, but internal settings and command line options
+ may be lost.
+
+ =item |dbcmd
+
+ Run debugger command, piping DB::OUT to current pager.
+
+ =item ||dbcmd
+
+ Same as C<|dbcmd> but DB::OUT is temporarily B<select>ed as well.
+ Often used with commands that would otherwise produce long
+ output, such as
+
+ |V main
+
+ =item = [alias value]
+
+ Define a command alias, or list current aliases.
+
=item command
Execute command as a Perl statement. A missing semicolon will be
***************
*** 200,236 ****
=back
! Any command you type in that isn't recognized by the debugger will be
! directly executed (C<eval>'d) as Perl code. Leading white space will
! cause the debugger to think it's C<NOT> a debugger command.
!
! If you have any compile-time executable statements (code within a BEGIN
! block or a C<use> statement), these will I<NOT> be stopped by debugger,
! although C<require>s will. From your own code, however, you can transfer
! control back to the debugger using the following statement, which is harmless
! if the debugger is not running:
$DB::single = 1;
! =head2 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 environment variable PERL5DB to say something like this:
BEGIN { require "myperl5db.pl" }
You can do some customization by setting up a F<.perldb> file which
contains initialization code. For instance, you could make aliases
! like these (the last one in particular most people seem to expect to
! be there):
! $DB::alias{'len'} = 's/^len(.*)/p length($1)/';
$DB::alias{'stop'} = 's/^stop (at|in)/b/';
! $DB::alias{'.'} = 's/^\./p '
! . '"\$DB::sub(\$DB::filename:\$DB::line):\t"'
! . ',\$DB::dbline[\$DB::line]/' ;
=head2 Other resources
--- 410,599 ----
=back
! The debugger prompt is something like
!
! DB<8>
!
! or even
!
! DB<<17>>
!
! where that number is the command number, which you'd use to access with
! the 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.
!
! If you want to enter a multi-line command, such as a subroutine
! definition with several statements, you may escape the newline that would
! normally end the debugger command with a backslash. Here's an example:
!
! DB<1> for (1..4) { \
! cont: print "ok\n"; \
! cont: }
! ok
! ok
! ok
! ok
!
! Note that this business of escaping a newline is specific to interactive
! commands typed into the debugger.
!
! Here's an example of what a stack backtrace might look like:
!
! $ = main::infested called from file `Ambulation.pm' line 10
! @ = Ambulation::legs(1, 2, 3, 4) called from file `camel_flea' line 7
! $ = main::pests('bactrian', 4) called from file `camel_flea' line 4
!
! The left-hand character up there tells whether the function was called
! in a scalar or list context (we bet you can tell which is which). What
! that says is that you were in the function C<main::infested> when you ran
! the stack dump, and that it was called in a scalar context from line 10
! of the file I<Ambulation.pm>, but without any arguments at all, meaning
! it was called as C<&infested>. The next stack frame shows that the
! function C<Ambulation::legs> was called in a list context from the
! I<camel_flea> file with four arguments. The last stack frame shows that
! C<main::pests> was called in a scalar context, also from I<camel_flea>,
! but from line 4.
!
! 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
! transfer control back to the debugger using the following statement,
! which is harmless if the debugger is not running:
$DB::single = 1;
! If you set C<$DB::single> to the value 2, it's equivalent to having
! just typed the C<n> command, whereas a value of 1 means the C<s>
! command. The C<$DB::trace> variable should be set to 1 to simulate
! having typed the C<t> command.
!
! =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" }
You can do some customization by setting up a F<.perldb> file which
contains initialization code. For instance, you could make aliases
! like these (the last one is one people expect to be there):
! $DB::alias{'len'} = 's/^len(.*)/p length($1)/';
$DB::alias{'stop'} = 's/^stop (at|in)/b/';
! $DB::alias{'ps'} = 's/^ps\b/p scalar /';
! $DB::alias{'quit'} = 's/^quit(\s*)/exit\$/';
!
! =head2 Readline Support
!
! As shipped, the only command line history supplied is a simplistic one
! that checks for leading exclamation points. However, if you install
! the Term::ReadKey and Term::ReadLine modules from CPAN, you will
! have full editing capabilities much like GNU I<readline>(3) provides.
! Look for these in the F<modules/by-module/Term> directory on CPAN.
!
! =head2 Editor Support for Debugging
!
! If you have GNU B<emacs> installed on your system, it can interact with
! the Perl debugger to provide an integrated software development
! environment reminiscent of its interactions with C debuggers.
!
! Perl is also delivered with a start file for making B<emacs> act like a
! syntax-directed editor that understands (some of) Perl's syntax. Look in
! the I<emacs> directory of the Perl source distribution.
!
! (Historically, a similar setup for interacting with B<vi> and the
! X11 window system had also been available, but at the time of this
! writing, no debugger support for B<vi> currently exists.)
!
! =head2 The Perl Profiler
!
! If you wish to supply an alternative debugger for Perl to run, just
! invoke your script with a colon and a package argument given to the B<-d>
! flag. One of the most popular alternative debuggers for Perl is
! B<DProf>, the Perl profiler. As of this writing, B<DProf> is not
! included with the standard Perl distribution, but it is expected to
! be included soon, for certain values of "soon".
!
! Meanwhile, you can fetch the Devel::Dprof module from CPAN. Assuming
! it's properly installed on your system, to profile your Perl program in
! the file F<mycode.pl>, just type:
!
! perl -d:DProf mycode.pl
!
! When the script terminates the profiler will dump the profile information
! to a file called F<tmon.out>. A tool like B<dprofpp> (also supplied with
! the Devel::DProf package) can be used to interpret the information which is
! in that profile.
!
! =head2 Debugger Internals
!
! 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.
!
! 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.
!
! 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.
!
! The following options can only be specified at startup. To set them in
! your rc file, call C<&parse_options("optionName=new_value")>.
+ =over 12
+
+ =item TTY
+
+ 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 ReadLine
+
+ If false, dummy ReadLine is used, so you can debug
+ ReadLine applications.
+
+ =item NonStop
+
+ If true, no I/O is performed until an interrupt.
+
+ =item LineInfo
+
+ File or pipe to print line number info to. If it'sis a
+ pipe, then a short, "emacs like" message is used.
+
+ Example rc file:
+
+ &parse_options("NonStop=1 LineInfo=db.out");
+ sub afterinit { $trace = 1; }
+
+ 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
=head2 Other resources
***************
*** 238,249 ****
=head1 BUGS
! If your program exit()s or die()s, so does the debugger.
! There's no builtin way to restart the debugger without exiting and coming back
! into it. You could use an alias like this:
! $DB::alias{'rerun'} = 'exec "perl -d $DB::filename"';
- But you'd lose any pending breakpoint information, and that might not
- be the right path, etc.
--- 601,611 ----
=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.
#~ Typos corrected
#~ New warnings for duplicate "my" declarations in a single
#~ scope and strict untie
#~ Replace "identifier" with "name"
diff -Pcr perl5_003/pod/perldiag.pod perl5_003_01/pod/perldiag.pod
*** perl5_003/pod/perldiag.pod Tue Feb 27 16:13:42 1996
--- perl5_003_01/pod/perldiag.pod Fri Jul 5 13:55:25 1996
***************
*** 22,28 ****
L<perlfunc/eval>.
Some of these messages are generic. Spots that vary are denoted with a %s,
! just as in a printf format. Note that some message start with a %s!
The symbols C<"%-?@> sort before the letters, while C<[> and C<\> sort after.
=over 4
--- 22,28 ----
L<perlfunc/eval>.
Some of these messages are generic. Spots that vary are denoted with a %s,
! just as in a printf format. Note that some messages start with a %s!
The symbols C<"%-?@> sort before the letters, while C<[> and C<\> sort after.
=over 4
***************
*** 33,38 ****
--- 33,46 ----
to try to declare one with a package qualifier on the front. Use local()
if you want to localize a package variable.
+ =item "my" variable %s masks earlier declaration in same scope
+
+ (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 "no" not allowed in expression
(F) The "no" keyword is recognized and executed at compile time, and returns
***************
*** 144,150 ****
=item @ outside of string
! (F) You had a pack template that specified an absolution position outside
the string being unpacked. See L<perlfunc/pack>.
=item accept() on closed fd
--- 152,158 ----
=item @ outside of string
! (F) You had a pack template that specified an absolute position outside
the string being unpacked. See L<perlfunc/pack>.
=item accept() on closed fd
***************
*** 226,232 ****
=item Bad arg length for %s, is %d, should be %d
(F) You passed a buffer of the wrong size to one of msgctl(), semctl() or
! shmctl(). In C parlance, the correct sized are, respectively,
S<sizeof(struct msqid_ds *)>, S<sizeof(struct semid_ds *)> and
S<sizeof(struct shmid_ds *)>.
--- 234,240 ----
=item Bad arg length for %s, is %d, should be %d
(F) You passed a buffer of the wrong size to one of msgctl(), semctl() or
! shmctl(). In C parlance, the correct sizes are, respectively,
S<sizeof(struct msqid_ds *)>, S<sizeof(struct semid_ds *)> and
S<sizeof(struct shmid_ds *)>.
***************
*** 531,537 ****
=item Can't localize lexical variable %s
! (F) You used local on a variable name that was previous declared as a
lexical variable using "my". This is not allowed. If you want to
localize a package variable of the same name, qualify it with the
package name.
--- 539,545 ----
=item Can't localize lexical variable %s
! (F) You used local on a variable name that was previously declared as a
lexical variable using "my". This is not allowed. If you want to
localize a package variable of the same name, qualify it with the
package name.
***************
*** 548,554 ****
(F) You called a method correctly, and it correctly indicated a package
functioning as a class, but that package doesn't define that particular
! method, nor does any of it's base classes. See L<perlobj>.
=item Can't locate package %s for @%s::ISA
--- 556,562 ----
(F) You called a method correctly, and it correctly indicated a package
functioning as a class, but that package doesn't define that particular
! method, nor does any of its base classes. See L<perlobj>.
=item Can't locate package %s for @%s::ISA
***************
*** 664,669 ****
--- 672,682 ----
(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
***************
*** 713,723 ****
(F) A value used as either a hard reference or a symbolic reference must
be a defined value. This helps to de-lurk some insidious errors.
- =item Can't use delimiter brackets within expression
-
- (F) The ${name} construct is for disambiguating identifiers in strings, not
- in ordinary code.
-
=item Can't use global %s in "my"
(F) You tried to declare a magical variable as a lexical variable. This is
--- 726,731 ----
***************
*** 982,992 ****
(D) Really old Perl let you omit the % on hash names in some spots. This
is now heavily deprecated.
! =item Identifier "%s::%s" used only once: possible typo
! (W) Typographical errors often show up as unique identifiers. If you
! had a good reason for having a unique identifier, then just mention it
! again somehow to suppress the message.
=item Illegal division by zero
--- 990,1001 ----
(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
! (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 Illegal division by zero
***************
*** 1034,1040 ****
(S) A warning peculiar to VMS. Perl keeps track of the number
of times you've called C<fork> and C<exec>, in order to determine
! whether the current call to C<exec> should be affect the current
script or a subprocess (see L<perlvms/exec>). Somehow, this count
has become scrambled, so Perl is making a guess and treating
this C<exec> as a request to terminate the Perl script
--- 1043,1049 ----
(S) A warning peculiar to VMS. Perl keeps track of the number
of times you've called C<fork> and C<exec>, in order to determine
! whether the current call to C<exec> should affect the current
script or a subprocess (see L<perlvms/exec>). Somehow, this count
has become scrambled, so Perl is making a guess and treating
this C<exec> as a request to terminate the Perl script
***************
*** 1669,1675 ****
=item regexp too big
! (F) The current implementation of regular expression uses shorts as
address offsets within a string. Unfortunately this means that if
the regular expression compiles to longer than 32767, it'll blow up.
Usually when you want a regular expression this big, there is a better
--- 1678,1684 ----
=item regexp too big
! (F) The current implementation of regular expressions uses shorts as
address offsets within a string. Unfortunately this means that if
the regular expression compiles to longer than 32767, it'll blow up.
Usually when you want a regular expression this big, there is a better
***************
*** 2236,2242 ****
=item Warning: unable to close filehandle %s properly.
(S) The implicit close() done by an open() got an error indication on the
! close(0. This usually indicates your filesystem ran out of disk space.
=item Warning: Use of "%s" without parens is ambiguous
--- 2245,2251 ----
=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.
=item Warning: Use of "%s" without parens is ambiguous
#~ Typos corrected; whitespace trimmed
#~ Update references to debugger
diff -Pcr perl5_003/pod/perldsc.pod perl5_003_01/pod/perldsc.pod
*** perl5_003/pod/perldsc.pod Tue Jan 30 13:21:01 1996
--- perl5_003_01/pod/perldsc.pod Mon Jul 8 09:21:32 1996
***************
*** 21,27 ****
for $x (1 .. 10) {
for $y (1 .. 10) {
for $z (1 .. 10) {
! $LoL[$x][$y][$z] =
$x ** $y + $z;
}
}
--- 21,27 ----
for $x (1 .. 10) {
for $y (1 .. 10) {
for $z (1 .. 10) {
! $LoL[$x][$y][$z] =
$x ** $y + $z;
}
}
***************
*** 34,40 ****
you sort it? How can you pass it to a function or get one of these back
from a function? Is is an object? Can you save it to disk to read
back later? How do you access whole rows or columns of that matrix? Do
! all the values have to be numeric?
As you see, it's quite easy to become confused. While some small portion
of the blame for this can be attributed to the reference-based
--- 34,40 ----
you sort it? How can you pass it to a function or get one of these back
from a function? Is is an object? Can you save it to disk to read
back later? How do you access whole rows or columns of that matrix? Do
! all the values have to be numeric?
As you see, it's quite easy to become confused. While some small portion
of the blame for this can be attributed to the reference-based
***************
*** 69,75 ****
=back
But for now, let's look at some of the general issues common to all
! of these types of data structures.
=head1 REFERENCES
--- 69,75 ----
=back
But for now, let's look at some of the general issues common to all
! of these types of data structures.
=head1 REFERENCES
***************
*** 84,97 ****
you would a real array or hash. For C or C++ programmers unused to distinguishing
between arrays and pointers to the same, this can be confusing. If so,
just think of it as the difference between a structure and a pointer to a
! structure.
You can (and should) read more about references in the perlref(1) man
page. Briefly, references are rather like pointers that know what they
point to. (Objects are also a kind of reference, but we won't be needing
! them right away--if ever.) That means that when you have something that
! looks to you like an access to two-or-more-dimensional array and/or hash,
! that what's really going on is that in all these cases, the base type is
merely a one-dimensional entity that contains references to the next
level. It's just that you can I<use> it as though it were a
two-dimensional one. This is actually the way almost all C
--- 84,97 ----
you would a real array or hash. For C or C++ programmers unused to distinguishing
between arrays and pointers to the same, this can be confusing. If so,
just think of it as the difference between a structure and a pointer to a
! structure.
You can (and should) read more about references in the perlref(1) man
page. Briefly, references are rather like pointers that know what they
point to. (Objects are also a kind of reference, but we won't be needing
! them right away--if ever.) This means that when you have something which
! looks to you like an access to a two-or-more-dimensional array and/or hash,
! what's really going on is that the base type is
merely a one-dimensional entity that contains references to the next
level. It's just that you can I<use> it as though it were a
two-dimensional one. This is actually the way almost all C
***************
*** 130,136 ****
for $i (1..10) {
@list = somefunc($i);
$LoL[$i] = @list; # WRONG!
! }
That's just the simple case of assigning a list to a scalar and getting
its element count. If that's what you really and truly want, then you
--- 130,136 ----
for $i (1..10) {
@list = somefunc($i);
$LoL[$i] = @list; # WRONG!
! }
That's just the simple case of assigning a list to a scalar and getting
its element count. If that's what you really and truly want, then you
***************
*** 139,145 ****
for $i (1..10) {
@list = somefunc($i);
$counts[$i] = scalar @list;
! }
Here's the case of taking a reference to the same memory location
again and again:
--- 139,145 ----
for $i (1..10) {
@list = somefunc($i);
$counts[$i] = scalar @list;
! }
Here's the case of taking a reference to the same memory location
again and again:
***************
*** 147,153 ****
for $i (1..10) {
@list = somefunc($i);
$LoL[$i] = \@list; # WRONG!
! }
So, just what's the big problem with that? It looks right, doesn't it?
After all, I just told you that you need an array of references, so by
--- 147,153 ----
for $i (1..10) {
@list = somefunc($i);
$LoL[$i] = \@list; # WRONG!
! }
So, just what's the big problem with that? It looks right, doesn't it?
After all, I just told you that you need an array of references, so by
***************
*** 164,192 ****
rp = getpwnam("root");
dp = getpwnam("daemon");
! printf("daemon name is %s\nroot name is %s\n",
dp->pw_name, rp->pw_name);
}
Which will print
daemon name is daemon
! root name is daemon
The problem is that both C<rp> and C<dp> are pointers to the same location
in memory! In C, you'd have to remember to malloc() yourself some new
memory. In Perl, you'll want to use the array constructor C<[]> or the
hash constructor C<{}> instead. Here's the right way to do the preceding
! broken code fragments
for $i (1..10) {
@list = somefunc($i);
$LoL[$i] = [ @list ];
! }
The square brackets make a reference to a new array with a I<copy>
of what's in @list at the time of the assignment. This is what
! you want.
Note that this will produce something similar, but it's
much harder to read:
--- 164,192 ----
rp = getpwnam("root");
dp = getpwnam("daemon");
! printf("daemon name is %s\nroot name is %s\n",
dp->pw_name, rp->pw_name);
}
Which will print
daemon name is daemon
! root name is daemon
The problem is that both C<rp> and C<dp> are pointers to the same location
in memory! In C, you'd have to remember to malloc() yourself some new
memory. In Perl, you'll want to use the array constructor C<[]> or the
hash constructor C<{}> instead. Here's the right way to do the preceding
! broken code fragments:
for $i (1..10) {
@list = somefunc($i);
$LoL[$i] = [ @list ];
! }
The square brackets make a reference to a new array with a I<copy>
of what's in @list at the time of the assignment. This is what
! you want.
Note that this will produce something similar, but it's
much harder to read:
***************
*** 194,200 ****
for $i (1..10) {
@list = 0 .. $i;
@{$LoL[$i]} = @list;
! }
Is it the same? Well, maybe so--and maybe not. The subtle difference
is that when you assign something in square brackets, you know for sure
--- 194,200 ----
for $i (1..10) {
@list = 0 .. $i;
@{$LoL[$i]} = @list;
! }
Is it the same? Well, maybe so--and maybe not. The subtle difference
is that when you assign something in square brackets, you know for sure
***************
*** 220,226 ****
So just remember to always use the array or hash constructors with C<[]>
or C<{}>, and you'll be fine, although it's not always optimally
! efficient.
Surprisingly, the following dangerous-looking construct will
actually work out fine:
--- 220,226 ----
So just remember to always use the array or hash constructors with C<[]>
or C<{}>, and you'll be fine, although it's not always optimally
! efficient.
Surprisingly, the following dangerous-looking construct will
actually work out fine:
***************
*** 228,234 ****
for $i (1..10) {
my @list = somefunc($i);
$LoL[$i] = \@list;
! }
That's because my() is more of a run-time statement than it is a
compile-time declaration I<per se>. This means that the my() variable is
--- 228,234 ----
for $i (1..10) {
my @list = somefunc($i);
$LoL[$i] = \@list;
! }
That's because my() is more of a run-time statement than it is a
compile-time declaration I<per se>. This means that the my() variable is
***************
*** 251,257 ****
@{ $LoL[$i] } = @list; # way too tricky for most programmers
! =head1 CAVEAT ON PRECEDENCE
Speaking of things like C<@{$LoL[$i]}>, the following are actually the
same thing:
--- 251,257 ----
@{ $LoL[$i] } = @list; # way too tricky for most programmers
! =head1 CAVEAT ON PRECEDENCE
Speaking of things like C<@{$LoL[$i]}>, the following are actually the
same thing:
***************
*** 303,318 ****
=head1 DEBUGGING
! The standard Perl debugger in 5.001 doesn't do a very nice job of
! printing out complex data structures. However, the perl5db that
! Ilya Zakharevich E<lt>F<ilya@math.ohio-state.edu>E<gt>
! wrote, which is accessible at
!
! ftp://ftp.perl.com/pub/perl/ext/perl5db-kit-0.9.tar.gz
!
! has several new features, including command line editing as well
! as the C<x> command to dump out complex data structures. For example,
! given the assignment to $LoL above, here's the debugger output:
DB<1> X $LoL
$LoL = ARRAY(0x13b5a0)
--- 303,313 ----
=head1 DEBUGGING
! Before 5.002, the standard Perl debugger didn't do a very nice job of
! printing out complex data structures. With version 5.002 or above, the
! debugger includes several new features, including command line editing as
! well as the C<x> command to dump out complex data structures. For
! example, given the assignment to $LoL above, here's the debugger output:
DB<1> X $LoL
$LoL = ARRAY(0x13b5a0)
***************
*** 338,344 ****
=head1 CODE EXAMPLES
Presented with little comment (these will get their own man pages someday)
! here are short code examples illustrating access of various
types of data structures.
=head1 LISTS OF LISTS
--- 333,339 ----
=head1 CODE EXAMPLES
Presented with little comment (these will get their own man pages someday)
! here are short code examples illustrating access of various
types of data structures.
=head1 LISTS OF LISTS
***************
*** 356,373 ****
# reading from file
while ( <> ) {
push @LoL, [ split ];
!
# calling a function
for $i ( 1 .. 10 ) {
$LoL[$i] = [ somefunc($i) ];
!
# using temp vars
for $i ( 1 .. 10 ) {
@tmp = somefunc($i);
$LoL[$i] = [ @tmp ];
!
# add to an existing row
push @{ $LoL[0] }, "wilma", "betty";
--- 351,368 ----
# reading from file
while ( <> ) {
push @LoL, [ split ];
! }
# calling a function
for $i ( 1 .. 10 ) {
$LoL[$i] = [ somefunc($i) ];
! }
# using temp vars
for $i ( 1 .. 10 ) {
@tmp = somefunc($i);
$LoL[$i] = [ @tmp ];
! }
# add to an existing row
push @{ $LoL[0] }, "wilma", "betty";
***************
*** 383,401 ****
# print the whole thing with refs
for $aref ( @LoL ) {
print "\t [ @$aref ],\n";
!
# print the whole thing with indices
for $i ( 0 .. $#LoL ) {
print "\t [ @{$LoL[$i]} ],\n";
!
# print the whole thing one at a time
for $i ( 0 .. $#LoL ) {
for $j ( 0 .. $#{$LoL[$i]} ) {
print "elt $i $j is $LoL[$i][$j]\n";
}
!
=head1 HASHES OF LISTS
--- 378,396 ----
# print the whole thing with refs
for $aref ( @LoL ) {
print "\t [ @$aref ],\n";
! }
# print the whole thing with indices
for $i ( 0 .. $#LoL ) {
print "\t [ @{$LoL[$i]} ],\n";
! }
# print the whole thing one at a time
for $i ( 0 .. $#LoL ) {
for $j ( 0 .. $#{$LoL[$i]} ) {
print "elt $i $j is $LoL[$i][$j]\n";
}
! }
=head1 HASHES OF LISTS
***************
*** 414,420 ****
while ( <> ) {
next unless s/^(.*?):\s*//;
$HoL{$1} = [ split ];
!
# reading from file; more temps
# flintstones: fred barney wilma dino
--- 409,415 ----
while ( <> ) {
next unless s/^(.*?):\s*//;
$HoL{$1} = [ split ];
! }
# reading from file; more temps
# flintstones: fred barney wilma dino
***************
*** 422,439 ****
($who, $rest) = split /:\s*/, $line, 2;
@fields = split ' ', $rest;
$HoL{$who} = [ @fields ];
!
# calling a function that returns a list
for $group ( "simpsons", "jetsons", "flintstones" ) {
$HoL{$group} = [ get_family($group) ];
!
# likewise, but using temps
for $group ( "simpsons", "jetsons", "flintstones" ) {
@members = get_family($group);
$HoL{$group} = [ @members ];
!
# append new members to an existing family
push @{ $HoL{"flintstones"} }, "wilma", "betty";
--- 417,434 ----
($who, $rest) = split /:\s*/, $line, 2;
@fields = split ' ', $rest;
$HoL{$who} = [ @fields ];
! }
# calling a function that returns a list
for $group ( "simpsons", "jetsons", "flintstones" ) {
$HoL{$group} = [ get_family($group) ];
! }
# likewise, but using temps
for $group ( "simpsons", "jetsons", "flintstones" ) {
@members = get_family($group);
$HoL{$group} = [ @members ];
! }
# append new members to an existing family
push @{ $HoL{"flintstones"} }, "wilma", "betty";
***************
*** 449,455 ****
# print the whole thing
foreach $family ( keys %HoL ) {
print "$family: @{ $HoL{$family} }\n"
!
# print the whole thing with indices
foreach $family ( keys %HoL ) {
--- 444,450 ----
# print the whole thing
foreach $family ( keys %HoL ) {
print "$family: @{ $HoL{$family} }\n"
! }
# print the whole thing with indices
foreach $family ( keys %HoL ) {
***************
*** 458,472 ****
print " $i = $HoL{$family}[$i]";
}
print "\n";
!
# print the whole thing sorted by number of members
foreach $family ( sort { @{$HoL{$b}} <=> @{$HoL{$b}} } keys %HoL ) {
print "$family: @{ $HoL{$family} }\n"
# print the whole thing sorted by number of members and name
foreach $family ( sort { @{$HoL{$b}} <=> @{$HoL{$a}} } keys %HoL ) {
print "$family: ", join(", ", sort @{ $HoL{$family}), "\n";
=head1 LISTS OF HASHES
--- 453,469 ----
print " $i = $HoL{$family}[$i]";
}
print "\n";
! }
# print the whole thing sorted by number of members
foreach $family ( sort { @{$HoL{$b}} <=> @{$HoL{$b}} } keys %HoL ) {
print "$family: @{ $HoL{$family} }\n"
+ }
# print the whole thing sorted by number of members and name
foreach $family ( sort { @{$HoL{$b}} <=> @{$HoL{$a}} } keys %HoL ) {
print "$family: ", join(", ", sort @{ $HoL{$family}), "\n";
+ }
=head1 LISTS OF HASHES
***************
*** 474,481 ****
@LoH = (
{
! Lead => "fred",
! Friend => "barney",
},
{
Lead => "george",
--- 471,478 ----
@LoH = (
{
! Lead => "fred",
! Friend => "barney",
},
{
Lead => "george",
***************
*** 500,505 ****
--- 497,503 ----
$rec->{$key} = $value;
}
push @LoH, $rec;
+ }
# reading from file
***************
*** 507,536 ****
# no temp
while ( <> ) {
push @LoH, { split /[\s+=]/ };
!
# calling a function that returns a key,value list, like
# "lead","fred","daughter","pebbles"
while ( %fields = getnextpairset() )
push @LoH, { %fields };
!
# likewise, but using no temp vars
while (<>) {
push @LoH, { parsepairs($_) };
!
# add key/value to an element
! $LoH[0]{"pet"} = "dino";
! $LoH[2]{"pet"} = "santa's little helper";
=head2 Access and Printing of a LIST OF HASHES
# one element
! $LoH[0]{"lead"} = "fred";
# another element
! $LoH[1]{"lead"} =~ s/(\w)/\u$1/;
# print the whole thing with refs
for $href ( @LoH ) {
--- 505,534 ----
# no temp
while ( <> ) {
push @LoH, { split /[\s+=]/ };
! }
# calling a function that returns a key,value list, like
# "lead","fred","daughter","pebbles"
while ( %fields = getnextpairset() )
push @LoH, { %fields };
! }
# likewise, but using no temp vars
while (<>) {
push @LoH, { parsepairs($_) };
! }
# add key/value to an element
! $LoH[0]{pet} = "dino";
! $LoH[2]{pet} = "santa's little helper";
=head2 Access and Printing of a LIST OF HASHES
# one element
! $LoH[0]{lead} = "fred";
# another element
! $LoH[1]{lead} =~ s/(\w)/\u$1/;
# print the whole thing with refs
for $href ( @LoH ) {
***************
*** 539,545 ****
print "$role=$href->{$role} ";
}
print "}\n";
!
# print the whole thing with indices
for $i ( 0 .. $#LoH ) {
--- 537,543 ----
print "$role=$href->{$role} ";
}
print "}\n";
! }
# print the whole thing with indices
for $i ( 0 .. $#LoH ) {
***************
*** 548,560 ****
print "$role=$LoH[$i]{$role} ";
}
print "}\n";
!
# print the whole thing one at a time
for $i ( 0 .. $#LoH ) {
for $role ( keys %{ $LoH[$i] } ) {
print "elt $i $role is $LoH[$i]{$role}\n";
}
=head1 HASHES OF HASHES
--- 546,559 ----
print "$role=$LoH[$i]{$role} ";
}
print "}\n";
! }
# print the whole thing one at a time
for $i ( 0 .. $#LoH ) {
for $role ( keys %{ $LoH[$i] } ) {
print "elt $i $role is $LoH[$i]{$role}\n";
}
+ }
=head1 HASHES OF HASHES
***************
*** 566,580 ****
"pal" => "barney",
},
"jetsons" => {
! "lead" => "george",
! "wife" => "jane",
! "his boy"=> "elroy",
! }
"simpsons" => {
"lead" => "homer",
"wife" => "marge",
"kid" => "bart",
! );
=head2 Generation of a HASH OF HASHES
--- 565,580 ----
"pal" => "barney",
},
"jetsons" => {
! "lead" => "george",
! "wife" => "jane",
! "his boy" => "elroy",
! },
"simpsons" => {
"lead" => "homer",
"wife" => "marge",
"kid" => "bart",
! },
! );
=head2 Generation of a HASH OF HASHES
***************
*** 599,636 ****
($key, $value) = split /=/, $field;
$rec->{$key} = $value;
}
!
# calling a function that returns a key,value list, like
# "lead","fred","daughter","pebbles"
while ( %fields = getnextpairset() )
push @a, { %fields };
!
# calling a function that returns a key,value hash
for $group ( "simpsons", "jetsons", "flintstones" ) {
$HoH{$group} = { get_family($group) };
!
# likewise, but using temps
for $group ( "simpsons", "jetsons", "flintstones" ) {
%members = get_family($group);
$HoH{$group} = { %members };
!
# append new members to an existing family
%new_folks = (
"wife" => "wilma",
"pet" => "dino";
);
for $what (keys %new_folks) {
$HoH{flintstones}{$what} = $new_folks{$what};
!
=head2 Access and Printing of a HASH OF HASHES
# one element
! $HoH{"flintstones"}{"wife"} = "wilma";
# another element
$HoH{simpsons}{lead} =~ s/(\w)/\u$1/;
--- 599,637 ----
($key, $value) = split /=/, $field;
$rec->{$key} = $value;
}
! }
# calling a function that returns a key,value list, like
# "lead","fred","daughter","pebbles"
while ( %fields = getnextpairset() )
push @a, { %fields };
! }
# calling a function that returns a key,value hash
for $group ( "simpsons", "jetsons", "flintstones" ) {
$HoH{$group} = { get_family($group) };
! }
# likewise, but using temps
for $group ( "simpsons", "jetsons", "flintstones" ) {
%members = get_family($group);
$HoH{$group} = { %members };
! }
# append new members to an existing family
%new_folks = (
"wife" => "wilma",
"pet" => "dino";
);
+
for $what (keys %new_folks) {
$HoH{flintstones}{$what} = $new_folks{$what};
! }
=head2 Access and Printing of a HASH OF HASHES
# one element
! $HoH{flintstones}{wife} = "wilma";
# another element
$HoH{simpsons}{lead} =~ s/(\w)/\u$1/;
***************
*** 638,666 ****
# print the whole thing
foreach $family ( keys %HoH ) {
print "$family: ";
! for $role ( keys %{ $HoH{$family} } {
print "$role=$HoH{$family}{$role} ";
}
print "}\n";
!
# print the whole thing somewhat sorted
foreach $family ( sort keys %HoH ) {
print "$family: ";
! for $role ( sort keys %{ $HoH{$family} } {
print "$role=$HoH{$family}{$role} ";
}
print "}\n";
# print the whole thing sorted by number of members
foreach $family ( sort { keys %{$HoH{$b}} <=> keys %{$HoH{$b}} } keys %HoH ) {
print "$family: ";
! for $role ( sort keys %{ $HoH{$family} } {
print "$role=$HoH{$family}{$role} ";
}
print "}\n";
!
# establish a sort order (rank) for each role
$i = 0;
--- 639,668 ----
# print the whole thing
foreach $family ( keys %HoH ) {
print "$family: ";
! for $role ( keys %{ $HoH{$family} } ) {
print "$role=$HoH{$family}{$role} ";
}
print "}\n";
! }
# print the whole thing somewhat sorted
foreach $family ( sort keys %HoH ) {
print "$family: ";
! for $role ( sort keys %{ $HoH{$family} } ) {
print "$role=$HoH{$family}{$role} ";
}
print "}\n";
+ }
# print the whole thing sorted by number of members
foreach $family ( sort { keys %{$HoH{$b}} <=> keys %{$HoH{$b}} } keys %HoH ) {
print "$family: ";
! for $role ( sort keys %{ $HoH{$family} } ) {
print "$role=$HoH{$family}{$role} ";
}
print "}\n";
! }
# establish a sort order (rank) for each role
$i = 0;
***************
*** 670,679 ****
foreach $family ( sort { keys %{$HoH{$b}} <=> keys %{$HoH{$b}} } keys %HoH ) {
print "$family: ";
# and print these according to rank order
! for $role ( sort { $rank{$a} <=> $rank{$b} keys %{ $HoH{$family} } {
print "$role=$HoH{$family}{$role} ";
}
print "}\n";
=head1 MORE ELABORATE RECORDS
--- 672,682 ----
foreach $family ( sort { keys %{$HoH{$b}} <=> keys %{$HoH{$b}} } keys %HoH ) {
print "$family: ";
# and print these according to rank order
! for $role ( sort { $rank{$a} <=> $rank{$b} keys %{ $HoH{$family} } ) {
print "$role=$HoH{$family}{$role} ";
}
print "}\n";
+ }
=head1 MORE ELABORATE RECORDS
***************
*** 684,731 ****
many different sorts:
$rec = {
! STRING => $string,
! LIST => [ @old_values ],
! LOOKUP => { %some_table },
! FUNC => \&some_function,
! FANON => sub { $_[0] ** $_[1] },
! FH => \*STDOUT,
};
! print $rec->{STRING};
print $rec->{LIST}[0];
! $last = pop @ { $rec->{LIST} };
print $rec->{LOOKUP}{"key"};
($first_k, $first_v) = each %{ $rec->{LOOKUP} };
! $answer = &{ $rec->{FUNC} }($arg);
! $answer = &{ $rec->{FANON} }($arg1, $arg2);
# careful of extra block braces on fh ref
! print { $rec->{FH} } "a string\n";
use FileHandle;
! $rec->{FH}->autoflush(1);
! $rec->{FH}->print(" a string\n");
=head2 Declaration of a HASH OF COMPLEX RECORDS
%TV = (
"flintstones" => {
series => "flintstones",
! nights => [ qw(monday thursday friday) ];
members => [
{ name => "fred", role => "lead", age => 36, },
{ name => "wilma", role => "wife", age => 31, },
! { name => "pebbles", role => "kid", age => 4, },
],
},
"jetsons" => {
series => "jetsons",
! nights => [ qw(wednesday saturday) ];
members => [
{ name => "george", role => "lead", age => 41, },
{ name => "jane", role => "wife", age => 39, },
--- 687,734 ----
many different sorts:
$rec = {
! TEXT => $string,
! SEQUENCE => [ @old_values ],
! LOOKUP => { %some_table },
! THATCODE => \&some_function,
! THISCODE => sub { $_[0] ** $_[1] },
! HANDLE => \*STDOUT,
};
! print $rec->{TEXT};
print $rec->{LIST}[0];
! $last = pop @ { $rec->{SEQUENCE} };
print $rec->{LOOKUP}{"key"};
($first_k, $first_v) = each %{ $rec->{LOOKUP} };
! $answer = &{ $rec->{THATCODE} }($arg);
! $answer = &{ $rec->{THISCODE} }($arg1, $arg2);
# careful of extra block braces on fh ref
! print { $rec->{HANDLE} } "a string\n";
use FileHandle;
! $rec->{HANDLE}->autoflush(1);
! $rec->{HANDLE}->print(" a string\n");
=head2 Declaration of a HASH OF COMPLEX RECORDS
%TV = (
"flintstones" => {
series => "flintstones",
! nights => [ qw(monday thursday friday) ],
members => [
{ name => "fred", role => "lead", age => 36, },
{ name => "wilma", role => "wife", age => 31, },
! { name => "pebbles", role => "kid", age => 4, },
],
},
"jetsons" => {
series => "jetsons",
! nights => [ qw(wednesday saturday) ],
members => [
{ name => "george", role => "lead", age => 41, },
{ name => "jane", role => "wife", age => 39, },
***************
*** 735,741 ****
"simpsons" => {
series => "simpsons",
! nights => [ qw(monday) ];
members => [
{ name => "homer", role => "lead", age => 34, },
{ name => "marge", role => "wife", age => 37, },
--- 738,744 ----
"simpsons" => {
series => "simpsons",
! nights => [ qw(monday) ],
members => [
{ name => "homer", role => "lead", age => 34, },
{ name => "marge", role => "wife", age => 37, },
***************
*** 832,837 ****
Tom Christiansen E<lt>F<tchrist@perl.com>E<gt>
! Last update:
! Tue Dec 12 09:20:26 MST 1995
!
--- 835,839 ----
Tom Christiansen E<lt>F<tchrist@perl.com>E<gt>
! Last update:
! Mon Jul 8 05:22:49 MDT 1996
#~ Whitespace trimmed
#~ Include references to ExtUtils::Embed
#~ Wrap long lines in examples
#~ Expanded discussion of dynamic loading from embedded Perl
diff -Pcr perl5_003/pod/perlembed.pod perl5_003_01/pod/perlembed.pod
*** perl5_003/pod/perlembed.pod Tue Jan 30 13:21:14 1996
--- perl5_003_01/pod/perlembed.pod Fri Jul 5 14:33:53 1996
***************
*** 10,33 ****
=over 5
! =item B<Use C from Perl?>
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>.
! =item B<Use Perl from Perl?>
! Read about L<perlfunc/do> and L<perlfunc/eval> and L<perlmod/use>
and L<perlmod/require>.
! =item B<Use C from C?>
Rethink your design.
! =item B<Use Perl from C?>
Read on...
--- 10,33 ----
=over 5
! =item B<Use C from Perl?>
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>.
! =item B<Use Perl from Perl?>
! Read about L<perlfunc/do> and L<perlfunc/eval> and L<perlmod/use>
and L<perlmod/require>.
! =item B<Use C from C?>
Rethink your design.
! =item B<Use Perl from C?>
Read on...
***************
*** 37,43 ****
L<Compiling your C program>
! There's one example in each of the five sections:
L<Adding a Perl interpreter to your C program>
--- 37,43 ----
L<Compiling your C program>
! There's one example in each of the six sections:
L<Adding a Perl interpreter to your C program>
***************
*** 49,59 ****
L<Fiddling with the Perl stack from your C program>
This documentation is UNIX specific.
=head2 Compiling your C program
! Every C program that uses Perl must link in the I<perl library>.
What's that, you ask? Perl is itself written in C; the perl library
is the collection of compiled C programs that were used to create your
--- 49,61 ----
L<Fiddling with the Perl stack from your C program>
+ L<Using Perl modules, which themselves use C libraries, from your C program>
+
This documentation is UNIX specific.
=head2 Compiling your C program
! Every C program that uses Perl must link in the I<perl library>.
What's that, you ask? Perl is itself written in C; the perl library
is the collection of compiled C programs that were used to create your
***************
*** 64,70 ****
I<lib> directory.)
Your C program will--usually--allocate, "run", and deallocate a
! I<PerlInterpreter> object, which is defined in the perl library.
If your copy of Perl is recent enough to contain this documentation
(5.002 or later), then the perl library (and I<EXTERN.h> and
--- 66,72 ----
I<lib> directory.)
Your C program will--usually--allocate, "run", and deallocate a
! I<PerlInterpreter> object, which is defined in the perl library.
If your copy of Perl is recent enough to contain this documentation
(5.002 or later), then the perl library (and I<EXTERN.h> and
***************
*** 83,95 ****
Execute this statement for a hint about where to find CORE:
! perl -e 'use Config; print $Config{archlib}'
Here's how you might compile the example in the next section,
L<Adding a Perl interpreter to your C program>,
on a DEC Alpha running the OSF operating system:
! % cc -o interp interp.c -L/usr/local/lib/perl5/alpha-dec_osf/CORE
-I/usr/local/lib/perl5/alpha-dec_osf/CORE -lperl -lm
You'll have to choose the appropriate compiler (I<cc>, I<gcc>, et al.) and
--- 85,97 ----
Execute this statement for a hint about where to find CORE:
! perl -MConfig -e 'print $Config{archlib}'
Here's how you might compile the example in the next section,
L<Adding a Perl interpreter to your C program>,
on a DEC Alpha running the OSF operating system:
! % cc -o interp interp.c -L/usr/local/lib/perl5/alpha-dec_osf/CORE
-I/usr/local/lib/perl5/alpha-dec_osf/CORE -lperl -lm
You'll have to choose the appropriate compiler (I<cc>, I<gcc>, et al.) and
***************
*** 97,108 ****
compiler complains that certain functions are undefined, or that it
can't locate I<-lperl>, then you need to change the path following the
-L. If it complains that it can't find I<EXTERN.h> or I<perl.h>, you need
! to change the path following the -I.
You may have to add extra libraries as well. Which ones?
! Perhaps those printed by
- perl -e 'use Config; print $Config{libs}'
=head2 Adding a Perl interpreter to your C program
--- 99,121 ----
compiler complains that certain functions are undefined, or that it
can't locate I<-lperl>, then you need to change the path following the
-L. If it complains that it can't find I<EXTERN.h> or I<perl.h>, you need
! to change the path following the -I.
You may have to add extra libraries as well. Which ones?
! Perhaps those printed by
!
! perl -MConfig -e 'print $Config{libs}'
!
! We strongly recommend you use the B<ExtUtils::Embed> module to determine
! all of this information for you:
!
! % cc -o interp interp.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
!
!
! If the B<ExtUtils::Embed> module is not part of your perl kit's
! distribution you can retrieve it from:
! http://www.perl.com/cgi-bin/cpan_mod?module=ExtUtils::Embed.
=head2 Adding a Perl interpreter to your C program
***************
*** 114,136 ****
#include <stdio.h>
#include <EXTERN.h> /* from the Perl distribution */
#include <perl.h> /* from the Perl distribution */
!
static PerlInterpreter *my_perl; /*** The Perl interpreter ***/
!
int main(int argc, char **argv, char **env)
{
my_perl = perl_alloc();
perl_construct(my_perl);
! perl_parse(my_perl, NULL, argc, argv, env);
perl_run(my_perl);
perl_destruct(my_perl);
perl_free(my_perl);
}
Now compile this program (I'll call it I<interp.c>) into an executable:
! % cc -o interp interp.c -L/usr/local/lib/perl5/alpha-dec_osf/CORE
! -I/usr/local/lib/perl5/alpha-dec_osf/CORE -lperl -lm
After a successful compilation, you'll be able to use I<interp> just
like perl itself:
--- 127,154 ----
#include <stdio.h>
#include <EXTERN.h> /* from the Perl distribution */
#include <perl.h> /* from the Perl distribution */
!
static PerlInterpreter *my_perl; /*** The Perl interpreter ***/
!
int main(int argc, char **argv, char **env)
{
my_perl = perl_alloc();
perl_construct(my_perl);
! perl_parse(my_perl, NULL, argc, argv, (char **)NULL);
perl_run(my_perl);
perl_destruct(my_perl);
perl_free(my_perl);
}
+ 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,
+ we hand it a B<NULL> instead, in which case the current environment
+ is used.
+
Now compile this program (I'll call it I<interp.c>) into an executable:
! % cc -o interp interp.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
After a successful compilation, you'll be able to use I<interp> just
like perl itself:
***************
*** 149,155 ****
You can also read and execute Perl statements from a file while in the
midst of your C program, by placing the filename in I<argv[1]> before
! calling I<perl_run()>.
=head2 Calling a Perl subroutine from your C program
--- 167,173 ----
You can also read and execute Perl statements from a file while in the
midst of your C program, by placing the filename in I<argv[1]> before
! calling I<perl_run()>.
=head2 Calling a Perl subroutine from your C program
***************
*** 160,176 ****
#include <stdio.h>
#include <EXTERN.h>
! #include <perl.h>
!
! static PerlInterpreter *my_perl;
!
int main(int argc, char **argv, char **env)
{
my_perl = perl_alloc();
perl_construct(my_perl);
!
! perl_parse(my_perl, NULL, argc, argv, env);
!
/*** This replaces perl_run() ***/
perl_call_argv("showtime", G_DISCARD | G_NOARGS, argv);
perl_destruct(my_perl);
--- 178,194 ----
#include <stdio.h>
#include <EXTERN.h>
! #include <perl.h>
!
! static PerlInterpreter *my_perl;
!
int main(int argc, char **argv, char **env)
{
my_perl = perl_alloc();
perl_construct(my_perl);
!
! perl_parse(my_perl, NULL, argc, argv, NULL);
!
/*** This replaces perl_run() ***/
perl_call_argv("showtime", G_DISCARD | G_NOARGS, argv);
perl_destruct(my_perl);
***************
*** 178,199 ****
}
where I<showtime> is a Perl subroutine that takes no arguments (that's the
! I<G_NOARGS>) and for which I'll ignore the return value (that's the
I<G_DISCARD>). Those flags, and others, are discussed in L<perlcall>.
I'll define the I<showtime> subroutine in a file called I<showtime.pl>:
print "I shan't be printed.";
!
sub showtime {
print time;
}
Simple enough. Now compile and run:
! % cc -o showtime showtime.c -L/usr/local/lib/perl5/alpha-dec_osf/CORE
! -I/usr/local/lib/perl5/alpha-dec_osf/CORE -lperl -lm
!
% showtime showtime.pl
818284590
--- 196,216 ----
}
where I<showtime> is a Perl subroutine that takes no arguments (that's the
! I<G_NOARGS>) and for which I'll ignore the return value (that's the
I<G_DISCARD>). Those flags, and others, are discussed in L<perlcall>.
I'll define the I<showtime> subroutine in a file called I<showtime.pl>:
print "I shan't be printed.";
!
sub showtime {
print time;
}
Simple enough. Now compile and run:
! % cc -o showtime showtime.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
!
% showtime showtime.pl
818284590
***************
*** 203,209 ****
If you want to pass some arguments to the Perl subroutine, or
you want to access the return value, you'll need to manipulate the
! Perl stack, demonstrated in the last section of this document:
L<Fiddling with the Perl stack from your C program>
=head2 Evaluating a Perl statement from your C program
--- 220,226 ----
If you want to pass some arguments to the Perl subroutine, or
you want to access the return value, you'll need to manipulate the
! Perl stack, demonstrated in the last section of this document:
L<Fiddling with the Perl stack from your C program>
=head2 Evaluating a Perl statement from your C program
***************
*** 213,238 ****
features that enable A Better Way (such as with L<perlguts/perl_eval_sv>).
Look for updates to this document soon.
! One way to evaluate a Perl string is to define a function (we'll call
ours I<perl_eval()>) that wraps around Perl's L<perlfunc/eval>.
Arguably, this is the only routine you'll ever need to execute
snippets of Perl code from within your C program. Your string can be
as long as you wish; it can contain multiple statements; it can
use L<perlmod/require> or L<perlfunc/do> to include external Perl
! files.
! Our I<perl_eval()> lets us evaluate individual Perl strings, and then
! extract variables for coercion into C types. The following program,
I<string.c>, executes three Perl strings, extracting an C<int> from
the first, a C<float> from the second, and a C<char *> from the third.
#include <stdio.h>
#include <EXTERN.h>
#include <perl.h>
!
static PerlInterpreter *my_perl;
!
int perl_eval(char *string)
{
char *argv[2];
--- 230,255 ----
features that enable A Better Way (such as with L<perlguts/perl_eval_sv>).
Look for updates to this document soon.
! One way to evaluate a Perl string is to define a function (we'll call
ours I<perl_eval()>) that wraps around Perl's L<perlfunc/eval>.
Arguably, this is the only routine you'll ever need to execute
snippets of Perl code from within your C program. Your string can be
as long as you wish; it can contain multiple statements; it can
use L<perlmod/require> or L<perlfunc/do> to include external Perl
! files.
! Our I<perl_eval()> lets us evaluate individual Perl strings, and then
! extract variables for coercion into C types. The following program,
I<string.c>, executes three Perl strings, extracting an C<int> from
the first, a C<float> from the second, and a C<char *> from the third.
#include <stdio.h>
#include <EXTERN.h>
#include <perl.h>
!
static PerlInterpreter *my_perl;
!
int perl_eval(char *string)
{
char *argv[2];
***************
*** 240,268 ****
argv[1] = NULL;
perl_call_argv("_eval_", 0, argv);
}
!
main (int argc, char **argv, char **env)
{
char *embedding[] = { "", "-e", "sub _eval_ { eval $_[0] }" };
STRLEN length;
!
my_perl = perl_alloc();
perl_construct( my_perl );
!
! perl_parse(my_perl, NULL, 3, embedding, env);
!
/** Treat $a as an integer **/
perl_eval("$a = 3; $a **= 2");
printf("a = %d\n", SvIV(perl_get_sv("a", FALSE)));
!
/** Treat $a as a float **/
perl_eval("$a = 3.14; $a **= 2");
printf("a = %f\n", SvNV(perl_get_sv("a", FALSE)));
!
/** Treat $a as a string **/
perl_eval("$a = 'rekcaH lreP rehtonA tsuJ'; $a = reverse($a); ");
printf("a = %s\n", SvPV(perl_get_sv("a", FALSE), length));
!
perl_destruct(my_perl);
perl_free(my_perl);
}
--- 257,285 ----
argv[1] = NULL;
perl_call_argv("_eval_", 0, argv);
}
!
main (int argc, char **argv, char **env)
{
char *embedding[] = { "", "-e", "sub _eval_ { eval $_[0] }" };
STRLEN length;
!
my_perl = perl_alloc();
perl_construct( my_perl );
!
! perl_parse(my_perl, NULL, 3, embedding, NULL);
!
/** Treat $a as an integer **/
perl_eval("$a = 3; $a **= 2");
printf("a = %d\n", SvIV(perl_get_sv("a", FALSE)));
!
/** Treat $a as a float **/
perl_eval("$a = 3.14; $a **= 2");
printf("a = %f\n", SvNV(perl_get_sv("a", FALSE)));
!
/** Treat $a as a string **/
perl_eval("$a = 'rekcaH lreP rehtonA tsuJ'; $a = reverse($a); ");
printf("a = %s\n", SvPV(perl_get_sv("a", FALSE), length));
!
perl_destruct(my_perl);
perl_free(my_perl);
}
***************
*** 284,290 ****
define some functions that use it to "specialize" in matches and
substitutions: I<match()>, I<substitute()>, and I<matches()>.
! char match(char *string, char *pattern);
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/">),
--- 301,307 ----
define some functions that use it to "specialize" in matches and
substitutions: I<match()>, I<substitute()>, and I<matches()>.
! char match(char *string, char *pattern);
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/">),
***************
*** 293,299 ****
int substitute(char *string[], char *pattern);
! Given a pointer to a string and an "=~" operation (e.g. "s/bob/robert/g" or
"tr[A-Z][a-z]"), modifies the string according to the operation,
returning the number of substitutions made.
--- 310,316 ----
int substitute(char *string[], char *pattern);
! Given a pointer to a string and an "=~" operation (e.g. "s/bob/robert/g" or
"tr[A-Z][a-z]"), modifies the string according to the operation,
returning the number of substitutions made.
***************
*** 301,370 ****
Given a string, a pattern, and a pointer to an empty array of strings,
evaluates C<$string =~ $pattern> in an array context, and fills in
! I<matches> with the array elements (allocating memory as it does so),
returning the number of matches found.
! Here's a sample program, I<match.c>, that uses all three:
#include <stdio.h>
#include <EXTERN.h>
#include <perl.h>
-
static PerlInterpreter *my_perl;
!
! int eval(char *string)
{
char *argv[2];
argv[0] = string;
argv[1] = NULL;
perl_call_argv("_eval_", 0, argv);
}
-
/** match(string, pattern)
! **
! ** Used for matches in a scalar context.
! **
! ** Returns 1 if the match was successful; 0 otherwise.
! **/
! char match(char *string, char *pattern)
{
char *command;
command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 37);
! sprintf(command, "$string = '%s'; $return = $string =~ %s",
! string, pattern);
perl_eval(command);
free(command);
return SvIV(perl_get_sv("return", FALSE));
}
-
/** substitute(string, pattern)
! **
! ** Used for =~ operations that modify their left-hand side (s/// and tr///)
! **
! ** Returns the number of successful matches, and
! ** modifies the input string if there were any.
! **/
! int substitute(char *string[], char *pattern)
{
char *command;
STRLEN length;
command = malloc(sizeof(char) * strlen(*string) + strlen(pattern) + 35);
! sprintf(command, "$string = '%s'; $ret = ($string =~ %s)",
! *string, pattern);
! perl_eval(command);
! free(command);
! *string = SvPV(perl_get_sv("string", FALSE), length);
! return SvIV(perl_get_sv("ret", FALSE));
}
-
/** matches(string, pattern, matches)
! **
! ** Used for matches in an array context.
! **
! ** Returns the number of matches,
! ** and fills in **matches with the matching substrings (allocates memory!)
! **/
! int matches(char *string, char *pattern, char **matches[])
{
char *command;
SV *current_match;
--- 318,383 ----
Given a string, a pattern, and a pointer to an empty array of strings,
evaluates C<$string =~ $pattern> in an array context, and fills in
! I<matches> with the array elements (allocating memory as it does so),
returning the number of matches found.
! Here's a sample program, I<match.c>, that uses all three (long lines have
! been wrapped here):
#include <stdio.h>
#include <EXTERN.h>
#include <perl.h>
static PerlInterpreter *my_perl;
! int perl_eval(char *string)
{
char *argv[2];
argv[0] = string;
argv[1] = NULL;
perl_call_argv("_eval_", 0, argv);
}
/** match(string, pattern)
! **
! ** Used for matches in a scalar context.
! **
! ** Returns 1 if the match was successful; 0 otherwise.
! **/
! char match(char *string, char *pattern)
{
char *command;
command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 37);
! sprintf(command, "$string = '%s'; $return = $string =~ %s",
! string, pattern);
perl_eval(command);
free(command);
return SvIV(perl_get_sv("return", FALSE));
}
/** substitute(string, pattern)
! **
! ** Used for =~ operations that modify their left-hand side (s/// and tr///)
! **
! ** Returns the number of successful matches, and
! ** modifies the input string if there were any.
! **/
! int substitute(char *string[], char *pattern)
{
char *command;
STRLEN length;
command = malloc(sizeof(char) * strlen(*string) + strlen(pattern) + 35);
! sprintf(command, "$string = '%s'; $ret = ($string =~ %s)",
! *string, pattern);
! perl_eval(command);
! free(command);
! *string = SvPV(perl_get_sv("string", FALSE), length);
! return SvIV(perl_get_sv("ret", FALSE));
}
/** matches(string, pattern, matches)
! **
! ** Used for matches in an array context.
! **
! ** Returns the number of matches,
! ** and fills in **matches with the matching substrings (allocates memory!)
! **/
! int matches(char *string, char *pattern, char **match_list[])
{
char *command;
SV *current_match;
***************
*** 372,464 ****
I32 num_matches;
STRLEN length;
int i;
-
command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 38);
! sprintf(command, "$string = '%s'; @array = ($string =~ %s)",
! string, pattern);
perl_eval(command);
free(command);
array = perl_get_av("array", FALSE);
num_matches = av_len(array) + 1; /** assume $[ is 0 **/
! *matches = (char **) malloc(sizeof(char *) * num_matches);
! for (i = 0; i <= num_matches; i++) {
current_match = av_shift(array);
! (*matches)[i] = SvPV(current_match, length);
}
return num_matches;
}
-
main (int argc, char **argv, char **env)
{
char *embedding[] = { "", "-e", "sub _eval_ { eval $_[0] }" };
! char *text, **matches;
int num_matches, i;
int j;
-
my_perl = perl_alloc();
perl_construct( my_perl );
!
! perl_parse(my_perl, NULL, 3, embedding, env);
!
text = (char *) malloc(sizeof(char) * 486); /** A long string follows! **/
! sprintf(text, "%s", "When he is at a convenience store and the bill comes to some amount like 76 cents, Maynard is aware that there is something he *should* do, something that will enable him to get back a quarter, but he has no idea *what*. He fumbles through his red squeezey changepurse and gives the boy three extra pennies with his dollar, hoping that he might luck into the correct amount. The boy gives him back two of his own pennies and then the big shiny quarter that is his prize. -RICHH");
!
! if (perl_match(text, "m/quarter/")) /** Does text contain 'quarter'? **/
! printf("perl_match: Text contains the word 'quarter'.\n\n");
! else
! printf("perl_match: Text doesn't contain the word 'quarter'.\n\n");
!
! if (perl_match(text, "m/eighth/")) /** Does text contain 'eighth'? **/
! printf("perl_match: Text contains the word 'eighth'.\n\n");
! else
! printf("perl_match: Text doesn't contain the word 'eighth'.\n\n");
!
! /** Match all occurrences of /wi../ **/
! num_matches = perl_matches(text, "m/(wi..)/g", &matches);
!
! printf("perl_matches: m/(wi..)/g found %d matches...\n", num_matches);
! for (i = 0; i < num_matches; i++)
! printf("match: %s\n", matches[i]);
printf("\n");
for (i = 0; i < num_matches; i++) {
! free(matches[i]);
}
! free(matches);
!
! /** Remove all vowels from text **/
! num_matches = perl_substitute(&text, "s/[aeiou]//gi");
if (num_matches) {
! printf("perl_substitute: s/[aeiou]//gi...%d substitutions made.\n",
! num_matches);
printf("Now text is: %s\n\n", text);
}
!
! /** Attempt a substitution
! if (!perl_substitute(&text, "s/Perl/C/")) {
! printf("perl_substitute: s/Perl/C...No substitution made.\n\n");
}
-
free(text);
-
perl_destruct(my_perl);
perl_free(my_perl);
}
! which produces the output
perl_match: Text contains the word 'quarter'.
!
perl_match: Text doesn't contain the word 'eighth'.
!
perl_matches: m/(wi..)/g found 2 matches...
match: will
match: with
!
perl_substitute: s/[aeiou]//gi...139 substitutions made.
! Now text is: Whn h s t cnvnnc str nd th bll cms t sm mnt lk 76 cnts, Mynrd s wr tht thr s smthng h *shld* d, smthng tht wll nbl hm t gt bck qrtr, bt h hs n d *wht*. H fmbls thrgh hs rd sqzy chngprs nd gvs th by thr xtr pnns wth hs dllr, hpng tht h mght lck nt th crrct mnt. Th by gvs hm bck tw f hs wn pnns nd thn th bg shny qrtr tht s hs prz. -RCHH
!
perl_substitute: s/Perl/C...No substitution made.
!
=head2 Fiddling with the Perl stack from your C program
When trying to explain stacks, most computer science textbooks mumble
--- 385,475 ----
I32 num_matches;
STRLEN length;
int i;
command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 38);
! sprintf(command, "$string = '%s'; @array = ($string =~ %s)",
! string, pattern);
perl_eval(command);
free(command);
array = perl_get_av("array", FALSE);
num_matches = av_len(array) + 1; /** assume $[ is 0 **/
! *match_list = (char **) malloc(sizeof(char *) * num_matches);
! for (i = 0; i <= num_matches; i++) {
current_match = av_shift(array);
! (*match_list)[i] = SvPV(current_match, length);
}
return num_matches;
}
main (int argc, char **argv, char **env)
{
char *embedding[] = { "", "-e", "sub _eval_ { eval $_[0] }" };
! char *text, **match_list;
int num_matches, i;
int j;
my_perl = perl_alloc();
perl_construct( my_perl );
! perl_parse(my_perl, NULL, 3, embedding, NULL);
text = (char *) malloc(sizeof(char) * 486); /** A long string follows! **/
! sprintf(text, "%s", "When he is at a convenience store and the bill \
! comes to some amount like 76 cents, Maynard is aware that there is \
! something he *should* do, something that will enable him to get back \
! a quarter, but he has no idea *what*. He fumbles through his red \
! squeezey changepurse and gives the boy three extra pennies with his \
! dollar, hoping that he might luck into the correct amount. The boy \
! gives him back two of his own pennies and then the big shiny quarter \
! that is his prize. -RICHH");
! if (match(text, "m/quarter/")) /** Does text contain 'quarter'? **/
! printf("match: Text contains the word 'quarter'.\n\n");
! else
! printf("match: Text doesn't contain the word 'quarter'.\n\n");
! if (match(text, "m/eighth/")) /** Does text contain 'eighth'? **/
! printf("match: Text contains the word 'eighth'.\n\n");
! else
! printf("match: Text doesn't contain the word 'eighth'.\n\n");
! /** Match all occurrences of /wi../ **/
! num_matches = matches(text, "m/(wi..)/g", &match_list);
! printf("matches: m/(wi..)/g found %d matches...\n", num_matches);
! for (i = 0; i < num_matches; i++)
! printf("match: %s\n", match_list[i]);
printf("\n");
for (i = 0; i < num_matches; i++) {
! free(match_list[i]);
}
! free(match_list);
! /** Remove all vowels from text **/
! num_matches = substitute(&text, "s/[aeiou]//gi");
if (num_matches) {
! printf("substitute: s/[aeiou]//gi...%d substitutions made.\n",
! num_matches);
printf("Now text is: %s\n\n", text);
}
! /** Attempt a substitution **/
! if (!substitute(&text, "s/Perl/C/")) {
! printf("substitute: s/Perl/C...No substitution made.\n\n");
}
free(text);
perl_destruct(my_perl);
perl_free(my_perl);
}
! which produces the output (again, long lines have been wrapped here)
perl_match: Text contains the word 'quarter'.
!
perl_match: Text doesn't contain the word 'eighth'.
!
perl_matches: m/(wi..)/g found 2 matches...
match: will
match: with
!
perl_substitute: s/[aeiou]//gi...139 substitutions made.
! Now text is: Whn h s t cnvnnc str nd th bll cms t sm mnt lk 76 cnts,
! Mynrd s wr tht thr s smthng h *shld* d, smthng tht wll nbl hm t gt bck
! qrtr, bt h hs n d *wht*. H fmbls thrgh hs rd sqzy chngprs nd gvs th by
! thr xtr pnns wth hs dllr, hpng tht h mght lck nt th crrct mnt. Th by gvs
! hm bck tw f hs wn pnns nd thn th bg shny qrtr tht s hs prz. -RCHH
!
perl_substitute: s/Perl/C...No substitution made.
!
=head2 Fiddling with the Perl stack from your C program
When trying to explain stacks, most computer science textbooks mumble
***************
*** 467,473 ****
do for our purposes: your C program will push some arguments onto "the Perl
stack", shut its eyes while some magic happens, and then pop the
results--the return value of your Perl subroutine--off the stack.
!
First you'll need to know how to convert between C types and Perl
types, with newSViv() and sv_setnv() and newAV() and all their
friends. They're described in L<perlguts>.
--- 478,484 ----
do for our purposes: your C program will push some arguments onto "the Perl
stack", shut its eyes while some magic happens, and then pop the
results--the return value of your Perl subroutine--off the stack.
!
First you'll need to know how to convert between C types and Perl
types, with newSViv() and sv_setnv() and newAV() and all their
friends. They're described in L<perlguts>.
***************
*** 475,481 ****
Then you'll need to know how to manipulate the Perl stack. That's
described in L<perlcall>.
! Once you've understood those, embedding Perl in C is easy.
Since C has no built-in function for integer exponentiation, let's
make Perl's ** operator available to it (this is less useful than it
--- 486,492 ----
Then you'll need to know how to manipulate the Perl stack. That's
described in L<perlcall>.
! Once you've understood those, embedding Perl in C is easy.
Since C has no built-in function for integer exponentiation, let's
make Perl's ** operator available to it (this is less useful than it
***************
*** 495,503 ****
#include <stdio.h>
#include <EXTERN.h>
#include <perl.h>
!
static PerlInterpreter *my_perl;
!
static void
PerlPower(int a, int b)
{
--- 506,514 ----
#include <stdio.h>
#include <EXTERN.h>
#include <perl.h>
!
static PerlInterpreter *my_perl;
!
static void
PerlPower(int a, int b)
{
***************
*** 512,550 ****
SPAGAIN; /* refresh stack pointer */
/* pop the return value from stack */
printf ("%d to the %dth power is %d.\n", a, b, POPi);
! PUTBACK;
FREETMPS; /* free that return value */
LEAVE; /* ...and the XPUSHed "mortal" args.*/
}
!
! int main (int argc, char **argv, char **env)
{
char *my_argv[2];
!
my_perl = perl_alloc();
perl_construct( my_perl );
!
my_argv[1] = (char *) malloc(10);
sprintf(my_argv[1], "power.pl");
!
! perl_parse(my_perl, NULL, argc, my_argv, env);
!
PerlPower(3, 4); /*** Compute 3 ** 4 ***/
!
perl_destruct(my_perl);
perl_free(my_perl);
}
!
Compile and run:
! % cc -o power power.c -L/usr/local/lib/perl5/alpha-dec_osf/CORE
! -I/usr/local/lib/perl5/alpha-dec_osf/CORE -lperl -lm
!
! % power
3 to the 4th power is 81.
=head1 MORAL
You can sometimes I<write faster code> in C, but
--- 523,646 ----
SPAGAIN; /* refresh stack pointer */
/* pop the return value from stack */
printf ("%d to the %dth power is %d.\n", a, b, POPi);
! PUTBACK;
FREETMPS; /* free that return value */
LEAVE; /* ...and the XPUSHed "mortal" args.*/
}
!
! int main (int argc, char **argv, char **env)
{
char *my_argv[2];
!
my_perl = perl_alloc();
perl_construct( my_perl );
!
my_argv[1] = (char *) malloc(10);
sprintf(my_argv[1], "power.pl");
!
! perl_parse(my_perl, NULL, argc, my_argv, NULL);
!
PerlPower(3, 4); /*** Compute 3 ** 4 ***/
!
perl_destruct(my_perl);
perl_free(my_perl);
}
!
Compile and run:
! % cc -o power power.c `perl -MExtUtils::Embed -e ccopts -e ldopts`
!
! % power
3 to the 4th power is 81.
+ =head2 Using Perl modules, which themselves use C libraries, from your C program
+
+ If you've played with the examples above and tried to embed a script
+ that I<use()>s a Perl module (such as I<Socket>) which itself uses a C or C++ library,
+ this probably happened:
+
+
+ Can't load module Socket, dynamic loading not available in this perl.
+ (You may need to build a new perl executable which either supports
+ dynamic loading or has the Socket module statically linked into it.)
+
+
+ What's wrong?
+
+ Your interpreter doesn't know how to communicate with these extensions
+ on its own. A little glue will help. Up until now you've been
+ calling I<perl_parse()>, handing it NULL for the second argument:
+
+ perl_parse(my_perl, NULL, argc, my_argv, NULL);
+
+ That's where the glue code can be inserted to create the initial contact between
+ Perl and linked C/C++ routines. Let's take a look some pieces of I<perlmain.c>
+ to see how Perl does this:
+
+
+ #ifdef __cplusplus
+ # define EXTERN_C extern "C"
+ #else
+ # define EXTERN_C extern
+ #endif
+
+ static void xs_init _((void));
+
+ EXTERN_C void boot_DynaLoader _((CV* cv));
+ EXTERN_C void boot_Socket _((CV* cv));
+
+
+ EXTERN_C void
+ xs_init()
+ {
+ char *file = __FILE__;
+ /* DynaLoader is a special case */
+ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
+ newXS("Socket::bootstrap", boot_Socket, file);
+ }
+
+ Simply put: for each extension linked with your Perl executable
+ (determined during its initial configuration on your
+ computer or when adding a new extension),
+ a Perl subroutine is created to incorporate the extension's
+ routines. Normally, that subroutine is named
+ I<Module::bootstrap()> and is invoked when you say I<use Module>. In
+ turn, this hooks into an XSUB, I<boot_Module>, which creates a Perl
+ counterpart for each of the extension's XSUBs. Don't worry about this
+ part; leave that to the I<xsubpp> and extension authors. If your
+ extension is dynamically loaded, DynaLoader creates I<Module::bootstrap()>
+ for you on the fly. In fact, if you have a working DynaLoader then there
+ is rarely any need to statically link in any other extensions.
+
+
+ Once you have this code, slap it into the second argument of I<perl_parse()>:
+
+
+ perl_parse(my_perl, xs_init, argc, my_argv, NULL);
+
+
+ Then compile:
+
+ % cc -o interp interp.c `perl -MExtUtils::Embed -e ldopts`
+
+ % interp
+ use Socket;
+ use SomeDynamicallyLoadedModule;
+
+ print "Now I can use extensions!\n"'
+
+ B<ExtUtils::Embed> can also automate writing the I<xs_init> glue code.
+
+ % perl -MExtUtils::Embed -e xsinit -o perlxsi.c
+ % cc -c perlxsi.c `perl -MExtUtils::Embed -e ccopts`
+ % cc -c interp.c `perl -MExtUtils::Embed -e ccopts`
+ % cc -o interp perlxsi.o interp.o `perl -MExtUtils::Embed -e ldopts`
+
+ Consult L<perlxs> and L<perlguts> for more details.
+
+
=head1 MORAL
You can sometimes I<write faster code> in C, but
***************
*** 554,565 ****
=head1 AUTHOR
! Jon Orwant F<E<lt>orwant@media.mit.eduE<gt>>, with contributions from
! Tim Bunce, Tom Christiansen, Dov Grobgeld, and Ilya Zakharevich.
! December 18, 1995
! Some of this material is excerpted from my book: I<Perl 5 Interactive>,
Waite Group Press, 1996 (ISBN 1-57169-064-6) and appears
courtesy of Waite Group Press.
-
--- 650,663 ----
=head1 AUTHOR
! Jon Orwant F<E<lt>orwant@media.mit.eduE<gt>>,
! co-authored by Doug MacEachern F<E<lt>dougm@osf.orgE<gt>>,
! with contributions from
! Tim Bunce, Tom Christiansen, Dov Grobgeld, and Ilya
! Zakharevich.
! June 17, 1996
! Some of this material is excerpted from my book: I<Perl 5 Interactive>,
Waite Group Press, 1996 (ISBN 1-57169-064-6) and appears
courtesy of Waite Group Press.
#~ Typos corrected
diff -Pcr perl5_003/pod/perlform.pod perl5_003_01/pod/perlform.pod
*** perl5_003/pod/perlform.pod Tue Jan 30 13:21:24 1996
--- perl5_003_01/pod/perlform.pod Mon Jun 17 18:58:32 1996
***************
*** 100,106 ****
Top-of-form processing is by default handled by a format with the
same name as the current filehandle with "_TOP" concatenated to it.
! It's triggered at the top of each page. See <perlfunc/write()>.
Examples:
--- 100,106 ----
Top-of-form processing is by default handled by a format with the
same name as the current filehandle with "_TOP" concatenated to it.
! It's triggered at the top of each page. See L<perlfunc/write>.
Examples:
***************
*** 272,278 ****
Here's another strategy; open a pipe to yourself, using C<open(MESELF, "|-")>
(see L<perlfunc/open()>) and always write() to MESELF instead of
! STDOUT. Have your child process postprocesses its STDIN to rearrange
headers and footers however you like. Not very convenient, but doable.
=head2 Accessing Formatting Internals
--- 272,278 ----
Here's another strategy; open a pipe to yourself, using C<open(MESELF, "|-")>
(see L<perlfunc/open()>) and always write() to MESELF instead of
! STDOUT. Have your child process massage its STDIN to rearrange
headers and footers however you like. Not very convenient, but doable.
=head2 Accessing Formatting Internals
#~ Typos corrected
#~ Update "each" documentation to include behavior in scalar context
#~ Add documentation for new "prototype" operator
#~ Explain "require" expansion of barewords
#~ Add limit parameter to "split" example to clarify its use
#~ Update "srand" documentation to reflect new behavior
#~ Quote package name in "tie" example -- necesary under use strict subs
#~ Correct "time" docs to reflect that not all epochs are Unix
#~ Update "use" documentation to inidcate that first parameter must
#~ be a bareword or Perl version number
diff -Pcr perl5_003/pod/perlfunc.pod perl5_003_01/pod/perlfunc.pod
*** perl5_003/pod/perlfunc.pod Mon Mar 25 01:05:13 1996
--- perl5_003_01/pod/perlfunc.pod Fri Jul 19 14:44:35 1996
***************
*** 119,125 ****
=item Functions for filehandles, files, or directories
! -X, chdir, chmod, chown, chroot, fcntl, glob, ioctl, link,
lstat, mkdir, open, opendir, readlink, rename, rmdir,
stat, symlink, umask, unlink, utime
--- 119,125 ----
=item Functions for filehandles, files, or directories
! I<-X>, chdir, chmod, chown, chroot, fcntl, glob, ioctl, link,
lstat, mkdir, open, opendir, readlink, rename, rmdir,
stat, symlink, umask, unlink, utime
***************
*** 183,190 ****
=item Functions new in perl5
abs, bless, chomp, chr, exists, formline, glob, import, lc,
! lcfirst, map, my, no, qx, qw, ref, sub*, sysopen, tie, tied, uc,
! ucfirst, untie, use
* - C<sub> was a keyword in perl4, but in perl5 it is an
operator which can be used in expressions.
--- 183,190 ----
=item Functions new in perl5
abs, bless, chomp, chr, exists, formline, glob, import, lc,
! lcfirst, map, my, no, prototype, qx, qw, readline, readpipe,
! ref, sub*, sysopen, tie, tied, uc, ucfirst, untie, use
* - C<sub> was a keyword in perl4, but in perl5 it is an
operator which can be used in expressions.
***************
*** 776,786 ****
=item each ASSOC_ARRAY
! Returns a 2-element array consisting of the key and value for the next
! value of an associative array, so that you can iterate over it.
Entries are returned in an apparently random order. When the array is
! entirely read, a null array is returned (which when assigned produces a
! FALSE (0) value). The next call to each() after that will start
iterating again. The iterator can be reset only by reading all the
elements from the array. You should not add elements to an array while
you're iterating over it. There is a single iterator for each
--- 776,789 ----
=item each ASSOC_ARRAY
! 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.
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
! 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
***************
*** 1123,1129 ****
$login = getlogin || (getpwuid($<))[0] || "Kilroy";
! Do not consider getlogin() for authorentication: it is not as
secure as getpwuid().
=item getpeername SOCKET
--- 1126,1132 ----
$login = getlogin || (getpwuid($<))[0] || "Kilroy";
! Do not consider getlogin() for authentication: it is not as
secure as getpwuid().
=item getpeername SOCKET
***************
*** 1455,1461 ****
process groups instead of processes. (On System V, a negative I<PROCESS>
number will also kill process groups, but that's not portable.) That
means you usually want to use positive not negative signals. You may also
! use a signal name in quotes. See the L<perlipc/"Signals"> man page for details.
=item last LABEL
--- 1458,1464 ----
process groups instead of processes. (On System V, a negative I<PROCESS>
number will also kill process groups, but that's not portable.) That
means you usually want to use positive not negative signals. You may also
! use a signal name in quotes. See L<perlipc/"Signals"> for details.
=item last LABEL
***************
*** 1527,1533 ****
$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 modulie.
=item log EXPR
--- 1530,1536 ----
$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
***************
*** 1660,1666 ****
as a command to which output is to be piped, and if the filename ends with
a "|", the filename is interpreted See L<perlipc/"Using open() for IPC">
for more examples of this. as command which pipes input to us. (You may
! not have a raw open() to a command that pipes both in I<and> out, but see See L<open2>,
L<open3>, and L<perlipc/"Bidirectional Communication"> for alternatives.)
Opening '-' opens STDIN and opening '>-' opens STDOUT. Open returns
--- 1663,1669 ----
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
***************
*** 1982,1988 ****
token is a term, it may be misinterpreted as an operator unless you
interpose a + or put parens around the arguments.) If FILEHANDLE is
omitted, prints by default to standard output (or to the last selected
! output channel--see select()). If LIST is also omitted, prints $_ to
STDOUT. To set the default output channel to something other than
STDOUT use the select operation. Note that, because print takes a
LIST, anything in the LIST is evaluated in a list context, and any
--- 1985,1991 ----
token is a term, it may be misinterpreted as an operator unless you
interpose a + or put parens 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
STDOUT use the select operation. Note that, because print takes a
LIST, anything in the LIST is evaluated in a list context, and any
***************
*** 1993,1999 ****
put parens around all the arguments.
Note that if you're storing FILEHANDLES in an array or other expression,
! you will have to use a block returning its value instead
print { $files[$i] } "stuff\n";
print { $OK ? STDOUT : STDERR } "stuff\n";
--- 1996,2002 ----
put parens around all the arguments.
Note that if you're storing FILEHANDLES in an array or other expression,
! you will have to use a block returning its value instead:
print { $files[$i] } "stuff\n";
print { $OK ? STDOUT : STDERR } "stuff\n";
***************
*** 2005,2010 ****
--- 2008,2019 ----
Equivalent to a "print FILEHANDLE sprintf(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.
+
=item push ARRAY,LIST
Treats ARRAY as a stack, and pushes the values of LIST
***************
*** 2190,2200 ****
otherwise. But it's better just to put the "C<1;>", in case you add more
statements.
! If EXPR is a bare word, the require assumes a "F<.pm>" extension for you,
to make it easy to load standard modules. This form of loading of
modules does not risk altering your namespace.
! For a yet-more-powerful import facility, see the L</use()> and
L<perlmod>.
=item reset EXPR
--- 2199,2210 ----
otherwise. But it's better just to put the "C<1;>", in case you add more
statements.
! If EXPR is a bare word, the require assumes a "F<.pm>" extension and
! replaces "F<::>" with "F</>" in the filename for you,
to make it easy to load standard modules. This form of loading of
modules does not risk altering your namespace.
! For a yet-more-powerful import facility, see L</use> and
L<perlmod>.
=item reset EXPR
***************
*** 2217,2223 ****
Resetting "A-Z" is not recommended since you'll wipe out your
ARGV and ENV arrays. Only resets package variables--lexical variables
are unaffected, but they clean themselves up on scope exit anyway,
! so anymore you probably want to use them instead. See L</my>.
=item return LIST
--- 2227,2233 ----
Resetting "A-Z" is not recommended since you'll wipe out your
ARGV and ENV arrays. Only resets package variables--lexical variables
are unaffected, but they clean themselves up on scope exit anyway,
! so you'll probably want to use them instead. See L</my>.
=item return LIST
***************
*** 2382,2388 ****
capable of returning the $timeleft. If not, they always return
$timeleft equal to the supplied $timeout.
! You can effect a 250-microsecond sleep this way:
select(undef, undef, undef, 0.25);
--- 2392,2398 ----
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:
select(undef, undef, undef, 0.25);
***************
*** 2711,2717 ****
If the PATTERN contains parentheses, additional array elements are
created from each matching substring in the delimiter.
! split(/([,-])/, "1-10,20");
produces the list value
--- 2721,2727 ----
If the PATTERN contains parentheses, additional array elements are
created from each matching substring in the delimiter.
! split(/([,-])/, "1-10,20", 3);
produces the list value
***************
*** 2764,2771 ****
=item srand EXPR
Sets the random number seed for the C<rand> operator. If EXPR is omitted,
! does C<srand(time)>. Many folks use an explicit C<srand(time ^ $$)>
! instead. Of course, you'd need something much more random than that for
cryptographic purposes, since it's easy to guess the current time.
Checksumming the compressed output of rapidly changing operating system
status programs is the usual method. Examples are posted regularly to
--- 2774,2781 ----
=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
! 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.
Checksumming the compressed output of rapidly changing operating system
status programs is the usual method. Examples are posted regularly to
***************
*** 3016,3022 ****
# print out history file offsets
use NDBM_File;
! tie(%HIST, NDBM_File, '/usr/lib/news/history', 1, 0);
while (($key,$val) = each %HIST) {
print $key, ' = ', unpack('L',$val), "\n";
}
--- 3026,3032 ----
# print out history file offsets
use NDBM_File;
! tie(%HIST, 'NDBM_File', '/usr/lib/news/history', 1, 0);
while (($key,$val) = each %HIST) {
print $key, ' = ', unpack('L',$val), "\n";
}
***************
*** 3062,3069 ****
=item time
! Returns the number of non-leap seconds since 00:00:00 UTC, January 1,
! 1970. Suitable for feeding to gmtime() and localtime().
=item times
--- 3072,3081 ----
=item time
! Returns the number of non-leap seconds since whatever time the system
! considers to be the epoch (that's 00:00:00, January 1, 1904 for MacOS,
! and 00:00:00 UTC, January 1, 1970 for most other systems).
! Suitable for feeding to gmtime() and localtime().
=item times
***************
*** 3187,3198 ****
--- 3199,3224 ----
=item use Module
+ =item use Module VERSION LIST
+
+ =item use VERSION
+
Imports some semantics into the current package from the named module,
generally by aliasing certain subroutine or variable names into your
package. It is exactly equivalent to
BEGIN { require Module; import Module LIST; }
+ except that Module I<must> be a bare word.
+
+ If the first argument to C<use> is a number, it is treated as a version
+ number instead of a module name. If the version of the Perl interpreter
+ is less than VERSION, then an error message is printed and Perl exits
+ immediately. This is often useful if you need to check the current
+ Perl version before C<use>ing library modules which have changed in
+ incompatible ways from older versions of Perl. (We try not to do
+ this more than we have to.)
+
The BEGIN forces the require and import to happen at compile time. The
require makes sure the module is loaded into memory if it hasn't been
yet. The import is not a builtin--it's just an ordinary static method
***************
*** 3210,3215 ****
--- 3236,3245 ----
BEGIN { require Module; }
+ If the VERSION argument is present between Module and LIST, then the
+ C<use> will fail if the C<$VERSION> variable in package Module is
+ less than VERSION.
+
Because this is a wide-open interface, pragmas (compiler directives)
are also implemented this way. Currently implemented pragmas are:
***************
*** 3224,3230 ****
effective through the end of the file).
There's a corresponding "no" command that unimports meanings imported
! by use.
no integer;
no strict 'refs';
--- 3254,3260 ----
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>.
no integer;
no strict 'refs';
#~ Use pod formatting instead of ASCII emphasis
diff -Pcr perl5_003/pod/perlguts.pod perl5_003_01/pod/perlguts.pod
*** perl5_003/pod/perlguts.pod Mon Mar 25 01:05:14 1996
--- perl5_003_01/pod/perlguts.pod Mon Jun 17 19:11:53 1996
***************
*** 39,45 ****
SV* newSVpv(char*, int);
SV* newSVsv(SV*);
! To change the value of an *already-existing* SV, there are five routines:
void sv_setiv(SV*, IV);
void sv_setnv(SV*, double);
--- 39,45 ----
SV* newSVpv(char*, int);
SV* newSVsv(SV*);
! To change the value of an I<already-existing> SV, there are five routines:
void sv_setiv(SV*, IV);
void sv_setnv(SV*, double);
#~ Typos corrected
diff -Pcr perl5_003/pod/perlipc.pod perl5_003_01/pod/perlipc.pod
*** perl5_003/pod/perlipc.pod Tue Jan 30 13:21:53 1996
--- perl5_003_01/pod/perlipc.pod Mon Jun 17 19:05:09 1996
***************
*** 14,26 ****
references of user-installed signal handlers. These handlers will be called
with an argument which is the name of the signal that triggered it. A
signal may be generated intentionally from a particular keyboard sequence like
! control-C or control-Z, sent to you from an another process, or
triggered automatically by the kernel when special events transpire, like
a child process exiting, your process running out of stack space, or
hitting file size limit.
For example, to trap an interrupt signal, set up a handler like this.
! Notice how all we do is set with a global variable and then raise an
exception. That's because on most systems libraries are not
re-entrant, so calling any print() functions (or even anything that needs to
malloc(3) more memory) could in theory trigger a memory fault
--- 14,26 ----
references of user-installed signal handlers. These handlers will be called
with an argument which is the name of the signal that triggered it. A
signal may be generated intentionally from a particular keyboard sequence like
! control-C or control-Z, sent to you from another process, or
triggered automatically by the kernel when special events transpire, like
a child process exiting, your process running out of stack space, or
hitting file size limit.
For example, to trap an interrupt signal, set up a handler like this.
! Notice how all we do is set a global variable and then raise an
exception. That's because on most systems libraries are not
re-entrant, so calling any print() functions (or even anything that needs to
malloc(3) more memory) could in theory trigger a memory fault
***************
*** 199,205 ****
Perl's basic open() statement can also be used for unidirectional interprocess
communication by either appending or prepending a pipe symbol to the second
! argument to open(). Here's how to start something up a child process you
intend to write to:
open(SPOOLER, "| cat -v | lpr -h 2>/dev/null")
--- 199,205 ----
Perl's basic open() statement can also be used for unidirectional interprocess
communication by either appending or prepending a pipe symbol to the second
! argument to open(). Here's how to start something up in a child process you
intend to write to:
open(SPOOLER, "| cat -v | lpr -h 2>/dev/null")
***************
*** 216,222 ****
next if /^(tcp|udp)/;
print;
}
! close SPOOLER || die "bad netstat: $! $?";
If one can be sure that a particular program is a Perl script that is
expecting filenames in @ARGV, the clever programmer can write something
--- 216,222 ----
next if /^(tcp|udp)/;
print;
}
! close STATUS || die "bad netstat: $! $?";
If one can be sure that a particular program is a Perl script that is
expecting filenames in @ARGV, the clever programmer can write something
***************
*** 296,302 ****
Another common use for this construct is when you need to execute
something without the shell's interference. With system(), it's
! straigh-forward, but you can't use a pipe open or backticks safely.
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.
--- 296,302 ----
Another common use for this construct is when you need to execute
something without the shell's interference. With system(), it's
! straightforward, but you can't use a pipe open or backticks safely.
That's because there's no way to stop the shell from getting its hands on
your arguments. Instead, use lower-level control to call exec() directly.
***************
*** 341,347 ****
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.
=head2 Bidirectional Communication
--- 341,347 ----
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.
=head2 Bidirectional Communication
***************
*** 627,633 ****
=head2 Unix-Domain TCP Clients and Servers
! That's fine for Internet-domain clients and servers, but what local
communications? While you can use the same setup, sometimes you don't
want to. Unix-domain sockets are local to the current host, and are often
used internally to implement pipes. Unlike Internet domain sockets, UNIX
--- 627,633 ----
=head2 Unix-Domain TCP Clients and Servers
! That's fine for Internet-domain clients and servers, but what about local
communications? While you can use the same setup, sometimes you don't
want to. Unix-domain sockets are local to the current host, and are often
used internally to implement pipes. Unlike Internet domain sockets, UNIX
***************
*** 808,814 ****
die if !defined($key);
print "$key\n";
! Put this code in a separate file to be run in more that one process
Call the file F<take>:
# create a semaphore
--- 808,814 ----
die if !defined($key);
print "$key\n";
! Put this code in a separate file to be run in more than one process.
Call the file F<take>:
# create a semaphore
***************
*** 832,838 ****
semop($key,$opstring) || die "$!";
! Put this code in a separate file to be run in more that one process
Call this file F<give>:
# 'give' the semaphore
--- 832,838 ----
semop($key,$opstring) || die "$!";
! Put this code in a separate file to be run in more than one process.
Call this file F<give>:
# 'give' the semaphore
***************
*** 870,883 ****
If you are running under version 5.000 (dubious) or 5.001, you can still
use most of the examples in this document. You may have to remove the
C<use strict> and some of the my() statements for 5.000, and for both
! you'll have to load in version 1.2 of the F<Socket.pm> module, which
! was/is/shall-be included in I<perl5.001o>.
Most of these routines quietly but politely return C<undef> when they fail
instead of causing your program to die right then and there due to an
uncaught exception. (Actually, some of the new I<Socket> conversion
functions croak() on bad arguments.) It is therefore essential
! that you should check the return values fo these functions. Always begin
your socket programs this way for optimal success, and don't forget to add
B<-T> taint checking flag to the pound-bang line for servers:
--- 870,883 ----
If you are running under version 5.000 (dubious) or 5.001, you can still
use most of the examples in this document. You may have to remove the
C<use strict> and some of the my() statements for 5.000, and for both
! you'll have to load in version 1.2 or older of the F<Socket.pm> module, which
! is included in I<perl5.002>.
Most of these routines quietly but politely return C<undef> when they fail
instead of causing your program to die right then and there due to an
uncaught exception. (Actually, some of the new I<Socket> conversion
functions croak() on bad arguments.) It is therefore essential
! that you should check the return values of these functions. Always begin
your socket programs this way for optimal success, and don't forget to add
B<-T> taint checking flag to the pound-bang line for servers:
***************
*** 893,899 ****
elsewhere, Perl is at the mercy of your C libraries for much of its system
behaviour. It's probably safest to assume broken SysV semantics for
signals and to stick with simple TCP and UDP socket operations; e.g. don't
! try to pass open filedescriptors over a local UDP datagram socket if you
want your code to stand a chance of being portable.
Because few vendors provide C libraries that are safely
--- 893,899 ----
elsewhere, Perl is at the mercy of your C libraries for much of its system
behaviour. It's probably safest to assume broken SysV semantics for
signals and to stick with simple TCP and UDP socket operations; e.g. don't
! try to pass open file descriptors over a local UDP datagram socket if you
want your code to stand a chance of being portable.
Because few vendors provide C libraries that are safely
#~ Typos corrected
#~ Syntax clarified for optional ->
diff -Pcr perl5_003/pod/perllol.pod perl5_003_01/pod/perllol.pod
*** perl5_003/pod/perllol.pod Mon Jan 22 20:47:38 1996
--- perl5_003_01/pod/perllol.pod Mon Jun 17 18:52:31 1996
***************
*** 55,61 ****
Well, that's because the rule is that on adjacent brackets only (whether
square or curly), you are free to omit the pointer dereferencing array.
! But you need not do so for the very first one if it's a scalar containing
a reference, which means that $ref_to_LoL always needs it.
=head1 Growing Your Own
--- 55,61 ----
Well, that's because the rule is that on adjacent brackets only (whether
square or curly), you are free to omit the pointer dereferencing array.
! But you cannot do so for the very first one if it's a scalar containing
a reference, which means that $ref_to_LoL always needs it.
=head1 Growing Your Own
***************
*** 128,134 ****
$LoL[$i] = [ split ' ', <> ];
}
! You should in general be leary of using potential list functions
in a scalar context without explicitly stating such.
This would be clearer to the casual reader:
--- 128,134 ----
$LoL[$i] = [ split ' ', <> ];
}
! You should in general be leery of using potential list functions
in a scalar context without explicitly stating such.
This would be clearer to the casual reader:
***************
*** 243,249 ****
=head1 Slices
! If you want to get at a slide (part of a row) in a multidimensional
array, you're going to have to do some fancy subscripting. That's
because while we have a nice synonym for single elements via the
pointer arrow for dereferencing, no such convenience exists for slices.
--- 243,249 ----
=head1 Slices
! If you want to get at a slice (part of a row) in a multidimensional
array, you're going to have to do some fancy subscripting. That's
because while we have a nice synonym for single elements via the
pointer arrow for dereferencing, no such convenience exists for slices.
#~ Typos and pod formatting corrected
#~ Use "identifier" for both members of an aliased pair of symbols
#~ to emphasize their equivalence
#~ Add description of "ops" and "vars" pragmatic modules
diff -Pcr perl5_003/pod/perlmod.pod perl5_003_01/pod/perlmod.pod
*** perl5_003/pod/perlmod.pod Mon Mar 25 01:05:14 1996
--- perl5_003_01/pod/perlmod.pod Thu Jul 11 12:22:54 1996
***************
*** 7,13 ****
=head2 Packages
Perl provides a mechanism for alternative namespaces to protect packages
! from stomping on each others variables. In fact, apart from certain
magical variables, there's really no such thing as a global variable in
Perl. The package statement declares the compilation unit as being in the
given namespace. The scope of the package declaration is from the
--- 7,13 ----
=head2 Packages
Perl provides a mechanism for alternative namespaces to protect packages
! from stomping on each other's variables. In fact, apart from certain
magical variables, there's really no such thing as a global variable in
Perl. The package statement declares the compilation unit as being in the
given namespace. The scope of the package declaration is from the
***************
*** 22,28 ****
refer to variables and filehandles in other packages by prefixing the
identifier with the package name and a double colon:
C<$Package::Variable>. If the package name is null, the C<main> package
! as assumed. That is, C<$::sail> is equivalent to C<$main::sail>.
(The old package delimiter was a single quote, but double colon
is now the preferred delimiter, in part because it's more readable
--- 22,28 ----
refer to variables and filehandles in other packages by prefixing the
identifier with the package name and a double colon:
C<$Package::Variable>. If the package name is null, the C<main> package
! is assumed. That is, C<$::sail> is equivalent to C<$main::sail>.
(The old package delimiter was a single quote, but double colon
is now the preferred delimiter, in part because it's more readable
***************
*** 69,76 ****
The symbol table for a package happens to be stored in the associative
array of that name appended with two colons. The main symbol table's
! name is thus C<%main::>, or C<%::> for short. Likewise the nested package
! mentioned earlier is named C<%OUTER::INNER::>.
The value in each entry of the associative array is what you are referring
to when you use the C<*name> typeglob notation. In fact, the following
--- 69,76 ----
The symbol table for a package happens to be stored in the associative
array of that name appended with two colons. The main symbol table's
! name is thus C<%main::>, or C<%::> for short. Likewise symbol table for
! the nested package mentioned earlier is named C<%OUTER::INNER::>.
The value in each entry of the associative array is what you are referring
to when you use the C<*name> typeglob notation. In fact, the following
***************
*** 120,126 ****
*dick = *richard;
causes variables, subroutines and file handles accessible via the
! identifier C<richard> to also be accessible via the symbol C<dick>. If
you only want to alias a particular variable or subroutine, you can
assign a reference instead:
--- 120,126 ----
*dick = *richard;
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
assign a reference instead:
***************
*** 305,311 ****
the F<.ph> files made by B<h2ph> will probably end up as extension modules
made by B<h2xs>. (Some F<.ph> values may already be available through the
POSIX module.) The B<pl2pm> file in the distribution may help in your
! conversion, but it's just a mechanical process, so is far from bullet proof.
=head2 Pragmatic Modules
--- 305,311 ----
the F<.ph> files made by B<h2ph> will probably end up as extension modules
made by B<h2xs>. (Some F<.ph> values may already be available through the
POSIX module.) The B<pl2pm> file in the distribution may help in your
! conversion, but it's just a mechanical process, so is far from bulletproof.
=head2 Pragmatic Modules
***************
*** 335,340 ****
--- 335,344 ----
Pragma to request less of something from the compiler
+ =item ops
+
+ Pragma to restrict use of unsafe opcodes
+
=item overload
Pragma for overloading operators
***************
*** 351,356 ****
--- 355,364 ----
Pragma to predeclare sub names
+ =item vars
+
+ Pragma to predeclare global symbols
+
=back
=head2 Standard Modules
***************
*** 602,608 ****
=back
! Some of the reguster CPAN sites as of this writing include the following.
You should try to choose one close to you:
=over
--- 610,616 ----
=back
! The registered CPAN sites as of this writing include the following.
You should try to choose one close to you:
=over
***************
*** 676,682 ****
=back
For an up-to-date listing of CPAN sites,
! see http://www.perl.com/perl/ or ftp://ftp.perl.com/perl/ .
=head1 Modules: Creation, Use and Abuse
--- 684,690 ----
=back
For an up-to-date listing of CPAN sites,
! see F<http://www.perl.com/perl/CPAN> or F<ftp://ftp.perl.com/perl/>.
=head1 Modules: Creation, Use and Abuse
***************
*** 910,915 ****
--- 918,925 ----
split out some of the sections into separate files: INSTALL,
Copying, ToDo etc.
+ =over 4
+
=item Adding a Copyright Notice.
How you choose to licence your work is a personal decision.
***************
*** 991,996 ****
--- 1001,1008 ----
=back
+ =back
+
=head2 Guidelines for Converting Perl 4 Library Scripts into Modules
=over 4
***************
*** 1063,1069 ****
perl -e 'use Module::Name; method(@ARGV)' ...
or
! perl -mModule::Name ... (in perl5.002?)
=back
--- 1075,1081 ----
perl -e 'use Module::Name; method(@ARGV)' ...
or
! perl -mModule::Name ... (in perl5.002)
=back
#~ Add documentation for default UNIVERSAL methods
diff -Pcr perl5_003/pod/perlobj.pod perl5_003_01/pod/perlobj.pod
*** perl5_003/pod/perlobj.pod Mon Mar 25 01:05:15 1996
--- perl5_003_01/pod/perlobj.pod Fri Jul 5 15:55:24 1996
***************
*** 137,143 ****
If neither a method nor an AUTOLOAD routine is found in @ISA, then one
last try is made for the method (or an AUTOLOAD routine) in a class
! called UNIVERSAL. If that doesn't work, Perl finally gives up and
complains.
Perl classes only do method inheritance. Data inheritance is left
--- 137,145 ----
If neither a method nor an AUTOLOAD routine is found in @ISA, then one
last try is made for the method (or an AUTOLOAD routine) in a class
! called UNIVERSAL. (Several commonly used methods are automatically
! supplied in the UNIVERSAL class; see L<"Default UNIVERSAL methods"> for
! more details.) If that doesn't work, Perl finally gives up and
complains.
Perl classes only do method inheritance. Data inheritance is left
***************
*** 267,273 ****
$method = $fast ? "findfirst" : "findbest";
$fred->$method(@args);
! =head2 Destructors
When the last reference to an object goes away, the object is
automatically destroyed. (This may even be after you exit, if you've
--- 269,342 ----
$method = $fast ? "findfirst" : "findbest";
$fred->$method(@args);
! =head2 Default UNIVERSAL methods
!
! The C<UNIVERSAL> package automatically contains the following methods that
! are inherited by all other classes:
!
! =over 4
!
! =item isa ( CLASS )
!
! C<isa> returns I<true> if its object is blessed into a 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 require_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.
!
! use A 1.2 qw(some imported subs);
!
! A->require_version( 1.2 );
!
! =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
!
! =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
! 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.
!
! =head2 Destructors
When the last reference to an object goes away, the object is
automatically destroyed. (This may even be after you exit, if you've
#~ Correct typos and pod formatting
#~ Correct documentation for s///: return value with no substitutions,
#~ use of backticks as delimiters
diff -Pcr perl5_003/pod/perlop.pod perl5_003_01/pod/perlop.pod
*** perl5_003/pod/perlop.pod Mon Mar 25 01:05:15 1996
--- perl5_003_01/pod/perlop.pod Mon Jun 17 19:21:12 1996
***************
*** 749,755 ****
Searches a string for a pattern, and if found, replaces that pattern
with the replacement text and returns the number of substitutions
! made. Otherwise it returns false (0).
If no string is specified via the C<=~> or C<!~> operator, the C<$_>
variable is searched and modified. (The string specified with C<=~> must
--- 749,755 ----
Searches a string for a pattern, and if found, replaces that pattern
with the replacement text and returns the number of substitutions
! made. Otherwise it returns false (specifically, the empty string).
If no string is specified via the C<=~> or C<!~> operator, the C<$_>
variable is searched and modified. (The string specified with C<=~> must
***************
*** 777,785 ****
Any non-alphanumeric, non-whitespace delimiter may replace the
slashes. If single quotes are used, no interpretation is done on the
! replacement string (the C</e> modifier overrides this, however). If
! backquotes are used, the replacement string is a command to execute
! whose output will be used as the actual replacement text. If the
PATTERN is delimited by bracketing quotes, the REPLACEMENT has its own
pair of quotes, which may or may not be bracketing quotes, e.g.
C<s(foo)(bar)> or C<sE<lt>fooE<gt>/bar/>. A C</e> will cause the
--- 777,785 ----
Any non-alphanumeric, non-whitespace delimiter may replace the
slashes. If single quotes are used, no interpretation is done on the
! replacement string (the C</e> modifier overrides this, however). Unlike
! Perl 4, Perl 5 treats backticks as normal delimiters; the replacement
! text is not evaluated as a command. If the
PATTERN is delimited by bracketing quotes, the REPLACEMENT has its own
pair of quotes, which may or may not be bracketing quotes, e.g.
C<s(foo)(bar)> or C<sE<lt>fooE<gt>/bar/>. A C</e> will cause the
***************
*** 1073,1079 ****
It you're trying to do variable interpolation, it's definitely better
to use the glob() function, because the older notation can cause people
! to become confused with the indirect filehandle notatin.
@files = glob("$dir/*.[ch]");
@files = glob($files[$i]);
--- 1073,1079 ----
It you're trying to do variable interpolation, it's definitely better
to use the glob() function, because the older notation can cause people
! to become confused with the indirect filehandle notation.
@files = glob("$dir/*.[ch]");
@files = glob($files[$i]);
#~ Correct pod formatting
diff -Pcr perl5_003/pod/perlpod.pod perl5_003_01/pod/perlpod.pod
*** perl5_003/pod/perlpod.pod Mon Jan 22 20:48:00 1996
--- perl5_003_01/pod/perlpod.pod Wed May 1 17:48:43 1996
***************
*** 104,109 ****
--- 104,111 ----
X<index> An index entry
Z<> A zero-width character
+ =back
+
That's it. The intent is simplicity, not power. I wanted paragraphs
to look like paragraphs (block format), so that they stand out
visually, and so that I could run them through fmt easily to reformat
#~ Correct typo
diff -Pcr perl5_003/pod/perlre.pod perl5_003_01/pod/perlre.pod
*** perl5_003/pod/perlre.pod Mon Mar 25 01:05:18 1996
--- perl5_003_01/pod/perlre.pod Tue Jun 18 22:01:27 1996
***************
*** 330,336 ****
whole string. As C<\d*> can match on an empty string the complete
regular expression matched successfully.
! Beginning is <I have 2: 53147>, number is <>.
Here are some variants, most of which don't work:
--- 330,336 ----
whole string. As C<\d*> can match on an empty string the complete
regular expression matched successfully.
! Beginning is <I have 2 numbers: 53147>, number is <>.
Here are some variants, most of which don't work:
#~ Note potential gc problems with cyclic data structures
#~ Distinguish between "identifier" and full variable name
diff -Pcr perl5_003/pod/perlref.pod perl5_003_01/pod/perlref.pod
*** perl5_003/pod/perlref.pod Mon Mar 25 01:05:18 1996
--- perl5_003_01/pod/perlref.pod Tue Jun 18 19:59:27 1996
***************
*** 15,25 ****
Hard references are smart--they keep track of reference counts for you,
automatically freeing the thing referred to when its reference count
! goes to zero. If that thing happens to be an object, the object is
destructed. See L<perlobj> for more about objects. (In a sense,
everything in Perl is an object, but we usually reserve the word for
references to objects that have been officially "blessed" into a class package.)
A symbolic reference contains the name of a variable, just as a
symbolic link in the filesystem merely contains the name of a file.
The C<*glob> notation is a kind of symbolic reference. Hard references
--- 15,29 ----
Hard references are smart--they keep track of reference counts for you,
automatically freeing the thing referred to when its reference count
! goes to zero. (Note: The reference counts for values in self-referential
! or cyclic data structures may not go to zero without a little help; see
! L<perlobj/"Two-Phased Garbage Collection"> for a detailed explanation.
! If that thing happens to be an object, the object is
destructed. See L<perlobj> for more about objects. (In a sense,
everything in Perl is an object, but we usually reserve the word for
references to objects that have been officially "blessed" into a class package.)
+
A symbolic reference contains the name of a variable, just as a
symbolic link in the filesystem merely contains the name of a file.
The C<*glob> notation is a kind of symbolic reference. Hard references
***************
*** 207,215 ****
=item 1.
! Anywhere you'd put an identifier as part of a variable or subroutine
! name, you can replace the identifier with a simple scalar variable
! containing a reference of the correct type:
$bar = $$scalarref;
push(@$arrayref, $filename);
--- 211,219 ----
=item 1.
! Anywhere you'd put an identifier (or chain of identifiers) as part
! of a variable or subroutine name, you can replace the identifier with
! a simple scalar variable containing a reference of the correct type:
$bar = $$scalarref;
push(@$arrayref, $filename);
***************
*** 230,239 ****
=item 2.
! Anywhere you'd put an identifier as part of a variable or subroutine
! name, you can replace the identifier with a BLOCK returning a reference
! of the correct type. In other words, the previous examples could be
! written like this:
$bar = ${$scalarref};
push(@{$arrayref}, $filename);
--- 234,243 ----
=item 2.
! Anywhere you'd put an identifier (or chain of identifiers) as part of a
! variable or subroutine name, you can replace the identifier with a
! BLOCK returning a reference of the correct type. In other words, the
! previous examples could be written like this:
$bar = ${$scalarref};
push(@{$arrayref}, $filename);
#~ Distinguish between "identifier" and full variable name
diff -Pcr perl5_003/pod/perlrun.pod perl5_003_01/pod/perlrun.pod
*** perl5_003/pod/perlrun.pod Mon Mar 25 01:05:19 1996
--- perl5_003_01/pod/perlrun.pod Wed May 1 20:35:10 1996
***************
*** 415,421 ****
=item B<-w>
! prints warnings about identifiers 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
--- 415,421 ----
=item B<-w>
! prints warnings about variable names that are mentioned only once, and
scalar variables that are used before being set. Also warns about
redefined subroutines, and references to undefined filehandles or
filehandles opened readonly that you are attempting to write on. Also
#~ Extensive rewrite
diff -Pcr perl5_003/pod/perlsec.pod perl5_003_01/pod/perlsec.pod
*** perl5_003/pod/perlsec.pod Mon Jan 22 20:48:20 1996
--- perl5_003_01/pod/perlsec.pod Mon Jul 8 11:56:19 1996
***************
*** 1,147 ****
=head1 NAME
perlsec - Perl security
=head1 DESCRIPTION
! Perl is designed to make it easy to write secure setuid and setgid
! scripts. Unlike shells, which are based on multiple substitution
! passes on each line of the script, Perl uses a more conventional
! evaluation scheme with fewer hidden "gotchas". Additionally, since the
! language has more built-in functionality, it has to rely less upon
! external (and possibly untrustworthy) programs to accomplish its
! purposes.
!
! Beyond the obvious problems that stem from giving special privileges to
! such flexible systems as scripts, on many operating systems, setuid
! scripts are inherently insecure right from the start. This is because
! that between the time that the kernel opens up the file to see what to
! run, and when the now setuid interpreter it ran turns around and reopens
! the file so it can interpret it, things may have changed, especially if
! you have symbolic links on your system.
!
! Fortunately, sometimes this kernel "feature" can be disabled.
! Unfortunately, there are two ways to disable it. The system can simply
! outlaw scripts with the setuid bit set, which doesn't help much.
! Alternately, it can simply ignore the setuid bit on scripts. If the
! latter is true, Perl can emulate the setuid and setgid mechanism when it
! notices the otherwise useless setuid/gid bits on Perl scripts. It does
! this via a special executable called B<suidperl> that is automatically
! invoked for you if it's needed.
!
! If, however, the kernel setuid script feature isn't disabled, Perl will
! complain loudly that your setuid script is insecure. You'll need to
! either disable the kernel setuid script feature, or put a C wrapper around
! the script. See the program B<wrapsuid> in the F<eg> directory of your
! Perl distribution for how to go about doing this.
- There are some systems on which setuid scripts are free of this inherent
- security bug. For example, recent releases of Solaris are like this. On
- such systems, when the kernel passes the name of the setuid script to open
- to the interpreter, rather than using a pathname subject to mettling, it
- instead passes /dev/fd/3. This is a special file already opened on the
- script, so that there can be no race condition for evil scripts to
- exploit. On these systems, Perl should be compiled with
- C<-DSETUID_SCRIPTS_ARE_SECURE_NOW>. The B<Configure> program that builds
- Perl tries to figure this out for itself.
-
- When executing a setuid script, or when you have turned on taint checking
- explicitly using the B<-T> flag, Perl takes special precautions to
- prevent you from falling into any obvious traps. (In some ways, a Perl
- script is more secure than the corresponding C program.) Any command line
- argument, environment variable, or input is marked as "tainted", and may
- not be used, directly or indirectly, in any command that invokes a
- subshell, or in any command that modifies files, directories, or
- processes. Any variable that is set within an expression that has
- previously referenced a tainted value also becomes tainted (even if it is
- logically impossible for the tainted value to influence the variable).
For example:
! $foo = shift; # $foo is tainted
! $bar = $foo,'bar'; # $bar is also tainted
! $xxx = <>; # Tainted
$path = $ENV{'PATH'}; # Tainted, but see below
! $abc = 'abc'; # Not tainted
! system "echo $foo"; # Insecure
! system "/bin/echo", $foo; # Secure (doesn't use sh)
! system "echo $bar"; # Insecure
! system "echo $abc"; # Insecure until PATH set
! $ENV{'PATH'} = '/bin:/usr/bin';
! $ENV{'IFS'} = '' if $ENV{'IFS'} ne '';
! $path = $ENV{'PATH'}; # Not tainted
! system "echo $abc"; # Is secure now!
! open(FOO,"$foo"); # OK
! open(FOO,">$foo"); # Not OK
! open(FOO,"echo $foo|"); # Not OK, but...
! open(FOO,"-|") || exec 'echo', $foo; # OK
! $zzz = `echo $foo`; # Insecure, zzz tainted
! unlink $abc,$foo; # Insecure
! umask $foo; # Insecure
! exec "echo $foo"; # Insecure
! exec "echo", $foo; # Secure (doesn't use sh)
! exec "sh", '-c', $foo; # Considered secure, alas
! The taintedness is associated with each scalar value, so some elements
! of an array can be tainted, and others not.
If you try to do something insecure, you will get a fatal error saying
something like "Insecure dependency" or "Insecure PATH". Note that you
! can still write an insecure system call or exec, but only by explicitly
! doing something like the last example above. You can also bypass the
! tainting mechanism by referencing subpatterns--Perl presumes that if
! you reference a substring using $1, $2, etc, you knew what you were
! doing when you wrote the pattern:
!
! $ARGV[0] =~ /^-P(\w+)$/;
! $printer = $1; # Not tainted
!
! This is fairly secure since C<\w+> doesn't match shell metacharacters.
! Use of C</.+/> would have been insecure, but Perl doesn't check for that,
! so you must be careful with your patterns. This is the I<ONLY> mechanism
! for untainting user supplied filenames if you want to do file operations
! on them (unless you make C<$E<gt>> equal to C<$E<lt>> ).
!
! For "Insecure $ENV{PATH}" messages, you need to set C<$ENV{'PATH'}> to a known
! value, and each directory in the path must be non-writable by the world.
! A frequently voiced gripe is that you can get this message even
! if the pathname to an executable is fully qualified. But Perl can't
! know that the executable in question isn't going to execute some other
! program depending on the PATH.
It's also possible to get into trouble with other operations that don't
care whether they use tainted values. Make judicious use of the file
tests in dealing with any user-supplied filenames. When possible, do
opens and such after setting C<$E<gt> = $E<lt>>. (Remember group IDs,
! too!) Perl doesn't prevent you from opening tainted filenames for reading,
so be careful what you print out. The tainting mechanism is intended to
prevent stupid mistakes, not to remove the need for thought.
! This gives us a reasonably safe way to open a file or pipe: just reset the
! id set to the original IDs. Here's a way to do backticks reasonably
! safely. Notice how the exec() is not called with a string that the shell
! could expand. By the time we get to the exec(), tainting is turned off,
! however, so be careful what you call and what you pass it.
die unless defined $pid = open(KID, "-|");
if ($pid) { # parent
while (<KID>) {
# do something
! }
close KID;
} else {
! $> = $<;
! $) = $(; # BUG: initgroups() not called
! exec 'program', 'arg1', 'arg2';
! die "can't exec program: $!";
}
! For those even more concerned about safety, see the I<Safe> and I<Safe CGI>
! modules at a CPAN site near you. See L<perlmod> for a list of CPAN sites.
--- 1,268 ----
+
=head1 NAME
perlsec - Perl security
=head1 DESCRIPTION
! Perl is designed to make it easy to program securely even when running
! with extra privileges, like setuid or setgid programs. Unlike most
! command-line shells, which are based on multiple substitution passes on
! each line of the script, Perl uses a more conventional evaluation scheme
! with fewer hidden snags. Additionally, because the language has more
! built-in functionality, it can rely less upon external (and possibly
! untrustworthy) programs to accomplish its purposes.
!
! Perl automatically enables a set of special security checks, called I<taint
! mode>, when it detects its program running with differing real and effective
! user or group IDs. The setuid bit in Unix permissions is mode 04000, the
! setgid bit mode 02000; either or both may be set. You can also enable taint
! mode explicitly by using the 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.
!
! While in this mode, Perl takes special precautions called I<taint
! checks> to prevent both obvious and subtle traps. Some of these checks
! are reasonably simple, such as verifying that path directories aren't
! writable by others; careful programmers have always used checks like
! these. Other checks, however, are best supported by the language itself,
! and it is these checks especially that contribute to making a setuid Perl
! program more secure than the corresponding C program.
!
! You may not use data derived from outside your program to affect something
! else outside your program--at least, not by accident. All command-line
! arguments, environment variables, 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,
! 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
! taintedness is associated with each scalar value, some elements of an
! array can be tainted and others not.
For example:
! $arg = shift; # $arg is tainted
! $hid = $arg, 'bar'; # $hid is also tainted
! $line = <>; # Tainted
$path = $ENV{'PATH'}; # Tainted, but see below
! $data = 'abc'; # Not tainted
! system "echo $arg"; # Insecure
! system "/bin/echo", $arg; # Secure (doesn't use sh)
! system "echo $hid"; # Insecure
! system "echo $data"; # Insecure until PATH set
! $path = $ENV{'PATH'}; # $path now tainted
! $ENV{'PATH'} = '/bin:/usr/bin';
! $ENV{'IFS'} = '' if $ENV{'IFS'} ne '';
! $path = $ENV{'PATH'}; # $path now NOT tainted
! system "echo $data"; # Is secure now!
! open(FOO, "< $arg"); # OK - read-only file
! open(FOO, "> $arg"); # Not OK - trying to write
! open(FOO,"echo $arg|"); # Not OK, but...
! open(FOO,"-|")
! or exec 'echo', $arg; # OK
! $shout = `echo $arg`; # Insecure, $shout now tainted
! unlink $data, $arg; # Insecure
! umask $arg; # Insecure
! exec "echo $arg"; # Insecure
! exec "echo", $arg; # Secure (doesn't use the shell)
! exec "sh", '-c', $arg; # Considered secure, alas!
If you try to do something insecure, you will get a fatal error saying
something like "Insecure dependency" or "Insecure PATH". Note that you
! can still write an insecure B<system> or B<exec>, but only by explicitly
! doing something like the last example above.
!
! =head2 Laundering and Detecting Tainted Data
!
! To test whether a variable contains tainted data, and whose use would thus
! trigger an "Insecure dependency" message, you can use the following
! I<is_tainted()> function.
!
! sub is_tainted {
! return ! eval {
! join('',@_), kill 0;
! 1;
! };
! }
!
! This function makes use of the fact that the presence of tainted data
! anywhere within an expression renders the entire expression tainted. It
! would be inefficient for every operator to test every argument for
! taintedness. Instead, the slightly more efficient and conservative
! approach is used that if any tainted value has been accessed within the
! same expression, the whole expression is considered tainted.
!
! But testing for taintedness only gets you so far. Sometimes you just have
! to clear your data's taintedness. The only way to bypass the tainting
! mechanism is by referencing subpatterns from a regular expression match.
! Perl presumes that if you reference a substring using $1, $2, etc., that
! you knew what you were doing when you wrote the pattern. That means using
! a bit of thought--don't just blindly untaint anything, or you defeat the
! entire mechanism. It's better to verify that the variable has only
! good characters (for certain values of "good") rather than checking
! whether it has any bad characters. That's because it's far too easy to
! miss bad characters that you never thought of.
!
! Here's a test to make sure that the data contains nothing but "word"
! characters (alphabetics, numerics, and underscores), a hyphen, an at sign,
! or a dot.
!
! if ($data =~ /^([-\@\w.]+)$/) {
! $data = $1; # $data now untainted
! } else {
! die "Bad data in $data"; # log this somewhere
! }
!
! This is fairly secure since C</\w+/> doesn't normally match shell
! metacharacters, nor are dot, dash, or at going to mean something special
! to the shell. Use of C</.+/> would have been insecure in theory because
! it lets everything through, but Perl doesn't check for that. The lesson
! is that when untainting, you must be exceedingly careful with your patterns.
! Laundering data using regular expression is the I<ONLY> mechanism for
! untainting dirty data, unless you use the strategy detailed below to fork
! a child of lesser privilege.
!
! =head2 Cleaning Up Your Path
!
! For "Insecure $ENV{PATH}" messages, you need to set C<$ENV{'PATH'}> to a
! known value, and each directory in the path must be non-writable by others
! than its owner and group. You may be surprised to get this message even
! if the pathname to your executable is fully qualified. This is I<not>
! generated because you didn't supply a full path to the program; instead,
! it's generated because you never set your PATH environment variable, or
! you didn't set it to something that was safe. Because Perl can't
! guarantee that the executable in question isn't itself going to turn
! around and execute some other program that is dependent on your PATH, it
! makes sure you set the PATH.
It's also possible to get into trouble with other operations that don't
care whether they use tainted values. Make judicious use of the file
tests in dealing with any user-supplied filenames. When possible, do
opens and such after setting C<$E<gt> = $E<lt>>. (Remember group IDs,
! too!) Perl doesn't prevent you from opening tainted filenames for reading,
so be careful what you print out. The tainting mechanism is intended to
prevent stupid mistakes, not to remove the need for thought.
! Perl does not call the shell to expand wild cards when you pass B<system>
! and B<exec> explicit parameter lists instead of strings with possible shell
! wildcards in them. Unfortunately, the B<open>, B<glob>, and
! backtick functions provide no such alternate calling convention, so more
! subterfuge will be required.
!
! Perl provides a reasonably safe way to open a file or pipe from a setuid
! or setgid program: just create a child process with reduced privilege who
! does the dirty work for you. First, fork a child using the special
! B<open> syntax that connects the parent and child by a pipe. Now the
! child resets its ID set and any other per-process attributes, like
! environment variables, umasks, current working directories, back to the
! originals or known safe values. Then the child process, which no longer
! has any special permissions, does the B<open> or other system call.
! Finally, the child passes the data it managed to access back to the
! parent. Since the file or pipe was opened in the child while running
! under less privilege than the parent, it's not apt to be tricked into
! doing something it shouldn't.
!
! Here's a way to do backticks reasonably safely. Notice how the B<exec> is
! not called with a string that the shell could expand. This is by far the
! best way to call something that might be subjected to shell escapes: just
! never call the shell at all. By the time we get to the B<exec>, tainting
! is turned off, however, so be careful what you call and what you pass it.
+ use English;
die unless defined $pid = open(KID, "-|");
if ($pid) { # parent
while (<KID>) {
# do something
! }
close KID;
} else {
! $EUID = $UID;
! $EGID = $GID; # XXX: initgroups() not called
! $ENV{PATH} = "/bin:/usr/bin";
! exec 'myprog', 'arg1', 'arg2';
! die "can't exec myprog: $!";
! }
!
! A similar strategy would work for wildcard expansion via C<glob>.
!
! Taint checking is most useful when although you trust yourself not to have
! written a program to give away the farm, you don't necessarily trust those
! who end up using it not to try to trick it into doing something bad. This
! is the kind of security checking that's useful for setuid programs and
! programs launched on someone else's behalf, like CGI programs.
!
! This is quite different, however, from not even trusting the writer of the
! code not to try to do something evil. That's the kind of trust needed
! when someone hands you a program you've never seen before and says, "Here,
! run this." For that kind of safety, check out the Safe module,
! included standard in the Perl distribution. This module allows the
! programmer to set up special compartments in which all system operations
! are trapped and namespace access is carefully controlled.
!
! =head2 Security Bugs
!
! Beyond the obvious problems that stem from giving special privileges to
! systems as flexible as scripts, on many versions of Unix, setuid scripts
! are inherently insecure right from the start. The problem is a race
! condition in the kernel. Between the time the kernel opens the file to
! see which interpreter to run and when the (now-setuid) interpreter turns
! around and reopens the file to interpret it, the file in question may have
! changed, especially if you have symbolic links on your system.
!
! Fortunately, sometimes this kernel "feature" can be disabled.
! Unfortunately, there are two ways to disable it. The system can simply
! outlaw scripts with the setuid bit set, which doesn't help much.
! Alternately, it can simply ignore the setuid bit on scripts. If the
! latter is true, Perl can emulate the setuid and setgid mechanism when it
! notices the otherwise useless setuid/gid bits on Perl scripts. It does
! this via a special executable called B<suidperl> that is automatically
! invoked for you if it's needed.
!
! However, if the kernel setuid script feature isn't disabled, Perl will
! complain loudly that your setuid script is insecure. You'll need to
! either disable the kernel setuid script feature, or put a C wrapper around
! the script. A C wrapper is just a compiled program that does nothing
! except call your Perl program. Compiled programs are not subject to the
! kernel bug that plagues setuid scripts. Here's a simple wrapper, written
! in C:
!
! #define REAL_PATH "/path/to/script"
! main(ac, av)
! char **av;
! {
! execv(REAL_PATH, av);
}
! Compile this wrapper into a binary executable and then make I<it> rather
! than your script setuid or setgid.
!
! See the program B<wrapsuid> in the F<eg> directory of your Perl
! distribution for a convenient way to do this automatically for all your
! setuid Perl programs. It moves setuid scripts into files with the same
! name plus a leading dot, and then compiles a wrapper like the one above
! for each of them.
!
! In recent years, vendors have begun to supply systems free of this
! inherent security bug. On such systems, when the kernel passes the name
! of the setuid script to open to the interpreter, rather than using a
! pathname subject to meddling, it instead passes I</dev/fd/3>. This is a
! special file already opened on the script, so that there can be no race
! condition for evil scripts to exploit. On these systems, Perl should be
! compiled with C<-DSETUID_SCRIPTS_ARE_SECURE_NOW>. The B<Configure>
! program that builds Perl tries to figure this out for itself, so you
! should never have to specify this yourself. Most modern releases of
! SysVr4 and BSD 4.4 use this approach to avoid the kernel race condition.
!
! Prior to release 5.003 of Perl, a bug in the code of B<suidperl> could
! introduce a security hole in systems compiled with strict POSIX
! compliance.
#~ Typos corrected
#~ Update reference to AutoLoader/AutoSplit documentation
diff -Pcr perl5_003/pod/perlsub.pod perl5_003_01/pod/perlsub.pod
*** perl5_003/pod/perlsub.pod Mon Mar 25 01:05:22 1996
--- perl5_003_01/pod/perlsub.pod Fri Jul 5 16:56:18 1996
***************
*** 58,67 ****
Perl does not have named formal parameters, but in practice all you do is
assign to a my() list of these. Any variables you use in the function
that aren't declared private are global variables. For the gory details
! on creating private variables, see the sections below on L<"Private
! Variables via my()"> and L</"Temporary Values via local()">. To create
! protected environments for a set of functions in a separate package (and
! probably a separate file), see L<perlmod/"Packages">.
Example:
--- 58,67 ----
Perl does not have named formal parameters, but in practice all you do is
assign to a my() list of these. Any variables you use in the function
that aren't declared private are global variables. For the gory details
! on creating private variables, see the sections below on
! L<"Private Variables via my()"> and L<"Temporary Values via local()">.
! To create protected environments for a set of functions in a separate
! package (and probably a separate file), see L<perlmod/"Packages">.
Example:
***************
*** 286,292 ****
You may declare "my" variables at the outer most scope of a file to
totally hide any such identifiers from the outside world. This is similar
! to a C's static variables at the file level. To do this with a subroutine
requires the use of a closure (anonymous function). If a block (such as
an eval(), function, or C<package>) wants to create a private subroutine
that cannot be called from outside that block, it can declare a lexical
--- 286,292 ----
You may declare "my" variables at the outer most scope of a file to
totally hide any such identifiers from the outside world. This is similar
! to C's static variables at the file level. To do this with a subroutine
requires the use of a closure (anonymous function). If a block (such as
an eval(), function, or C<package>) wants to create a private subroutine
that cannot be called from outside that block, it can declare a lexical
***************
*** 342,348 ****
=head2 Temporary Values via local()
B<NOTE>: In general, you should be using "my" instead of "local", because
! it's faster and safer. Execeptions to this include the global punctuation
variables, filehandles and formats, and direct manipulation of the Perl
symbol table itself. Format variables often use "local" though, as do
other variables whose current value must be visible to called
--- 342,348 ----
=head2 Temporary Values via local()
B<NOTE>: In general, you should be using "my" instead of "local", because
! it's faster and safer. Exceptions to this include the global punctuation
variables, filehandles and formats, and direct manipulation of the Perl
symbol table itself. Format variables often use "local" though, as do
other variables whose current value must be visible to called
***************
*** 637,643 ****
The interesting thing about & is that you can generate new syntax with it:
! sub try (&$) {
my($try,$catch) = @_;
eval { &$try };
if ($@) {
--- 637,643 ----
The interesting thing about & is that you can generate new syntax with it:
! sub try (&@) {
my($try,$catch) = @_;
eval { &$try };
if ($@) {
***************
*** 764,770 ****
system($program, @_);
}
date();
! who('am', i');
ls('-l');
In fact, if you preclare the functions you want to call that way, you don't
--- 764,770 ----
system($program, @_);
}
date();
! who('am', 'i');
ls('-l');
In fact, if you preclare the functions you want to call that way, you don't
***************
*** 779,787 ****
can treat undefined subroutine calls as calls to Unix programs.
Mechanisms are available for modules writers to help split the modules
! up into autoloadable files. See the standard AutoLoader module described
! in L<Autoloader>, the standard SelfLoader modules in L<SelfLoader>, and
! the document on adding C functions to perl code in L<perlxs>.
=head1 SEE ALSO
--- 779,788 ----
can treat undefined subroutine calls as calls to Unix programs.
Mechanisms are available for modules writers to help split the modules
! up into autoloadable files. See the standard AutoLoader module
! described in L<AutoLoader> and in L<AutoSplit>, the standard
! SelfLoader modules in L<SelfLoader>, and the document on adding C
! functions to perl code in L<perlxs>.
=head1 SEE ALSO
#~ Quote package name in tie -- required when using strict subs
#~ Make return value in example meaningful
diff -Pcr perl5_003/pod/perltie.pod perl5_003_01/pod/perltie.pod
*** perl5_003/pod/perltie.pod Mon Mar 25 01:05:23 1996
--- perl5_003_01/pod/perltie.pod Mon Jul 15 13:36:22 1996
***************
*** 192,198 ****
aggregate assignment would be missed.) For example:
require Bounded_Array;
! tie @ary, Bounded_Array, 2;
$| = 1;
for $i (0 .. 10) {
print "setting index $i: ";
--- 192,198 ----
aggregate assignment would be missed.) For example:
require Bounded_Array;
! tie @ary, 'Bounded_Array', 2;
$| = 1;
for $i (0 .. 10) {
print "setting index $i: ";
***************
*** 317,323 ****
contents. For example:
use DotFiles;
! tie %dot, DotFiles;
if ( $dot{profile} =~ /MANPATH/ ||
$dot{login} =~ /MANPATH/ ||
$dot{cshrc} =~ /MANPATH/ )
--- 317,323 ----
contents. For example:
use DotFiles;
! tie %dot, 'DotFiles';
if ( $dot{profile} =~ /MANPATH/ ||
$dot{login} =~ /MANPATH/ ||
$dot{cshrc} =~ /MANPATH/ )
***************
*** 327,333 ****
Or here's another sample of using our tied class:
! tie %him, DotFiles, 'daemon';
foreach $f ( keys %him ) {
printf "daemon dot file %s is size %d\n",
$f, length $him{$f};
--- 327,333 ----
Or here's another sample of using our tied class:
! tie %him, 'DotFiles', 'daemon';
foreach $f ( keys %him ) {
printf "daemon dot file %s is size %d\n",
$f, length $him{$f};
***************
*** 509,517 ****
croak "@{[&whowasi]}: won't remove file $file"
unless $self->{CLOBBER};
delete $self->{LIST}->{$dot};
! unlink($file) || carp "@{[&whowasi]}: can't unlink $file: $!";
}
=item CLEAR this
This method is triggered when the whole hash is to be cleared, usually by
--- 509,525 ----
croak "@{[&whowasi]}: won't remove file $file"
unless $self->{CLOBBER};
delete $self->{LIST}->{$dot};
! my $success = unlink($file);
! carp "@{[&whowasi]}: can't unlink $file: $!" unless $success;
! $success;
}
+ The value returned by DELETE becomes the return value of the call
+ to delete(). If you want to emulate the normal behavior of delete(),
+ you should return whatever FETCH would have returned for this key.
+ In this example, we have chosen instead to return a value which tells
+ the caller whether the file was successfully deleted.
+
=item CLEAR this
This method is triggered when the whole hash is to be cleared, usually by
***************
*** 592,598 ****
# print out history file offsets
use NDBM_File;
! tie(%HIST, NDBM_File, '/usr/lib/news/history', 1, 0);
while (($key,$val) = each %HIST) {
print $key, ' = ', unpack('L',$val), "\n";
}
--- 600,606 ----
# print out history file offsets
use NDBM_File;
! tie(%HIST, 'NDBM_File', '/usr/lib/news/history', 1, 0);
while (($key,$val) = each %HIST) {
print $key, ' = ', unpack('L',$val), "\n";
}
#~ Fix pod formatting
diff -Pcr perl5_003/pod/perltoc.pod perl5_003_01/pod/perltoc.pod
*** perl5_003/pod/perltoc.pod Mon Mar 25 01:05:23 1996
--- perl5_003_01/pod/perltoc.pod Fri Jul 5 17:03:18 1996
***************
*** 323,329 ****
=item Alphabetical Listing of Perl Functions
! -X FILEHANDLE, -X EXPR, -X, abs VALUE, accept NEWSOCKET,GENERICSOCKET,
alarm SECONDS, atan2 Y,X, bind SOCKET,NAME, binmode FILEHANDLE, bless
REF,CLASSNAME, bless REF, caller EXPR, caller, chdir EXPR, chmod LIST,
chomp VARIABLE, chomp LIST, chomp, chop VARIABLE, chop LIST, chop,
--- 323,329 ----
=item Alphabetical Listing of Perl Functions
! -I<X> FILEHANDLE, -I<X> EXPR, -I<X>, abs VALUE, accept NEWSOCKET,GENERICSOCKET,
alarm SECONDS, atan2 Y,X, bind SOCKET,NAME, binmode FILEHANDLE, bless
REF,CLASSNAME, bless REF, caller EXPR, caller, chdir EXPR, chmod LIST,
chomp VARIABLE, chomp LIST, chomp, chop VARIABLE, chop LIST, chop,
***************
*** 1697,1703 ****
overload::StrVal(arg), overload::Overloaded(arg),
! overload::Method(obj,op)
=item IMPLEMENTATION
--- 1697,1703 ----
overload::StrVal(arg), overload::Overloaded(arg),
! C<overload::Method(obj,op)>
=item IMPLEMENTATION
***************
*** 1831,1837 ****
=item Standard Exports
! timeit(COUNT, CODE), timethis, timethese, timediff, timestr
=item Optional Exports
--- 1831,1837 ----
=item Standard Exports
! C<timeit(COUNT, CODE)>, timethis, timethese, timediff, timestr
=item Optional Exports
#~ Typos and pod formatting corrected
#~ Perl4 - Perl5 traps revised extensively
diff -Pcr perl5_003/pod/perltrap.pod perl5_003_01/pod/perltrap.pod
*** perl5_003/pod/perltrap.pod Tue Jan 30 13:23:50 1996
--- perl5_003_01/pod/perltrap.pod Mon Jul 29 19:27:52 1996
***************
*** 58,64 ****
=item *
Reading an input line does not split it for you. You get to split it
! yourself to an array. And split() operator has different
arguments.
=item *
--- 58,64 ----
=item *
Reading an input line does not split it for you. You get to split it
! yourself to an array. And the split() operator has different
arguments.
=item *
***************
*** 172,178 ****
=item *
! printf() does not implement the "*" format for interpolating
field widths, but it's trivial to use interpolation of double-quoted
strings to achieve the same effect.
--- 172,178 ----
=item *
! C<printf()> does not implement the "*" format for interpolating
field widths, but it's trivial to use interpolation of double-quoted
strings to achieve the same effect.
***************
*** 231,237 ****
=item *
! The backtick operator does variable interpretation without regard to
the presence of single quotes in the command.
=item *
--- 231,237 ----
=item *
! The backtick operator does variable interpolation without regard to
the presence of single quotes in the command.
=item *
***************
*** 293,299 ****
default to $_, or @ARGV, or whatever, but that others which
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
--- 293,299 ----
default to $_, or @ARGV, or whatever, but that others which
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
***************
*** 303,309 ****
while ($_ = <FH>) { }..
<FH>; # data discarded!
! =item *
Remember not to use "C<=>" when you need "C<=~>";
these two constructs are quite different:
--- 303,309 ----
while ($_ = <FH>) { }..
<FH>; # data discarded!
! =item *
Remember not to use "C<=>" when you need "C<=~>";
these two constructs are quite different:
***************
*** 318,326 ****
=item *
! Use my() for local variables whenever you can get away with
it (but see L<perlform> for where you can't).
! Using local() actually gives a local value to a global
variable, which leaves you open to unforeseen side-effects
of dynamic scoping.
--- 318,326 ----
=item *
! Use C<my()> for local variables whenever you can get away with
it (but see L<perlform> for where you can't).
! Using C<local()> actually gives a local value to a global
variable, which leaves you open to unforeseen side-effects
of dynamic scoping.
***************
*** 332,406 ****
=back
! =head2 Perl4 Traps
! Penitent Perl 4 Programmers should take note of the following
! incompatible changes that occurred between release 4 and release 5:
=over 4
! =item *
! C<@> now always interpolates an array in double-quotish strings. Some programs
! may now need to use backslash to protect any C<@> that shouldn't interpolate.
! =item *
! Barewords that used to look like strings to Perl will now look like subroutine
! calls if a subroutine by that name is defined before the compiler sees them.
! For example:
! sub SeeYa { die "Hasta la vista, baby!" }
! $SIG{'QUIT'} = SeeYa;
! In Perl 4, that set the signal handler; in Perl 5, it actually calls the
! function! You may use the B<-w> switch to find such places.
! =item *
! Symbols starting with C<_> are no longer forced into package C<main>, except
! for $_ itself (and @_, etc.).
! =item *
! Double-colon is now a valid package separator in an identifier. Thus these
! behave differently in perl4 vs. perl5:
! print "$a::$b::$c\n";
print "$var::abc::xyz\n";
! =item *
! C<s'$lhs'$rhs'> now does no interpolation on either side. It used to
! interpolate C<$lhs> but not C<$rhs>.
! =item *
! The second and third arguments of splice() are now evaluated in scalar
! context (as the book says) rather than list context.
! =item *
! These are now semantic errors because of precedence:
! shift @list + 20;
! $n = keys %map + 20;
! Because if that were to work, then this couldn't:
! sleep $dormancy + 20;
! =item *
The precedence of assignment operators is now the same as the precedence
of assignment. Perl 4 mistakenly gave them the precedence of the associated
operator. So you now must parenthesize them in expressions like
/foo/ ? ($a += 2) : ($a -= 2);
!
Otherwise
! /foo/ ? $a += 2 : $a -= 2;
would be erroneously parsed as
--- 332,898 ----
=back
! =head2 Perl4 to Perl5 Traps
! Practicing Perl4 Programmers should take note of the following
! Perl4-to-Perl5 specific traps.
!
! They're crudely ordered according to the following list:
=over 4
! =item Discontinuance, Deprecation, and BugFix traps
! Anything that's been fixed as a perl4 bug, removed as a perl4 feature
! or deprecated as a perl4 feature with the intent to encourage usage of
! some other perl5 feature.
! =item Parsing Traps
! Traps that appear to stem from the new parser.
! =item Numerical Traps
! Traps having to do with numerical or mathematical operators.
! =item General data type traps
! Traps involving perl standard data types.
! =item Context Traps - scalar, list contexts
!
! Traps related to context within lists, scalar statements/declarations.
!
! =item Precedence Traps
!
! Traps related to the precedence of parsing, evaluation, and execution of
! code.
!
! =item General Regular Expression Traps using s///, etc.
! Traps related to the use of pattern matching.
!
! =item Subroutine, Signal, Sorting Traps
!
! Traps related to the use of signals and signal handlers, general subroutines,
! and sorting, along with sorting subroutines.
!
! =item OS Traps
!
! OS-specific traps.
!
! =item DBM Traps
!
! Traps specific to the use of C<dbmopen()>, and specific dbm implementations.
!
! =item Unclassified Traps
!
! Everything else.
!
! =back
!
! If you find an example of a conversion trap that is not listed here,
! please submit it to Bill Middleton F<wjm@best.com> for inclusion.
! Also note that at least some of these can be caught with C<-w>.
!
! =head2 Discontinuance, Deprecation, and BugFix traps
!
! Anything that has been discontinued, deprecated, or fixed as
! a bug from perl4.
!
! =over 4
! =item * Discontinuance
!
! Symbols starting with "_" are no longer forced into package main, except
! for C<$_> itself (and C<@_>, etc.).
!
! package test;
! $_legacy = 1;
!
! package main;
! print "\$_legacy is ",$_legacy,"\n";
!
! # perl4 prints: $_legacy is 1
! # perl5 prints: $_legacy is
!
! =item * Deprecation
!
! Double-colon is now a valid package separator in a variable name. Thus these
! behave differently in perl4 vs. perl5, since the packages don't exist.
!
! $a=1;$b=2;$c=3;$var=4;
! print "$a::$b::$c ";
print "$var::abc::xyz\n";
+
+ # perl4 prints: 1::2::3 4::abc::xyz
+ # perl5 prints: 3
+
+ Given that C<::> is now the preferred package delimiter, it is debatable
+ whether this should be classed as a bug or not.
+ (The older package delimiter, ' ,is used here)
+
+ $x = 10 ;
+ print "x=${'x}\n" ;
+
+ # perl4 prints: x=10
+ # perl5 prints: Can't find string terminator "'" anywhere before EOF
+
+ Also see precedence traps, for parsing C<$:>.
+
+ =item * BugFix
+
+ The second and third arguments of C<splice()> are now evaluated in scalar
+ context (as the Camel says) rather than list context.
+
+ sub sub1{return(0,2) } # return a 2-elem array
+ sub sub2{ return(1,2,3)} # return a 3-elem array
+ @a1 = ("a","b","c","d","e");
+ @a2 = splice(@a1,&sub1,&sub2);
+ print join(' ',@a2),"\n";
+
+ # perl4 prints: a b
+ # perl5 prints: c d e
! =item * Discontinuance
! You can't do a C<goto> into a block that is optimized away. Darn.
! goto marker1;
! for(1){
! marker1:
! print "Here I is!\n";
! }
!
! # perl4 prints: Here I is!
! # perl5 dumps core (SEGV)
! =item * Discontinuance
! It is no longer syntactically legal to use whitespace as the name
! of a variable, or as a delimiter for any kind of quote construct.
! Double darn.
! $a = ("foo bar");
! $b = q baz ;
! print "a is $a, b is $b\n";
!
! # perl4 prints: a is foo bar, b is baz
! # perl5 errors: Bare word found where operator expected
!
! =item * Discontinuance
!
! The archaic while/if BLOCK BLOCK syntax is no longer supported.
!
! if { 1 } {
! print "True!";
! }
! else {
! print "False!";
! }
!
! # perl4 prints: True!
! # perl5 errors: syntax error at test.pl line 1, near "if {"
! =item * BugFix
! The C<**> operator now binds more tightly than unary minus.
! It was documented to work this way before, but didn't.
! print -4**2,"\n";
!
! # perl4 prints: 16
! # perl5 prints: -16
!
! =item * Discontinuance
!
! The meaning of C<foreach{}> has changed slightly when it is iterating over a
! list which is not an array. This used to assign the list to a
! temporary array, but no longer does so (for efficiency). This means
! that you'll now be iterating over the actual values, not over copies of
! the values. Modifications to the loop variable can change the original
! values.
!
! @list = ('ab','abc','bcd','def');
! foreach $var (grep(/ab/,@list)){
! $var = 1;
! }
! print (join(':',@list));
!
! # perl4 prints: ab:abc:bcd:def
! # perl5 prints: 1:1:bcd:def
!
! To retain Perl4 semantics you need to assign your list
! explicitly to a temporary array and then iterate over that. For
! example, you might need to change
!
! foreach $var (grep(/ab/,@list)){
!
! to
!
! foreach $var (@tmp = grep(/ab/,@list)){
!
! Otherwise changing $var will clobber the values of @list. (This most often
! happens when you use C<$_> for the loop variable, and call subroutines in
! the loop that don't properly localize C<$_>.)
!
! =item * Deprecation
!
! Some error messages will be different.
!
! =item * Discontinuance
!
! Some bugs may have been inadvertently removed. :-)
!
! =back
!
! =head2 Parsing Traps
!
! Perl4-to-Perl5 traps from having to do with parsing.
!
! =over 4
!
! =item * Parsing
!
! Note the space between . and =
!
! $string . = "more string";
! print $string;
!
! # perl4 prints: more string
! # perl5 prints: syntax error at - line 1, near ". ="
!
! =item * Parsing
!
! Better parsing in perl 5
!
! sub foo {}
! &foo
! print("hello, world\n");
!
! # perl4 prints: hello, world
! # perl5 prints: syntax error
!
! =item * Parsing
!
! "if it looks like a function, it is a function" rule.
!
! print
! ($foo == 1) ? "is one\n" : "is zero\n";
!
! # perl4 prints: is zero
! # perl5 warns: "Useless use of a constant in void context" if using -w
!
! =back
!
! =head2 Numerical Traps
!
! Perl4-to-Perl5 traps having to do with numerical operators,
! operands, or output from same.
!
! =over 5
!
! =item * Numerical
!
! Formatted output and significant digits
!
! print 7.373504 - 0, "\n";
! printf "%20.18f\n", 7.373504 - 0;
!
! # Perl4 prints:
! 7.375039999999996141
! 7.37503999999999614
!
! # Perl5 prints:
! 7.373504
! 7.37503999999999614
!
! =item * Numerical
!
! Large integer trap with autoincrement
!
! $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
!
! =item * Numerical
!
! Assignment of return values from numeric equality tests
! does not work in perl5 when the test evaluates to false (0).
! Logical tests now return an null, instead of 0
!
! $p = ($test == 1);
! print $p,"\n";
!
! # perl4 prints: 0
! # perl5 prints:
!
! Also see the L<General Regular Expression Traps> tests for another example
! of this new feature...
!
! =back
!
! =head2 General data type traps
!
! Perl4-to-Perl5 traps involving most data-types, and their usage
! within certain expressions and/or context.
!
! =over 5
!
! =item * (Arrays)
!
! Negative array subscripts now count from the end of the array.
!
! @a = (1, 2, 3, 4, 5);
! print "The third element of the array is $a[3] also expressed as $a[-2] \n";
!
! # perl4 prints: The third element of the array is 4 also expressed as
! # perl5 prints: The third element of the array is 4 also expressed as 4
!
! =item * (Arrays)
!
! Setting C<$#array> lower now discards array elements, and makes them
! impossible to recover.
!
! @a = (a,b,c,d,e);
! print "Before: ",join('',@a);
! $#a =1;
! print ", After: ",join('',@a);
! $#a =3;
! print ", Recovered: ",join('',@a),"\n";
!
! # perl4 prints: Before: abcde, After: ab, Recovered: abcd
! # perl5 prints: Before: abcde, After: ab, Recovered: ab
!
! =item * (Hashes)
!
! Hashes get defined before use
!
! local($s,@a,%h);
! die "scalar \$s defined" if defined($s);
! die "array \@a defined" if defined(@a);
! die "hash \%h defined" if defined(%h);
!
! # perl4 prints:
! # perl5 dies: hash %h defined
!
! =item * (Globs)
!
! glob assignment from variable to variable will fail if the assigned
! variable is localized subsequent to the assignment
!
! @a = ("This is Perl 4");
! *b = *a;
! local(@a);
! print @b,"\n";
!
! # perl4 prints: This is Perl 4
! # perl5 prints:
!
! # Another example
!
! *fred = *barney; # fred is aliased to barney
! @barney = (1, 2, 4);
! # @fred;
! print "@fred"; # should print "1, 2, 4"
!
! # perl4 prints: 1 2 4
! # perl5 prints: Literal @fred now requires backslash
!
! =item * (Scalar String)
!
! Changes in unary negation (of strings)
! This change effects both the return value and what it
! does to auto(magic)increment.
!
! $x = "aaa";
! print ++$x," : ";
! print -$x," : ";
! print ++$x,"\n";
!
! # perl4 prints: aab : -0 : 1
! # perl5 prints: aab : -aab : aac
!
! =item * (Constants)
!
! perl 4 lets you modify constants:
!
! $foo = "x";
! &mod($foo);
! for ($x = 0; $x < 3; $x++) {
! &mod("a");
! }
! sub mod {
! print "before: $_[0]";
! $_[0] = "m";
! print " after: $_[0]\n";
! }
!
! # perl4:
! # before: x after: m
! # before: a after: m
! # before: m after: m
! # before: m after: m
!
! # Perl5:
! # before: x after: m
! # Modification of a read-only value attempted at foo.pl line 12.
! # before: a
!
! =item * (Scalars)
!
! The behavior is slightly different for:
!
! print "$x", defined $x
!
! # perl 4: 1
! # perl 5: <no output, $x is not called into existence>
!
! =item * (Variable Suicide)
!
! Variable suicide behavior is more consistent under Perl 5.
! Perl5 exhibits the same behavior for associative arrays and scalars,
! that perl4 exhibits only for scalars.
!
! $aGlobal{ "aKey" } = "global value";
! print "MAIN:", $aGlobal{"aKey"}, "\n";
! $GlobalLevel = 0;
! &test( *aGlobal );
!
! sub test {
! local( *theArgument ) = @_;
! local( %aNewLocal ); # perl 4 != 5.001l,m
! $aNewLocal{"aKey"} = "this should never appear";
! print "SUB: ", $theArgument{"aKey"}, "\n";
! $aNewLocal{"aKey"} = "level $GlobalLevel"; # what should print
! $GlobalLevel++;
! if( $GlobalLevel<4 ) {
! &test( *aNewLocal );
! }
! }
!
! # Perl4:
! # MAIN:global value
! # SUB: global value
! # SUB: level 0
! # SUB: level 1
! # SUB: level 2
!
! # Perl5:
! # MAIN:global value
! # SUB: global value
! # SUB: this should never appear
! # SUB: this should never appear
! # SUB: this should never appear
!
! =back
!
! =head2 Context Traps - scalar, list contexts
!
! =over 5
!
! =item * (list context)
!
! The elements of argument lists for formats are now evaluated in list
! context. This means you can interpolate list values now.
!
! @fmt = ("foo","bar","baz");
! format STDOUT=
! @<<<<< @||||| @>>>>>
! @fmt;
! .
! write;
!
! # perl4 errors: Please use commas to separate fields in file
! # perl5 prints: foo bar baz
!
! =item * (scalar context)
!
! The C<caller()> function now returns a false value in a scalar context
! if there is no caller. This lets library files determine if they're
! being required.
!
! caller() ? (print "You rang?\n") : (print "Got a 0\n");
!
! # perl4 errors: There is no caller
! # perl5 prints: Got a 0
!
! =item * (scalar context)
!
! The comma operator in a scalar context is now guaranteed to give a
! scalar context to its arguments.
!
! @y= ('a','b','c');
! $x = (1, 2, @y);
! print "x = $x\n";
!
! # Perl4 prints: x = c # Thinks list context interpolates list
! # Perl5 prints: x = 3 # Knows scalar uses length of list
!
! =item * (list, builtin)
!
! C<sprintf()> funkiness (array argument converted to scalar array count)
! This test could be added to t/op/sprintf.t
!
! @z = ('%s%s', 'foo', 'bar');
! $x = sprintf(@z);
! if ($x eq 'foobar') {print "ok 2\n";} else {print "not ok 2 '$x'\n";}
!
! # perl4 prints: ok 2
! # perl5 prints: not ok 2
!
! C<printf()> works fine, though:
!
! printf STDOUT (@z);
! print "\n";
!
! # perl4 prints: foobar
! # perl5 prints: foobar
!
! Probably a bug.
!
! =back
!
! =head2 Precedence Traps
!
! Perl4-to-Perl5 traps involving precedence order.
!
! =item *
!
! These are now semantic errors because of precedence:
!
! @list = (1,2,3,4,5);
! %map = ("a",1,"b",2,"c",3,"d",4);
! $n = shift @list + 2; # first item in list plus 2
! print "n is $n, ";
! $m = keys %map + 2; # number of items in hash plus 2
! print "m is $m\n";
!
! # perl4 prints: n is 3, m is 6
! # perl5 errors and fails to compile
!
! =item * Precedence
The precedence of assignment operators is now the same as the precedence
of assignment. Perl 4 mistakenly gave them the precedence of the associated
operator. So you now must parenthesize them in expressions like
/foo/ ? ($a += 2) : ($a -= 2);
!
Otherwise
! /foo/ ? $a += 2 : $a -= 2
would be erroneously parsed as
***************
*** 408,522 ****
On the other hand,
! $a += /foo/ ? 1 : 2;
now works as a C programmer would expect.
! =item *
! C<open FOO || die> is now incorrect. You need parens around the filehandle.
! While temporarily supported, using such a construct will
! generate a non-fatal (but non-suppressible) warning.
! =item *
! The elements of argument lists for formats are now evaluated in list
! context. This means you can interpolate list values now.
! =item *
! You can't do a C<goto> into a block that is optimized away. Darn.
! =item *
! It is no longer syntactically legal to use whitespace as the name
! of a variable, or as a delimiter for any kind of quote construct.
! Double darn.
! =item *
! The caller() function now returns a false value in a scalar context if there
! is no caller. This lets library files determine if they're being required.
! =item *
C<m//g> now attaches its state to the searched string rather than the
! regular expression.
! =item *
- C<reverse> is no longer allowed as the name of a sort subroutine.
! =item *
! B<taintperl> is no longer a separate executable. There is now a B<-T>
! switch to turn on tainting when it isn't turned on automatically.
! =item *
! Double-quoted strings may no longer end with an unescaped C<$> or C<@>.
! =item *
! The archaic C<while/if> BLOCK BLOCK syntax is no longer supported.
! =item *
! Negative array subscripts now count from the end of the array.
! =item *
! The comma operator in a scalar context is now guaranteed to give a
! scalar context to its arguments.
! =item *
- The C<**> operator now binds more tightly than unary minus.
- It was documented to work this way before, but didn't.
- =item *
! Setting C<$#array> lower now discards array elements.
! =item *
! delete() is not guaranteed to return the old value for tie()d arrays,
! since this capability may be onerous for some modules to implement.
! =item *
The construct "this is $$x" used to interpolate the pid at that
! point, but now tries to dereference $x. C<$$> by itself still
works fine, however.
! =item *
! The meaning of foreach has changed slightly when it is iterating over a
! list which is not an array. This used to assign the list to a
! temporary array, but no longer does so (for efficiency). This means
! that you'll now be iterating over the actual values, not over copies of
! the values. Modifications to the loop variable can change the original
! values. To retain Perl 4 semantics you need to assign your list
! explicitly to a temporary array and then iterate over that. For
! example, you might need to change
! foreach $var (grep /x/, @list) { ... }
to
! foreach $var (my @tmp = grep /x/, @list) { ... }
! Otherwise changing C<$var> will clobber the values of @list. (This most often
! happens when you use C<$_> for the loop variable, and call subroutines in
! the loop that don't properly localize C<$_>.)
! =item *
! Some error messages will be different.
! =item *
! Some bugs may have been inadvertently removed.
=back
--- 900,1354 ----
On the other hand,
! $a += /foo/ ? 1 : 2;
now works as a C programmer would expect.
! =item * Precedence
! open FOO || die;
! is now incorrect. You need parens around the filehandle.
! Otherwise, perl5 leaves the statement as it's default precedence:
! open(FOO || die);
!
! # perl4 opens or dies
! # perl5 errors: Precedence problem: open FOO should be open(FOO)
! =item * Precedence
! perl4 gives the special variable, C<$:> precedence, where perl5
! treats C<$::> as main C<package>
! $a = "x"; print "$::a";
!
! # perl 4 prints: -:a
! # perl 5 prints: x
!
! =item * Precedence
! concatenation precedence over filetest operator?
! -e $foo .= "q"
!
! # perl4 prints: no output
! # perl5 prints: Can't modify -e in concatenation
! =item * Precedence
! Assignment to value takes precedence over assignment to key in
! perl5 when using the shift operator on both sides.
!
! @arr = ( 'left', 'right' );
! $a{shift @arr} = shift @arr;
! print join( ' ', keys %a );
!
! # perl4 prints: left
! # perl5 prints: right
!
! =back
!
! =head2 General Regular Expression Traps using s///, etc.
!
! All types of RE traps.
!
! =over 5
!
! =item * Regular Expression
!
! C<s'$lhs'$rhs'> now does no interpolation on either side. It used to
! interpolate C<$lhs> but not C<$rhs>. (And still does not match a literal
! '$' in string)
!
! $a=1;$b=2;
! $string = '1 2 $a $b';
! $string =~ s'$a'$b';
! print $string,"\n";
!
! # perl4 prints: $b 2 $a $b
! # perl5 prints: 1 2 $a $b
!
! =item * Regular Expression
C<m//g> now attaches its state to the searched string rather than the
! regular expression. (Once the scope of a block is left for the sub, the
! state of the searched string is lost)
! $_ = "ababab";
! while(m/ab/g){
! &doit("blah");
! }
! sub doit{local($_) = shift; print "Got $_ "}
!
! # perl4 prints: blah blah blah
! # perl5 prints: infinite loop blah...
!
! =item * Regular Expression
!
! If no parentheses are used in a match, Perl4 sets C<$+> to
! the whole match, just like C<$&>. Perl5 does not.
!
! "abcdef" =~ /b.*e/;
! print "\$+ = $+\n";
!
! # perl4 prints: bcde
! # perl5 prints:
!
! =item * Regular Expression
!
! substitution now returns the null string if it fails
!
! $string = "test";
! $value = ($string =~ s/foo//);
! print $value, "\n";
!
! # perl4 prints: 0
! # perl5 prints:
!
! Also see L<Numerical Traps> for another example of this new feature.
!
! =item * Regular Expression
!
! C<s`lhs`rhs`> (using backticks) is now a normal substitution, with no
! backtick expansion
!
! $string = "";
! $string =~ s`^`hostname`;
! print $string, "\n";
!
! # perl4 prints: <the local hostname>
! # perl5 prints: hostname
!
! =item * Regular Expression
!
! Stricter parsing of variables used in regular expressions
!
! s/^([^$grpc]*$grpc[$opt$plus$rep]?)//o;
!
! # perl4: compiles w/o error
! # perl5: with Scalar found where operator expected ..., near "$opt$plus"
!
! an added component of this example, apparently from the same script, is
! the actual value of the s'd string after the substitution.
! C<[$opt]> is a character class in perl4 and an array subscript in perl5
!
! $grpc = 'a';
! $opt = 'r';
! $_ = 'bar';
! s/^([^$grpc]*$grpc[$opt]?)/foo/;
! print ;
!
! # perl4 prints: foo
! # perl5 prints: foobar
!
! =item * Regular Expression
!
! Under perl5, C<m?x?> matches only once, like C<?x?>. Under perl4, it matched
! repeatedly, like C</x/> or C<m!x!>.
!
! $test = "once";
! sub match { $test =~ m?once?; }
! &match();
! if( &match() ) {
! # m?x? matches more then once
! print "perl4\n";
! } else {
! # m?x? matches only once
! print "perl5\n";
! }
!
! # perl4 prints: perl4
! # perl5 prints: perl5
! =back
! =head2 Subroutine, Signal, Sorting Traps
! The general group of Perl4-to-Perl5 traps having to do with
! Signals, Sorting, and their related subroutines, as well as
! general subroutine traps. Includes some OS-Specific traps.
! =over 5
! =item * (Signals)
! Barewords that used to look like strings to Perl will now look like subroutine
! calls if a subroutine by that name is defined before the compiler sees them.
+ sub SeeYa { warn"Hasta la vista, baby!" }
+ $SIG{'TERM'} = SeeYa;
+ print "SIGTERM is now $SIG{'TERM'}\n";
+
+ # perl4 prints: SIGTERM is main'SeeYa
+ # perl5 prints: SIGTERM is now main::1
+
+ Use B<-w> to catch this one
+
+ =item * (Sort Subroutine)
+
+ reverse is no longer allowed as the name of a sort subroutine.
+
+ sub reverse{ print "yup "; $a <=> $b }
+ print sort reverse a,b,c;
+
+ # perl4 prints: yup yup yup yup abc
+ # perl5 prints: abc
! =back
! =head2 OS Traps
! =over 5
! =item * (SysV)
! Under HPUX, and some other SysV OS's, one had to reset any signal handler,
! within the signal handler function, each time a signal was handled with
! perl4. With perl5, the reset is now done correctly. Any code relying
! on the handler _not_ being reset will have to be reworked.
!
! 5.002 and beyond uses sigaction() under SysV
!
! sub gotit {
! print "Got @_... ";
! }
! $SIG{'INT'} = 'gotit';
!
! $| = 1;
! $pid = fork;
! if ($pid) {
! kill('INT', $pid);
! sleep(1);
! kill('INT', $pid);
! } else {
! while (1) {sleep(10);}
! }
!
! # perl4 (HPUX) prints: Got INT...
! # perl5 (HPUX) prints: Got INT... Got INT...
!
! =item * (SysV)
!
! Under SysV 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
! for append, it is impossible to overwrite information already in
! the file.
!
! open(TEST,">>seek.test");
! $start = tell TEST ;
! foreach(1 .. 9){
! print TEST "$_ ";
! }
! $end = tell TEST ;
! seek(TEST,$start,0);
! print TEST "18 characters here";
!
! # perl4 (solaris) seek.test has: 18 characters here
! # perl5 (solaris) seek.test has: 1 2 3 4 5 6 7 8 9 18 characters here
! =back
! =head2 Interpolation Traps
! =over 5
! =item * Interpolation
!
! @ now always interpolates an array in double-quotish strings.
!
! print "To: someone@somewhere.com\n";
!
! # perl4 prints: To:someone@somewhere.com
! # perl5 errors : Literal @somewhere now requires backslash
!
! =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$";
! $bar = "bar@";
! print "foo is $foo, bar is $bar\n";
!
! # perl4 prints: foo is foo$, bar is bar@
! # perl5 errors: Final $ should be \$ or $name
!
! Note: perl5 DOES NOT error on the terminating @ in $bar
!
! =item * Interpolation
The construct "this is $$x" used to interpolate the pid at that
! point, but now apparently tries to dereference C<$x>. C<$$> by itself still
works fine, however.
! print "this is $$x\n";
! # perl4 prints: this is XXXx (XXX is the current pid)
! # perl5 prints: this is
!
! =item * Interpolation
!
! Creation of hashes on the fly with C<eval "EXPR"> now requires either both
! C<$>'s to be protected in the specification of the hash name, or both curlies
! to be protected. If both curlies are protected, the result will be compatible
! with perl4 and perl5. This is a very common practice, and should be changed
! to use the block form of C<eval{}> if possible.
! $hashname = "foobar";
! $key = "baz";
! $value = 1234;
! eval "\$$hashname{'$key'} = q|$value|";
! (defined($foobar{'baz'})) ? (print "Yup") : (print "Nope");
!
! # perl4 prints: Yup
! # perl5 prints: Nope
!
! Changing
!
! eval "\$$hashname{'$key'} = q|$value|";
to
! eval "\$\$hashname{'$key'} = q|$value|";
! causes the following result:
! # perl4 prints: Nope
! # perl5 prints: Yup
! or, changing to
! eval "\$$hashname\{'$key'\} = q|$value|";
!
! causes the following result:
!
! # perl4 prints: Yup
! # perl5 prints: Yup
! # and is compatible for both versions
!
!
! =item * Interpolation
!
! perl4 programs which unconsciously rely on the bugs in earlier perl versions.
!
! perl -e '$bar=q/not/; print "This is $foo{$bar} perl5"'
!
! # perl4 prints: This is not perl5
! # perl5 prints: This is perl5
!
! =item * Interpolation
!
! You also have to be careful about array references.
!
! print "$foo{"
!
! perl 4 prints: {
! perl 5 prints: syntax error
!
! =item * Interpolation
!
! Similarly, watch out for:
!
! $foo = "array";
! print "\$$foo{bar}\n";
!
! # perl4 prints: $array{bar}
! # perl5 prints: $
!
! Perl 5 is looking for C<$array{bar}> which doesn't exist, but perl 4 is
! happy just to expand $foo to "array" by itself. Watch out for this
! especially in C<eval>'s.
!
! =item * Interpolation
!
! C<qq()> string passed to C<eval>
!
! eval qq(
! foreach \$y (keys %\$x\) {
! \$count++;
! }
! );
!
! # perl4 runs this ok
! # perl5 prints: Can't find string terminator ")"
! =back
!
! =head2 DBM Traps
!
! General DBM traps.
!
! =over 5
!
! =item * DBM
!
! Existing dbm databases created under perl4 (or any other dbm/ndbm tool)
! may cause the same script, run under perl5, to fail. The build of perl5
! must have been linked with the same dbm/ndbm as the default for C<dbmopen()>
! to function properly without C<tie>'ing to an extension dbm implementation.
!
! dbmopen (%dbm, "file", undef);
! print "ok\n";
!
! # perl4 prints: ok
! # perl5 prints: ok (IFF linked with -ldbm or -lndbm)
!
!
! =item * DBM
!
! Existing dbm databases created under perl4 (or any other dbm/ndbm tool)
! may cause the same script, run under perl5, to fail. The error generated
! when exceeding the limit on the key/value size will cause perl5 to exit
! immediately.
!
! dbmopen(DB, "testdb",0600) || die "couldn't open db! $!";
! $DB{'trap'} = "x" x 1024; # value too large for most dbm/ndbm
! print "YUP\n";
!
! # perl4 prints:
! dbm store returned -1, errno 28, key "trap" at - line 3.
! YUP
!
! # perl5 prints:
! dbm store returned -1, errno 28, key "trap" at - line 3.
=back
+
+ =head2 Unclassified Traps
+
+ Everything else.
+
+ =item * Unclassified
+
+ C<require>/C<do> trap using returned value
+
+ If the file doit.pl has:
+
+ sub foo {
+ $rc = do "./do.pl";
+ return 8;
+ }
+ print &foo, "\n";
+
+ And the do.pl file has the following single line:
+
+ return 3;
+
+ Running doit.pl gives the following:
+
+ # perl 4 prints: 3 (aborts the subroutine early)
+ # perl 5 prints: 8
+
+ Same behavior if you replace C<do> with C<require>.
+
+ =back
+
+ As always, if any of these are ever officially declared as bugs,
+ they'll be fixed and removed.
+
#~ Correct pod formatting
#~ Expand documentation for $. and $|
#~ Correct $# documentation for initial value
#~ Add documentation for $^H
diff -Pcr perl5_003/pod/perlvar.pod perl5_003_01/pod/perlvar.pod
*** perl5_003/pod/perlvar.pod Mon Mar 25 01:05:23 1996
--- perl5_003_01/pod/perlvar.pod Fri Jul 5 17:25:41 1996
***************
*** 102,107 ****
--- 102,111 ----
(Mnemonic: underline is understood in certain operations.)
+ =back
+
+ =over 8
+
=item $<I<digit>>
Contains the subpattern from the corresponding set of parentheses in
***************
*** 176,183 ****
=item $.
! The current input line number of the last filehandle that was read. An
! explicit close on the filehandle resets the line number. Since
"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
--- 180,188 ----
=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
"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
***************
*** 214,225 ****
=item $|
If set to nonzero, forces a flush after every write or print on the
! currently selected output channel. Default is 0. Note that STDOUT
! will typically be line buffered if output is to the terminal and block
! buffered otherwise. Setting this variable is useful primarily when you
! are outputting to a pipe, such as when you are running a Perl script
! under rsh and want to see the output as it's happening. This has no
! effect on input buffering.
(Mnemonic: when you want your pipes to be piping hot.)
=item output_field_separator HANDLE EXPR
--- 219,232 ----
=item $|
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).
! Note that STDOUT will typically be line buffered if output is to the
! terminal and block buffered otherwise. Setting this variable is useful
! primarily when you are outputting to a pipe, such as when you are running
! a Perl script under rsh and want to see the output as it's happening. This
! has no effect on input buffering.
(Mnemonic: when you want your pipes to be piping hot.)
=item output_field_separator HANDLE EXPR
***************
*** 300,308 ****
The output format for printed numbers. This variable is a half-hearted
attempt to emulate B<awk>'s OFMT variable. There are times, however,
when B<awk> and Perl have differing notions of what is in fact
! numeric. Also, the initial value is %.20g rather than %.6g, so you
! need to set "C<$#>" explicitly to get B<awk>'s value. (Mnemonic: # is the
! number sign.)
Use of "C<$#>" is deprecated in Perl 5.
--- 307,316 ----
The output format for printed numbers. This variable is a half-hearted
attempt to emulate B<awk>'s OFMT variable. There are times, however,
when B<awk> and Perl have differing notions of what is in fact
! numeric. The initial value is %.I<n>g, where I<n> is the value
! of the macro DBL_DIG from your system's F<float.h>. This is different from
! B<awk>'s default OFMT setting of %.6g, so you need to set "C<$#>"
! explicitly to get B<awk>'s value. (Mnemonic: # is the number sign.)
Use of "C<$#>" is deprecated in Perl 5.
***************
*** 561,566 ****
--- 569,579 ----
status of a file descriptor will be decided according to the value of
C<$^F> at the time of the open, not the time of the exec.
+ =item $^H
+
+ The current set of syntax checks enabled by C<use strict>. See the
+ documentation of C<strict> for more details.
+
=item $INPLACE_EDIT
=item $^I
***************
*** 569,574 ****
--- 582,588 ----
inplace editing. (Mnemonic: value of B<-i> switch.)
=item $OSNAME
+
=item $^O
The name of the operating system under which this copy of Perl was
***************
*** 621,627 ****
The array @INC contains the list of places to look for Perl scripts to
be evaluated by the C<do EXPR>, C<require>, or C<use> constructs. It
initially consists of the arguments to any B<-I> command line switches,
! followed by the default Perl library, probably "/usr/local/lib/perl",
followed by ".", 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:
--- 635,641 ----
The array @INC contains the list of places to look for Perl scripts to
be evaluated by the C<do EXPR>, C<require>, or C<use> constructs. It
initially consists of the arguments to any B<-I> command line switches,
! followed by the default Perl library, probably F</usr/local/lib/perl>,
followed by ".", to represent the current directory. If you need to
modify this at runtime, you should use the C<use lib> pragma in order
to also get the machine-dependent library properly loaded:
***************
*** 692,695 ****
can die from a __DIE__ handler. Similarly for __WARN__.
=back
-
--- 706,708 ----
#~ Typos and formatting corrected
diff -Pcr perl5_003/pod/perlxs.pod perl5_003_01/pod/perlxs.pod
*** perl5_003/pod/perlxs.pod Mon Mar 25 01:05:24 1996
--- perl5_003_01/pod/perlxs.pod Mon Jul 8 16:37:00 1996
***************
*** 760,767 ****
B<default> case if it is not associated with a conditional. The following
example shows CASE switched via C<ix> with a function C<rpcb_gettime()>
having an alias C<x_gettime()>. When the function is called as
! C<rpcb_gettime()> it's parameters are the usual C<(char *host, time_t *timep)>,
! but when the function is called as C<x_gettime()> is parameters are
reversed, C<(time_t *timep, char *host)>.
long
--- 760,767 ----
B<default> case if it is not associated with a conditional. The following
example shows CASE switched via C<ix> with a function C<rpcb_gettime()>
having an alias C<x_gettime()>. When the function is called as
! C<rpcb_gettime()> its parameters are the usual C<(char *host, time_t *timep)>,
! but when the function is called as C<x_gettime()> its parameters are
reversed, C<(time_t *timep, char *host)>.
long
***************
*** 831,843 ****
Comments are allowed anywhere after the MODULE keyword. The compiler
will pass the preprocessor directives through untouched and will remove
the commented lines.
Comments can be added to XSUBs by placing a C<#> as the first
non-whitespace of a line. Care should be taken to avoid making the
comment look like a C preprocessor directive, lest it be interpreted as
such. The simplest way to prevent this is to put whitespace in front of
the C<#>.
-
If you use preprocessor directives to choose one of two
versions of a function, use
--- 831,843 ----
Comments are allowed anywhere after the MODULE keyword. The compiler
will pass the preprocessor directives through untouched and will remove
the commented lines.
+
Comments can be added to XSUBs by placing a C<#> as the first
non-whitespace of a line. Care should be taken to avoid making the
comment look like a C preprocessor directive, lest it be interpreted as
such. The simplest way to prevent this is to put whitespace in front of
the C<#>.
If you use preprocessor directives to choose one of two
versions of a function, use
***************
*** 1147,1150 ****
=head1 AUTHOR
Dean Roehrich F<E<lt>roehrich@cray.comE<gt>>
! Mar 12, 1996
--- 1147,1150 ----
=head1 AUTHOR
Dean Roehrich F<E<lt>roehrich@cray.comE<gt>>
! Jul 8, 1996
#~ Typos corrected
#~ Reflect change in blib structure at version 5.002
#~ Reflect addition of "use vars" by h2xs
#~ Note that h2xs doesn't scan nested includes
diff -Pcr perl5_003/pod/perlxstut.pod perl5_003_01/pod/perlxstut.pod
*** perl5_003/pod/perlxstut.pod Mon Feb 12 14:59:07 1996
--- perl5_003_01/pod/perlxstut.pod Wed Jul 10 20:36:13 1996
***************
*** 25,30 ****
--- 25,38 ----
=item *
+ In versions of 5.002 prior to the gamma version, the test script in Example
+ 1 will not function properly. You need to change the "use lib" line to
+ read:
+
+ use lib './blib';
+
+ =item *
+
In versions of 5.002 prior to version beta 3, then the line in the .xs file
about "PROTOTYPES: DISABLE" will cause a compiler error. Simply remove that
line from the file.
***************
*** 150,156 ****
printf("Hello, world!\n");
Now we'll run "perl Makefile.PL". This will create a real Makefile,
! which make needs. It's output looks something like:
% perl Makefile.PL
Checking if your kit is complete...
--- 158,164 ----
printf("Hello, world!\n");
Now we'll run "perl Makefile.PL". This will create a real Makefile,
! which make needs. Its output looks something like:
% perl Makefile.PL
Checking if your kit is complete...
***************
*** 178,184 ****
#! /opt/perl5/bin/perl
! use lib './blib';
use Mytest;
--- 186,192 ----
#! /opt/perl5/bin/perl
! use ExtUtils::testlib;
use Mytest;
***************
*** 223,233 ****
file test.pl. This file is set up to imitate the same kind of testing
structure that Perl itself has. Within the test script, you perform a
number of tests to confirm the behavior of the extension, printing "ok"
! when the test is correct, "not ok" when it is not.
!
! Remove the line that starts with "use lib", change the print statement in
! the BEGIN block to print "1..4", and add the following code to the end of
! the file:
print &Mytest::is_even(0) == 1 ? "ok 2" : "not ok 2", "\n";
print &Mytest::is_even(1) == 0 ? "ok 3" : "not ok 3", "\n";
--- 231,239 ----
file test.pl. This file is set up to imitate the same kind of testing
structure that Perl itself has. Within the test script, you perform a
number of tests to confirm the behavior of the extension, printing "ok"
! when the test is correct, "not ok" when it is not. Change the print
! statement in the BEGIN block to print "1..4", and add the following code
! to the end of the file:
print &Mytest::is_even(0) == 1 ? "ok 2" : "not ok 2", "\n";
print &Mytest::is_even(1) == 0 ? "ok 3" : "not ok 3", "\n";
***************
*** 367,375 ****
=head2 WHAT'S NEW HERE?
Two things are new here. First, we've made some changes to Makefile.PL.
! In this case, we've specified an extra library to link in, in this case the
! math library, libm. We'll talk later about how to write XSUBs that can call
! every routine in a library.
Second, the value of the function is being passed back not as the function's
return value, but through the same variable that was passed into the function.
--- 373,381 ----
=head2 WHAT'S NEW HERE?
Two things are new here. First, we've made some changes to Makefile.PL.
! In this case, we've specified an extra library to link in, the math library
! libm. We'll talk later about how to write XSUBs that can call every routine
! in a library.
Second, the value of the function is being passed back not as the function's
return value, but through the same variable that was passed into the function.
***************
*** 441,447 ****
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
pre-existing C routines, which often do modify their input parameters,
! this behavior is tolerated.
=head2 EXAMPLE 4
--- 447,453 ----
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
pre-existing C routines, which often do modify their input parameters,
! this behavior is tolerated. The next example will show how to do this.
=head2 EXAMPLE 4
***************
*** 504,510 ****
We will now create the main top-level Mytest2 files. Change to the directory
above Mytest2 and run the following command:
! % h2xs -O -n Mytest2 < ./Mytest2/mylib/mylib.h
This will print out a warning about overwriting Mytest2, but that's okay.
Our files are stored in Mytest2/mylib, and will be untouched.
--- 510,516 ----
We will now create the main top-level Mytest2 files. Change to the directory
above Mytest2 and run the following command:
! % h2xs -O -n Mytest2 ./Mytest2/mylib/mylib.h
This will print out a warning about overwriting Mytest2, but that's okay.
Our files are stored in Mytest2/mylib, and will be untouched.
***************
*** 537,544 ****
mylib/mylib.h
To keep our namespace nice and unpolluted, edit the .pm file and change
! the line setting @EXPORT to @EXPORT_OK. And finally, in the .xs file,
! edit the #include line to read:
#include "mylib/mylib.h"
--- 543,551 ----
mylib/mylib.h
To keep our namespace nice and unpolluted, edit the .pm file and change
! the lines setting @EXPORT to @EXPORT_OK (there are two: one in the line
! beginning "use vars" and one setting the array itself). Finally, in the
! .xs file, edit the #include line to read:
#include "mylib/mylib.h"
***************
*** 602,607 ****
--- 609,619 ----
mind using the "fully qualified name" of a variable, you could remove most
or all of the items in the @EXPORT array.
+ =item *
+
+ If our include file contained #include directives, these would not be
+ processed at all by h2xs. There is no good solution to this right now.
+
=back
We've also told Perl about the library that we built in the mylib
***************
*** 719,722 ****
=head2 Last Changed
! 1996/2/9
--- 731,734 ----
=head2 Last Changed
! 1996/7/10
#~ Correct typo in STDERR
#~ Remove .pm as well as .pod suffix from input filename
#~ Drop erroneous double quotes around function parameter
#~ Convert characters with high bit set to HTML escapes
diff -Pcr perl5_003/pod/pod2html.PL perl5_003_01/pod/pod2html.PL
*** perl5_003/pod/pod2html.PL Mon Mar 25 01:05:24 1996
--- perl5_003_01/pod/pod2html.PL Mon Jul 8 09:33:52 1996
***************
*** 98,106 ****
# loop twice through the pods, first to learn the links, then to produce html
for $count (0,1) {
! print STTDER "Scanning pods...\n" unless $count;
foreach $podfh ( @Pods ) {
! ($pod = $podfh) =~ s/\.pod$//;
Debug("files", "opening 2 $podfh" );
print "Creating $pod.html from $podfh\n" if $count;
$RS = "\n="; # grok pods by item (Nonstandard but effecient)
--- 98,106 ----
# loop twice through the pods, first to learn the links, then to produce html
for $count (0,1) {
! print STDERR "Scanning pods...\n" unless $count;
foreach $podfh ( @Pods ) {
! ($pod = $podfh) =~ s/\.(?:pod|pm)$//;
Debug("files", "opening 2 $podfh" );
print "Creating $pod.html from $podfh\n" if $count;
$RS = "\n="; # grok pods by item (Nonstandard but effecient)
***************
*** 151,157 ****
if ($count) { # producing html
($depth) or next; # just skip it
do_list("back",$all[$i+1],\$in_list,\$depth);
! do_rest("$title.$rest");
}
}
elsif ($cmd =~ /^cut/) {
--- 151,157 ----
if ($count) { # producing html
($depth) or next; # just skip it
do_list("back",$all[$i+1],\$in_list,\$depth);
! do_rest($title.$rest);
}
}
elsif ($cmd =~ /^cut/) {
***************
*** 161,167 ****
if ($count) { # producing html
if ($title =~ s/^html//) {
$in_html =1;
! do_rest("$title.$rest");
}
}
}
--- 161,167 ----
if ($count) { # producing html
if ($title =~ s/^html//) {
$in_html =1;
! do_rest($title.$rest);
}
}
}
***************
*** 501,506 ****
--- 501,507 ----
sub pre_escapes { # twiddle these, and stay up late :-)
my($thing) = @_;
for ($$thing) {
+ s/([\200-\377])/noremap("&".ord($1).";")/ge;
s/"(.*?)"/``$1''/gs;
s/&/noremap("&")/ge;
s/<</noremap("<<")/eg;
#~ Handle characters with high bit set
diff -Pcr perl5_003/pod/pod2latex.PL perl5_003_01/pod/pod2latex.PL
*** perl5_003/pod/pod2latex.PL Mon Mar 25 01:05:27 1996
--- perl5_003_01/pod/pod2latex.PL Thu Jul 4 14:50:18 1996
***************
*** 500,508 ****
}
sub init_noremap {
! if ( /[\200-\377]/ ) {
! warn "hit bit char in input stream";
! }
}
sub clear_noremap {
--- 500,507 ----
}
sub init_noremap {
! # escape high bit characters in input stream
! s/([\200-\377])/"E<".ord($1).">"/ge;
}
sub clear_noremap {
***************
*** 513,523 ****
sub expand_HTML_escapes {
local($s) = $_[0];
! $s =~ s { E<([A-Za-z]+)> }
{
do {
! exists $HTML_Escapes{$1}
! ? do { $HTML_Escapes{$1} }
: do {
warn "Unknown escape: $& in $_";
"E<$1>";
--- 512,525 ----
sub expand_HTML_escapes {
local($s) = $_[0];
! $s =~ s { E<((\d+)|([A-Za-z]+))> }
{
do {
! defined($2)
! ? do { chr($2) }
! :
! exists $HTML_Escapes{$3}
! ? do { $HTML_Escapes{$3} }
: do {
warn "Unknown escape: $& in $_";
"E<$1>";
#~ Handle characters with high bit set
#~ Don't try to find local Perl via PATH on Plan9
diff -Pcr perl5_003/pod/pod2man.PL perl5_003_01/pod/pod2man.PL
*** perl5_003/pod/pod2man.PL Mon Mar 25 01:05:27 1996
--- perl5_003_01/pod/pod2man.PL Mon Jul 29 19:59:57 1996
***************
*** 225,236 ****
(F) The input file wasn't available for the given reason.
- =item high bit char in input stream
-
- (W) You can't use high-bit characters in the input stream,
- because the translator uses them for its own nefarious purposes.
- Use an HTML entity in angle brackets instead.
-
=item Improper man page - no dash in NAME header in paragraph %d of %s
(W) The NAME header did not have an isolated dash in it. This is
--- 225,230 ----
***************
*** 292,299 ****
=head1 RESTRICTIONS
! You shouldn't use 8-bit characters in the input stream, as these
! will be used by the translator.
=head1 BUGS
--- 286,292 ----
=head1 RESTRICTIONS
! None at this time.
=head1 BUGS
***************
*** 311,317 ****
$/ = "";
$cutting = 1;
! ($version,$patch) = `\PATH=.:..:\$PATH; perl -v` =~ /version (\d\.\d{3}(?: +)(?:\S+)?)(?:.*patchlevel (\d\S*))?/s;
$DEF_RELEASE = "perl $version";
$DEF_RELEASE .= ", patch $patch" if $patch;
--- 304,318 ----
$/ = "";
$cutting = 1;
! # We try first to get the version number from a local binary, in case we're
! # running an installed version of Perl to produce documentation from an
! # uninstalled newer version's pod files.
! if ($^O ne 'plan9') {
! ($version,$patch) =
! `\PATH=.:..:\$PATH; perl -v` =~ /version (\d\.\d{3})(?:_(\d{2}))?/;
! }
! # No luck; we'll just go with the running Perl's version
! ($version,$patch) = $] =~ /^(.{5})(\d{2})?/ unless $version;
$DEF_RELEASE = "perl $version";
$DEF_RELEASE .= ", patch $patch" if $patch;
***************
*** 952,960 ****
}
sub init_noremap {
! if ( /[\200-\377]/ ) {
! warn "$0: high bit char in input stream in paragraph $. of $ARGV\n";
! }
}
sub clear_noremap {
--- 953,960 ----
}
sub init_noremap {
! # escape high bit characters in input stream
! s/([\200-\377])/"E<".ord($1).">"/ge;
}
sub clear_noremap {
***************
*** 969,981 ****
# otherwise the interative \w<> processing would have
# been hosed by the E<gt>
s {
! E<
! ( [A-Za-z]+ )
>
} {
! do {
! exists $HTML_Escapes{$1}
! ? do { $HTML_Escapes{$1} }
: do {
warn "$0: Unknown escape in paragraph $. of $ARGV: ``$&''\n";
"E<$1>";
--- 969,987 ----
# otherwise the interative \w<> processing would have
# been hosed by the E<gt>
s {
! E<
! (
! ( \d + )
! | ( [A-Za-z]+ )
! )
>
} {
! do {
! defined $2
! ? chr($2)
! :
! exists $HTML_Escapes{$3}
! ? do { $HTML_Escapes{$3} }
: do {
warn "$0: Unknown escape in paragraph $. of $ARGV: ``$&''\n";
"E<$1>";
#~ Add cast for new GV type
#~ Check for magic SV in pp_ref()
#~ Use more complex default seed in pp_srand(), but skip bits on Plan9
#~ which give its cc/asm a headache
#~ Reflect new HV management
#~ Make SV created to hold result of unpack('u',...) a valid string
#~ Rename global variable to eliminate collision with system header files
diff -Pcr perl5_003/pp.c perl5_003_01/pp.c
*** perl5_003/pp.c Fri Feb 23 22:07:37 1996
--- perl5_003_01/pp.c Wed Jul 17 11:48:22 1996
***************
*** 141,147 ****
GvREFCNT(sv) = 1;
GvSV(sv) = NEWSV(72,0);
GvLINE(sv) = curcop->cop_line;
! GvEGV(sv) = sv;
}
}
SETs(sv);
--- 141,147 ----
GvREFCNT(sv) = 1;
GvSV(sv) = NEWSV(72,0);
GvLINE(sv) = curcop->cop_line;
! GvEGV(sv) = (GV*)sv;
}
}
SETs(sv);
***************
*** 163,169 ****
}
}
else {
! GV *gv = sv;
char *sym;
if (SvTYPE(gv) != SVt_PVGV) {
--- 163,169 ----
}
}
else {
! GV *gv = (GV*)sv;
char *sym;
if (SvTYPE(gv) != SVt_PVGV) {
***************
*** 181,187 ****
sym = SvPV(sv, na);
if (op->op_private & HINT_STRICT_REFS)
DIE(no_symref, sym, "a SCALAR");
! gv = (SV*)gv_fetchpv(sym, TRUE, SVt_PV);
}
sv = GvSV(gv);
}
--- 181,187 ----
sym = SvPV(sv, na);
if (op->op_private & HINT_STRICT_REFS)
DIE(no_symref, sym, "a SCALAR");
! gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PV);
}
sv = GvSV(gv);
}
***************
*** 331,336 ****
--- 331,340 ----
char *pv;
sv = POPs;
+
+ if (sv && SvGMAGICAL(sv))
+ mg_get(sv);
+
if (!sv || !SvROK(sv))
RETPUSHNO;
***************
*** 1232,1242 ****
{
dSP;
I32 anum;
- Time_t when;
if (MAXARG < 1) {
(void)time(&when);
anum = when;
}
else
anum = POPi;
--- 1236,1266 ----
{
dSP;
I32 anum;
if (MAXARG < 1) {
+ #ifdef VMS
+ # include <starlet.h>
+ unsigned int when[2];
+ _ckvmssts(sys$gettim(when));
+ anum = when[0] ^ when[1];
+ #else
+ # if defined(I_SYS_TIME) && !defined(PLAN9)
+ struct timeval when;
+ gettimeofday(&when,(struct timezone *) 0);
+ anum = when.tv_sec ^ when.tv_usec;
+ # else
+ Time_t when;
(void)time(&when);
anum = when;
+ # endif
+ #endif
+ #if !defined(PLAN9) /* XXX Plan9 assembler chokes on this; fix coming soon */
+ /* 17-Jul-1996 bailey@genetics.upenn.edu */
+ /* What is a good hashing algorithm here? */
+ anum ^= ( ( 269 * (U32)getpid())
+ ^ (26107 * (U32)&when)
+ ^ (73819 * (U32)stack_sp));
+ #endif
}
else
anum = POPi;
***************
*** 1789,1796 ****
dSP; dTARGET;
HV *hash = (HV*)POPs;
HE *entry;
- I32 i;
- char *tmps;
PUTBACK;
entry = hv_iternext(hash); /* might clobber stack_sp */
--- 1813,1818 ----
***************
*** 1798,1807 ****
EXTEND(SP, 2);
if (entry) {
! tmps = hv_iterkey(entry, &i); /* won't clobber stack_sp */
! if (!i)
! tmps = "";
! PUSHs(sv_2mortal(newSVpv(tmps, i)));
if (GIMME == G_ARRAY) {
PUTBACK;
sv_setsv(TARG, hv_iterval(hash, entry)); /* might clobber stack_sp */
--- 1820,1826 ----
EXTEND(SP, 2);
if (entry) {
! PUSHs(hv_iterkeysv(entry)); /* won't clobber stack_sp */
if (GIMME == G_ARRAY) {
PUTBACK;
sv_setsv(TARG, hv_iterval(hash, entry)); /* might clobber stack_sp */
***************
*** 1831,1844 ****
SV *sv;
SV *tmpsv = POPs;
HV *hv = (HV*)POPs;
- char *tmps;
STRLEN len;
if (SvTYPE(hv) != SVt_PVHV) {
DIE("Not a HASH reference");
}
! tmps = SvPV(tmpsv, len);
! sv = hv_delete(hv, tmps, len,
! op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0);
if (!sv)
RETPUSHUNDEF;
PUSHs(sv);
--- 1850,1861 ----
SV *sv;
SV *tmpsv = POPs;
HV *hv = (HV*)POPs;
STRLEN len;
if (SvTYPE(hv) != SVt_PVHV) {
DIE("Not a HASH reference");
}
! sv = hv_delete_ent(hv, tmpsv,
! (op->op_private & OPpLEAVE_VOID ? G_DISCARD : 0), 0);
if (!sv)
RETPUSHUNDEF;
PUSHs(sv);
***************
*** 1850,1862 ****
dSP;
SV *tmpsv = POPs;
HV *hv = (HV*)POPs;
- char *tmps;
STRLEN len;
if (SvTYPE(hv) != SVt_PVHV) {
DIE("Not a HASH reference");
}
! tmps = SvPV(tmpsv, len);
! if (hv_exists(hv, tmps, len))
RETPUSHYES;
RETPUSHNO;
}
--- 1867,1877 ----
dSP;
SV *tmpsv = POPs;
HV *hv = (HV*)POPs;
STRLEN len;
if (SvTYPE(hv) != SVt_PVHV) {
DIE("Not a HASH reference");
}
! if (hv_exists_ent(hv, tmpsv, 0))
RETPUSHYES;
RETPUSHNO;
}
***************
*** 1864,1886 ****
PP(pp_hslice)
{
dSP; dMARK; dORIGMARK;
! register SV **svp;
register HV *hv = (HV*)POPs;
register I32 lval = op->op_flags & OPf_MOD;
if (SvTYPE(hv) == SVt_PVHV) {
while (++MARK <= SP) {
! STRLEN keylen;
! char *key = SvPV(*MARK, keylen);
! svp = hv_fetch(hv, key, keylen, lval);
if (lval) {
! if (!svp || *svp == &sv_undef)
! DIE(no_helem, key);
if (op->op_private & OPpLVAL_INTRO)
! save_svref(svp);
}
! *MARK = svp ? *svp : &sv_undef;
}
}
if (GIMME != G_ARRAY) {
--- 1879,1900 ----
PP(pp_hslice)
{
dSP; dMARK; dORIGMARK;
! register HE *he;
register HV *hv = (HV*)POPs;
register I32 lval = op->op_flags & OPf_MOD;
if (SvTYPE(hv) == SVt_PVHV) {
while (++MARK <= SP) {
! SV *keysv = *MARK;
! he = hv_fetch_ent(hv, keysv, lval, 0);
if (lval) {
! if (!he || HeVAL(he) == &sv_undef)
! DIE(no_helem, SvPV(keysv, na));
if (op->op_private & OPpLVAL_INTRO)
! save_svref(&HeVAL(he));
}
! *MARK = he ? HeVAL(he) : &sv_undef;
}
}
if (GIMME != G_ARRAY) {
***************
*** 1981,1994 ****
while (MARK < SP) {
SV* key = *++MARK;
- char *tmps;
SV *val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
else
warn("Odd number of elements in hash list");
! tmps = SvPV(key,len);
! (void)hv_store(hv,tmps,len,val,0);
}
SP = ORIGMARK;
XPUSHs((SV*)hv);
--- 1995,2006 ----
while (MARK < SP) {
SV* key = *++MARK;
SV *val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
else
warn("Odd number of elements in hash list");
! (void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
XPUSHs((SV*)hv);
***************
*** 2829,2834 ****
--- 2841,2848 ----
case 'u':
along = (strend - s) * 3 / 4;
sv = NEWSV(42, along);
+ if (along)
+ SvPOK_on(sv);
while (s < strend && *s > ' ' && *s < 'a') {
I32 a, b, c, d;
char hunk[4];
***************
*** 3324,3330 ****
I32 origlimit = limit;
I32 realarray = 0;
I32 base;
! AV *oldstack = stack;
register REGEXP *rx = pm->op_pmregexp;
I32 gimme = GIMME;
I32 oldsave = savestack_ix;
--- 3338,3344 ----
I32 origlimit = limit;
I32 realarray = 0;
I32 base;
! AV *oldstack = curstack;
register REGEXP *rx = pm->op_pmregexp;
I32 gimme = GIMME;
I32 oldsave = savestack_ix;
***************
*** 3347,3353 ****
av_extend(ary,0);
av_clear(ary);
/* temporarily switch stacks */
! SWITCHSTACK(stack, ary);
}
base = SP - stack_base;
orig = s;
--- 3361,3367 ----
av_extend(ary,0);
av_clear(ary);
/* temporarily switch stacks */
! SWITCHSTACK(curstack, ary);
}
base = SP - stack_base;
orig = s;
#~ Revise SETsv() and tryAMAGICun() macros
#~ Rename global symbol to eliminate collision with system header files
diff -Pcr perl5_003/pp.h perl5_003_01/pp.h
*** perl5_003/pp.h Mon Mar 25 01:05:28 1996
--- perl5_003_01/pp.h Fri Jul 5 15:31:26 1996
***************
*** 93,102 ****
#define SETn(n) STMT_START { sv_setnv(TARG, (double)(n)); SETTARG; } STMT_END
#define SETi(i) STMT_START { sv_setiv(TARG, (IV)(i)); SETTARG; } STMT_END
- #ifdef OVERLOAD
- #define SETsv(sv) STMT_START { sv_setsv(TARG, (sv)); SETTARG; } STMT_END
- #endif /* OVERLOAD */
-
#define dTOPss SV *sv = TOPs
#define dPOPss SV *sv = POPs
#define dTOPnv double value = TOPn
--- 93,98 ----
***************
*** 127,133 ****
stack_base = AvARRAY(t); \
stack_max = stack_base + AvMAX(t); \
sp = stack_sp = stack_base + AvFILL(t); \
! stack = t;
#ifdef OVERLOAD
--- 123,129 ----
stack_base = AvARRAY(t); \
stack_max = stack_base + AvMAX(t); \
sp = stack_sp = stack_base + AvFILL(t); \
! curstack = t;
#ifdef OVERLOAD
***************
*** 169,178 ****
} \
} STMT_END
! #define tryAMAGICun(meth) tryAMAGICunW(meth,SETsv)
#define tryAMAGICunSET(meth) tryAMAGICunW(meth,SETs)
#define opASSIGN (op->op_flags & OPf_STACKED)
/* newSVsv does not behave as advertised, so we copy missing
* information by hand */
--- 165,177 ----
} \
} STMT_END
! #define tryAMAGICun tryAMAGICunSET
#define tryAMAGICunSET(meth) tryAMAGICunW(meth,SETs)
#define opASSIGN (op->op_flags & OPf_STACKED)
+ #define SETsv(sv) STMT_START { \
+ if (opASSIGN) { sv_setsv(TARG, (sv)); SETTARG; } \
+ else SETs(sv); } STMT_END
/* newSVsv does not behave as advertised, so we copy missing
* information by hand */
#~ Rename global variable to eliminate collision with system header files
#~ Allow redurection of debug messages
#~ Make sure the right stack is in use in die()
#~ Correct juggling of stack and @_ in pp_goto()
#~ Get more information about XSUBs to debugger
#~ Preserve SP around eval
#~ Propagate G_KEEPERR down into eval
#~ Don't worry about %INC if we're not in a "require"
diff -Pcr perl5_003/pp_ctl.c perl5_003_01/pp_ctl.c
*** perl5_003/pp_ctl.c Mon Mar 25 01:05:31 1996
--- perl5_003_01/pp_ctl.c Mon Jul 15 13:41:09 1996
***************
*** 621,633 ****
SAVETMPS;
SAVESPTR(op);
! oldstack = stack;
if (!sortstack) {
sortstack = newAV();
AvREAL_off(sortstack);
av_extend(sortstack, 32);
}
! SWITCHSTACK(stack, sortstack);
if (sortstash != stash) {
firstgv = gv_fetchpv("a", TRUE, SVt_PV);
secondgv = gv_fetchpv("b", TRUE, SVt_PV);
--- 621,633 ----
SAVETMPS;
SAVESPTR(op);
! oldstack = curstack;
if (!sortstack) {
sortstack = newAV();
AvREAL_off(sortstack);
av_extend(sortstack, 32);
}
! SWITCHSTACK(curstack, sortstack);
if (sortstash != stash) {
firstgv = gv_fetchpv("a", TRUE, SVt_PV);
secondgv = gv_fetchpv("b", TRUE, SVt_PV);
***************
*** 881,887 ****
while (cxstack_ix > cxix) {
cx = &cxstack[cxstack_ix--];
! DEBUG_l(fprintf(stderr, "Unwinding block %ld, type %s\n", (long) cxstack_ix+1,
block_type[cx->cx_type]));
/* Note: we don't need to restore the base context info till the end. */
switch (cx->cx_type) {
--- 881,887 ----
while (cxstack_ix > cxix) {
cx = &cxstack[cxstack_ix--];
! DEBUG_l(fprintf(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) {
***************
*** 919,924 ****
--- 919,931 ----
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
***************
*** 1308,1315 ****
cx->blk_loop.iterix = -1;
}
else {
! cx->blk_loop.iterary = stack;
! AvFILL(stack) = sp - stack_base;
cx->blk_loop.iterix = MARK - stack_base;
}
--- 1315,1322 ----
cx->blk_loop.iterix = -1;
}
else {
! cx->blk_loop.iterary = curstack;
! AvFILL(curstack) = sp - stack_base;
cx->blk_loop.iterix = MARK - stack_base;
}
***************
*** 1376,1386 ****
PMOP *newpm;
I32 optype = 0;
! if (stack == sortstack) {
if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) {
if (cxstack_ix > sortcxix)
dounwind(sortcxix);
! AvARRAY(stack)[1] = *SP;
stack_sp = stack_base + 1;
return 0;
}
--- 1383,1393 ----
PMOP *newpm;
I32 optype = 0;
! if (curstack == sortstack) {
if (cxstack_ix == sortcxix || dopoptosub(cxstack_ix) < sortcxix) {
if (cxstack_ix > sortcxix)
dounwind(sortcxix);
! AvARRAY(curstack)[1] = *SP;
stack_sp = stack_base + 1;
return 0;
}
***************
*** 1634,1640 ****
AV* av = cx->blk_sub.argarray;
items = AvFILL(av) + 1;
! Copy(AvARRAY(av), ++stack_sp, items, SV*);
stack_sp += items;
GvAV(defgv) = cx->blk_sub.savearray;
AvREAL_off(av);
--- 1641,1649 ----
AV* av = cx->blk_sub.argarray;
items = AvFILL(av) + 1;
! stack_sp++;
! EXTEND(stack_sp, items); /* @_ could have been extended. */
! Copy(AvARRAY(av), stack_sp, items, SV*);
stack_sp += items;
GvAV(defgv) = cx->blk_sub.savearray;
AvREAL_off(av);
***************
*** 1661,1666 ****
--- 1670,1676 ----
sp = stack_base + items;
}
else {
+ stack_sp--; /* There is no cv arg. */
(void)(*CvXSUB(cv))(cv);
}
LEAVE;
***************
*** 1750,1755 ****
--- 1760,1772 ----
mark++;
}
}
+ 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. */
+ }
RETURNOP(CvSTART(cv));
}
}
***************
*** 1843,1849 ****
do_undump = FALSE;
}
! if (stack == signalstack) {
restartop = retop;
Siglongjmp(top_env, 3);
}
--- 1860,1866 ----
do_undump = FALSE;
}
! if (curstack == signalstack) {
restartop = retop;
Siglongjmp(top_env, 3);
}
***************
*** 1944,1949 ****
--- 1961,1968 ----
in_eval = 1;
+ PUSHMARK(SP);
+
/* set up a scratch pad */
SAVEINT(padix);
***************
*** 1992,1998 ****
curcop->cop_arybase = 0;
SvREFCNT_dec(rs);
rs = newSVpv("\n", 1);
! sv_setpv(GvSV(errgv),"");
if (yyparse() || error_count || !eval_root) {
SV **newsp;
I32 gimme;
--- 2011,2020 ----
curcop->cop_arybase = 0;
SvREFCNT_dec(rs);
rs = newSVpv("\n", 1);
! if (saveop->op_flags & OPf_SPECIAL)
! in_eval |= 4;
! else
! sv_setpv(GvSV(errgv),"");
if (yyparse() || error_count || !eval_root) {
SV **newsp;
I32 gimme;
***************
*** 2004,2009 ****
--- 2026,2032 ----
op_free(eval_root);
eval_root = Nullop;
}
+ SP = stack_base + POPMARK; /* pop original mark */
POPBLOCK(cx,curpm);
POPEVAL(cx);
pop_return();
***************
*** 2028,2033 ****
--- 2051,2057 ----
/* compiled okay, so do it */
+ SP = stack_base + POPMARK; /* pop original mark */
RETURNOP(eval_start);
}
***************
*** 2201,2206 ****
--- 2225,2231 ----
I32 gimme;
register CONTEXT *cx;
OP *retop;
+ OP *saveop = op;
I32 optype;
POPBLOCK(cx,newpm);
***************
*** 2233,2253 ****
}
curpm = newpm; /* Don't pop $1 et al till now */
! if (optype != OP_ENTEREVAL) {
char *name = cx->blk_eval.old_name;
! if (!(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
! /* Unassume the success we assumed earlier. */
! (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
!
! if (optype == OP_REQUIRE)
! retop = die("%s did not return a true value", name);
! }
}
lex_end();
LEAVE;
! sv_setpv(GvSV(errgv),"");
RETURNOP(retop);
}
--- 2258,2276 ----
}
curpm = newpm; /* Don't pop $1 et al till now */
! if (optype == OP_REQUIRE &&
! !(gimme == G_SCALAR ? SvTRUE(*sp) : sp > newsp)) {
char *name = cx->blk_eval.old_name;
! /* Unassume the success we assumed earlier. */
! (void)hv_delete(GvHVn(incgv), name, strlen(name), G_DISCARD);
! retop = die("%s did not return a true value", name);
}
lex_end();
LEAVE;
! if (!(saveop->op_flags & OPf_SPECIAL))
! sv_setpv(GvSV(errgv),"");
RETURNOP(retop);
}
#~ Use new GV type explicitly
#~ Update processing of glob expansion under OS/2
#~ Rename global variable to eliminate collision with system headers
#~ Give debugger more information about XSUBs
#~ Pass @_ through properly to nested XSUB call
#~ Improve efficiency of method lookup
diff -Pcr perl5_003/pp_hot.c perl5_003_01/pp_hot.c
*** perl5_003/pp_hot.c Mon Mar 25 01:05:32 1996
--- perl5_003_01/pp_hot.c Thu Jul 4 14:49:07 1996
***************
*** 414,419 ****
--- 414,421 ----
}
}
else {
+ GV *gv;
+
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
***************
*** 433,443 ****
sym = SvPV(sv,na);
if (op->op_private & HINT_STRICT_REFS)
DIE(no_symref, sym, "an ARRAY");
! sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
}
! av = GvAVn(sv);
if (op->op_private & OPpLVAL_INTRO)
! av = save_ary(sv);
if (op->op_flags & OPf_REF) {
PUSHs((SV*)av);
RETURN;
--- 435,447 ----
sym = SvPV(sv,na);
if (op->op_private & HINT_STRICT_REFS)
DIE(no_symref, sym, "an ARRAY");
! gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
! } else {
! gv = (GV*)sv;
}
! av = GvAVn(gv);
if (op->op_private & OPpLVAL_INTRO)
! av = save_ary(gv);
if (op->op_flags & OPf_REF) {
PUSHs((SV*)av);
RETURN;
***************
*** 487,492 ****
--- 491,498 ----
}
}
else {
+ GV *gv;
+
if (SvTYPE(sv) != SVt_PVGV) {
char *sym;
***************
*** 508,518 ****
sym = SvPV(sv,na);
if (op->op_private & HINT_STRICT_REFS)
DIE(no_symref, sym, "a HASH");
! sv = (SV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
}
! hv = GvHVn(sv);
if (op->op_private & OPpLVAL_INTRO)
! hv = save_hash(sv);
if (op->op_flags & OPf_REF) {
SETs((SV*)hv);
RETURN;
--- 514,526 ----
sym = SvPV(sv,na);
if (op->op_private & HINT_STRICT_REFS)
DIE(no_symref, sym, "a HASH");
! gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
! } else {
! gv = (GV*)sv;
}
! hv = GvHVn(gv);
if (op->op_private & OPpLVAL_INTRO)
! hv = save_hash(gv);
if (op->op_flags & OPf_REF) {
SETs((SV*)hv);
RETURN;
***************
*** 1045,1055 ****
}
#else /* !VMS */
#ifdef DOSISH
sv_setpv(tmpcmd, "perlglob ");
sv_catsv(tmpcmd, tmpglob);
sv_catpv(tmpcmd, " |");
! #else
! #ifdef CSH
sv_setpvn(tmpcmd, cshname, cshlen);
sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
sv_catsv(tmpcmd, tmpglob);
--- 1053,1069 ----
}
#else /* !VMS */
#ifdef DOSISH
+ #ifdef OS2
+ sv_setpv(tmpcmd, "for a in ");
+ sv_catsv(tmpcmd, tmpglob);
+ sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
+ #else
sv_setpv(tmpcmd, "perlglob ");
sv_catsv(tmpcmd, tmpglob);
sv_catpv(tmpcmd, " |");
! #endif /* !OS2 */
! #else /* !DOSISH */
! #if defined(CSH)
sv_setpvn(tmpcmd, cshname, cshlen);
sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
sv_catsv(tmpcmd, tmpglob);
***************
*** 1063,1069 ****
sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
#endif
#endif /* !CSH */
! #endif /* !MSDOS */
(void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
FALSE, 0, 0, Nullfp);
fp = IoIFP(io);
--- 1077,1083 ----
sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
#endif
#endif /* !CSH */
! #endif /* !DOSISH */
(void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
FALSE, 0, 0, Nullfp);
fp = IoIFP(io);
***************
*** 1278,1284 ****
if (cx->cx_type != CXt_LOOP)
DIE("panic: pp_iter");
av = cx->blk_loop.iterary;
! if (av == stack && cx->blk_loop.iterix >= cx->blk_oldsp)
RETPUSHNO;
if (cx->blk_loop.iterix >= AvFILL(av))
--- 1292,1298 ----
if (cx->cx_type != CXt_LOOP)
DIE("panic: pp_iter");
av = cx->blk_loop.iterary;
! if (av == curstack && cx->blk_loop.iterix >= cx->blk_oldsp)
RETPUSHNO;
if (cx->blk_loop.iterix >= AvFILL(av))
***************
*** 1647,1652 ****
--- 1661,1667 ----
register CV *cv;
register CONTEXT *cx;
I32 gimme;
+ I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
if (!sv)
DIE("Not a CODE reference");
***************
*** 1717,1734 ****
}
gimme = GIMME;
! if ((op->op_private & OPpENTERSUB_DB) && !CvXSUB(cv)) {
sv = GvSV(DBsub);
save_item(sv);
! if (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) {
/* GV is potentially non-unique */
sv_setsv(sv, newRV((SV*)cv));
}
else {
- gv = CvGV(cv);
gv_efullname(sv,gv);
}
cv = GvCV(DBsub);
if (!cv)
DIE("No DBsub routine");
}
--- 1732,1751 ----
}
gimme = GIMME;
! if ((op->op_private & OPpENTERSUB_DB)) {
sv = GvSV(DBsub);
save_item(sv);
! gv = CvGV(cv);
! if ( CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)
! || strEQ(GvNAME(gv), "END") ) {
/* GV is potentially non-unique */
sv_setsv(sv, newRV((SV*)cv));
}
else {
gv_efullname(sv,gv);
}
cv = GvCV(DBsub);
+ if (CvXSUB(cv)) curcopdb = curcop;
if (!cv)
DIE("No DBsub routine");
}
***************
*** 1738,1743 ****
--- 1755,1761 ----
I32 (*fp3)_((int,int,int));
dMARK;
register I32 items = SP - MARK;
+ /* We dont worry to copy from @_. */
while (sp > mark) {
sp[1] = sp[0];
sp--;
***************
*** 1753,1758 ****
--- 1771,1800 ----
I32 markix = TOPMARK;
PUTBACK;
+
+ if (!hasargs) {
+ /* Need to copy @_ to stack. Alternative may be to
+ * switch stack to @_, and copy return values
+ * back. This would allow popping @_ in XSUB, e.g.. XXXX */
+ AV* av = GvAV(defgv);
+ I32 items = AvFILL(av) + 1;
+
+ if (items) {
+ /* Mark is at the end of the stack. */
+ EXTEND(sp, items);
+ Copy(AvARRAY(av), sp + 1, items, SV*);
+ sp += items;
+ PUTBACK ;
+ }
+ }
+ if (curcopdb) { /* We assume that the first
+ XSUB in &DB::sub is the
+ called one. */
+ SAVESPTR(curcop);
+ curcop = curcopdb;
+ curcopdb = NULL;
+ }
+ /* Do we need to open block here? XXXX */
(void)(*CvXSUB(cv))(cv);
/* Enforce some sanity in scalar context. */
***************
*** 1770,1776 ****
else {
dMARK;
register I32 items = SP - MARK;
- I32 hasargs = (op->op_flags & OPf_STACKED) != 0;
AV* padlist = CvPADLIST(cv);
SV** svp = AvARRAY(padlist);
push_return(op->op_next);
--- 1812,1817 ----
***************
*** 1922,1930 ****
else {
GV* iogv;
char* packname = 0;
if (!SvOK(sv) ||
! !(packname = SvPV(sv, na)) ||
!(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
--- 1963,1972 ----
else {
GV* iogv;
char* packname = 0;
+ STRLEN packlen;
if (!SvOK(sv) ||
! !(packname = SvPV(sv, packlen)) ||
!(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
***************
*** 1932,1940 ****
HV *stash;
if (!packname || !isALPHA(*packname))
DIE("Can't call method \"%s\" without a package or object reference", name);
! if (!(stash = gv_stashpv(packname, FALSE))) {
! if (gv_stashpv("UNIVERSAL", FALSE))
! stash = gv_stashpv(packname, TRUE);
else
DIE("Can't call method \"%s\" in empty package \"%s\"",
name, packname);
--- 1974,1982 ----
HV *stash;
if (!packname || !isALPHA(*packname))
DIE("Can't call method \"%s\" without a package or object reference", name);
! if (!(stash = gv_stashpvn(packname, packlen, FALSE))) {
! if (gv_stashpvn("UNIVERSAL", 9, FALSE))
! stash = gv_stashpvn(packname, packlen, TRUE);
else
DIE("Can't call method \"%s\" in empty package \"%s\"",
name, packname);
***************
*** 1943,1952 ****
if (!gv)
DIE("Can't locate object method \"%s\" via package \"%s\"",
name, packname);
! SETs(gv);
RETURN;
}
! *(stack_base + TOPMARK + 1) = sv_2mortal(newRV(iogv));
}
if (!ob || !SvOBJECT(ob)) {
--- 1985,1994 ----
if (!gv)
DIE("Can't locate object method \"%s\" via package \"%s\"",
name, packname);
! SETs((SV*)gv);
RETURN;
}
! *(stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
}
if (!ob || !SvOBJECT(ob)) {
***************
*** 1962,1968 ****
name, HvNAME(SvSTASH(ob)));
}
! SETs(gv);
RETURN;
}
--- 2004,2010 ----
name, HvNAME(SvSTASH(ob)));
}
! SETs((SV*)gv);
RETURN;
}
#~ Use home-grown name for chsize() to avoid possible collision with
#~ function which exists in system libraries but isn't used
#~ Support home-grown analogue to binmode()
#~ Give debugger access to function call executing "tie" and "dbmopen"
#~ Implement strict untie
#~ Add casts to reflect new GV type
#~ Allow redirection of debug messages
#~ Fix handling of file truncation
#~ Handle missing rdev field in struct stat
#~ Handle 64-bit time values
diff -Pcr perl5_003/pp_sys.c perl5_003_01/pp_sys.c
*** perl5_003/pp_sys.c Mon Mar 25 01:05:32 1996
--- perl5_003_01/pp_sys.c Fri Jul 26 09:32:41 1996
***************
*** 89,94 ****
--- 89,99 ----
#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
static int dooneliner _((char *cmd, char *filename));
#endif
+
+ #ifdef HAS_CHSIZE
+ # define my_chsize chsize
+ #endif
+
/* Pushy I/O. */
PP(pp_backtick)
***************
*** 376,383 ****
--- 381,396 ----
RETPUSHUNDEF;
#endif
#else
+ #if defined(USEMYBINMODE)
+ if (my_binmode(fp,IoTYPE(io)) != NULL)
+ RETPUSHYES;
+ else
+ RETPUSHUNDEF;
+ #else
RETPUSHYES;
#endif
+ #endif
+
}
PP(pp_tie)
***************
*** 415,422 ****
ENTER;
SAVESPTR(op);
op = (OP *) &myop;
! XPUSHs(gv);
PUTBACK;
if (op = pp_entersub())
--- 428,437 ----
ENTER;
SAVESPTR(op);
op = (OP *) &myop;
+ if (perldb && curstash != debstash)
+ op->op_private |= OPpENTERSUB_DB;
! XPUSHs((SV*)gv);
PUTBACK;
if (op = pp_entersub())
***************
*** 443,452 ****
PP(pp_untie)
{
dSP;
! if (SvTYPE(TOPs) == SVt_PVHV || SvTYPE(TOPs) == SVt_PVAV)
! sv_unmagic(TOPs, 'P');
else
! sv_unmagic(TOPs, 'q');
RETSETYES;
}
--- 458,485 ----
PP(pp_untie)
{
dSP;
! SV * sv ;
!
! sv = POPs;
! if (hints & HINT_STRICT_UNTIE)
! {
! MAGIC * mg ;
! if (SvMAGICAL(sv)) {
! if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
! mg = mg_find(sv, 'P') ;
! else
! mg = mg_find(sv, 'q') ;
!
! if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
! croak("Can't untie: %d inner references still exist",
! SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
! }
! }
!
! if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
! sv_unmagic(sv, 'P');
else
! sv_unmagic(sv, 'q');
RETSETYES;
}
***************
*** 503,508 ****
--- 536,543 ----
ENTER;
SAVESPTR(op);
op = (OP *) &myop;
+ if (perldb && curstash != debstash)
+ op->op_private |= OPpENTERSUB_DB;
PUTBACK;
pp_pushmark();
***************
*** 514,520 ****
else
PUSHs(sv_2mortal(newSViv(O_RDWR)));
PUSHs(right);
! PUSHs(gv);
PUTBACK;
if (op = pp_entersub())
--- 549,555 ----
else
PUSHs(sv_2mortal(newSViv(O_RDWR)));
PUSHs(right);
! PUSHs((SV*)gv);
PUTBACK;
if (op = pp_entersub())
***************
*** 531,537 ****
PUSHs(left);
PUSHs(sv_2mortal(newSViv(O_RDONLY)));
PUSHs(right);
! PUSHs(gv);
PUTBACK;
if (op = pp_entersub())
--- 566,572 ----
PUSHs(left);
PUSHs(sv_2mortal(newSViv(O_RDONLY)));
PUSHs(right);
! PUSHs((SV*)gv);
PUTBACK;
if (op = pp_entersub())
***************
*** 710,720 ****
if (! hv)
XPUSHs(&sv_undef);
else {
! GV **gvp = hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
if (gvp && *gvp == egv)
gv_efullname(TARG, defoutgv);
else
! sv_setsv(TARG, sv_2mortal(newRV(egv)));
XPUSHTARG;
}
--- 745,755 ----
if (! hv)
XPUSHs(&sv_undef);
else {
! GV **gvp = (GV**)hv_fetch(hv, GvNAME(egv), GvNAMELEN(egv), FALSE);
if (gvp && *gvp == egv)
gv_efullname(TARG, defoutgv);
else
! sv_setsv(TARG, sv_2mortal(newRV((SV*)egv)));
XPUSHTARG;
}
***************
*** 827,833 ****
I32 gimme;
register CONTEXT *cx;
! DEBUG_f(fprintf(stderr,"left=%ld, todo=%ld\n",
(long)IoLINES_LEFT(io), (long)FmLINES(formtarget)));
if (IoLINES_LEFT(io) < FmLINES(formtarget) &&
formtarget != toptarget)
--- 862,868 ----
I32 gimme;
register CONTEXT *cx;
! DEBUG_f(fprintf(Perl_debug_log,"left=%ld, todo=%ld\n",
(long)IoLINES_LEFT(io), (long)FmLINES(formtarget)));
if (IoLINES_LEFT(io) < FmLINES(formtarget) &&
formtarget != toptarget)
***************
*** 1211,1244 ****
SETERRNO(0,0);
#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
- #ifdef HAS_TRUNCATE
if (op->op_flags & OPf_SPECIAL) {
tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO);
if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
ftruncate(fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
! result = 0;
! }
! else if (truncate(POPp, len) < 0)
! result = 0;
! #else
! if (op->op_flags & OPf_SPECIAL) {
! tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO);
! if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
! chsize(fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
result = 0;
}
else {
! int tmpfd;
!
! if ((tmpfd = open(POPp, 0)) < 0)
result = 0;
! else {
! if (chsize(tmpfd, len) < 0)
! result = 0;
! close(tmpfd);
}
- }
#endif
if (result)
RETPUSHYES;
--- 1246,1289 ----
SETERRNO(0,0);
#if defined(HAS_TRUNCATE) || defined(HAS_CHSIZE) || defined(F_FREESP)
if (op->op_flags & OPf_SPECIAL) {
tmpgv = gv_fetchpv(POPp,FALSE, SVt_PVIO);
+ do_ftruncate:
if (!GvIO(tmpgv) || !IoIFP(GvIOp(tmpgv)) ||
+ #ifdef HAS_TRUNCATE
ftruncate(fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
! #else
! my_chsize(fileno(IoIFP(GvIOn(tmpgv))), len) < 0)
! #endif
result = 0;
}
else {
! SV *sv = POPs;
! if (SvTYPE(sv) == SVt_PVGV) {
! tmpgv = (GV*)sv; /* *main::FRED for example */
! goto do_ftruncate;
! }
! else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVGV) {
! tmpgv = (GV*) SvRV(sv); /* \*main::FRED for example */
! goto do_ftruncate;
! }
! #ifdef HAS_TRUNCATE
! if (truncate (SvPV (sv, na), len) < 0)
result = 0;
! #else
! {
! int tmpfd;
!
! if ((tmpfd = open(SvPV (sv, na), 0)) < 0)
! result = 0;
! else {
! if (my_chsize(tmpfd, len) < 0)
! result = 0;
! close(tmpfd);
! }
}
#endif
+ }
if (result)
RETPUSHYES;
***************
*** 1831,1841 ****
--- 1876,1896 ----
PUSHs(sv_2mortal(newSViv((I32)statcache.st_nlink)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_uid)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_gid)));
+ #ifdef USE_STAT_RDEV
PUSHs(sv_2mortal(newSViv((I32)statcache.st_rdev)));
+ #else
+ PUSHs(sv_2mortal(newSVpv("", 0)));
+ #endif
PUSHs(sv_2mortal(newSViv((I32)statcache.st_size)));
+ #ifdef BIG_TIME
+ PUSHs(sv_2mortal(newSVnv((U32)statcache.st_atime)));
+ PUSHs(sv_2mortal(newSVnv((U32)statcache.st_mtime)));
+ PUSHs(sv_2mortal(newSVnv((U32)statcache.st_ctime)));
+ #else
PUSHs(sv_2mortal(newSViv((I32)statcache.st_atime)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_mtime)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_ctime)));
+ #endif
#ifdef USE_STAT_BLOCKS
PUSHs(sv_2mortal(newSViv((I32)statcache.st_blksize)));
PUSHs(sv_2mortal(newSViv((I32)statcache.st_blocks)));
***************
*** 2984,2990 ****
--- 3039,3049 ----
PP(pp_time)
{
dSP; dTARGET;
+ #ifdef BIG_TIME
+ XPUSHn( time(Null(Time_t*)) );
+ #else
XPUSHi( time(Null(Time_t*)) );
+ #endif
RETURN;
}
***************
*** 3038,3044 ****
--- 3097,3107 ----
if (MAXARG < 1)
(void)time(&when);
else
+ #ifdef BIG_TIME
+ when = (Time_t)SvNVx(POPs);
+ #else
when = (Time_t)SvIVx(POPs);
+ #endif
if (op->op_type == OP_LOCALTIME)
tmbuf = localtime(&when);
#~ Reflect name changes to routines and parameters
#~ Add new routines for shared has keys, faster symbol lookup,
#~ improved %SIG management, default UNIVERSAL methods,
#~ verion checking, and safecalloc()
#~ Correct count in i18nl10n
diff -Pcr perl5_003/proto.h perl5_003_01/proto.h
*** perl5_003/proto.h Mon Mar 25 01:05:33 1996
--- perl5_003_01/proto.h Thu Jul 18 11:15:44 1996
***************
*** 30,42 ****
OP* bind_match _((I32 type, OP* left, OP* pat));
OP* block_end _((int line, int floor, OP* seq));
int block_start _((void));
void calllist _((AV* list));
I32 cando _((I32 bit, I32 effective, struct stat* statbufp));
#ifndef CASTNEGFLOAT
U32 cast_ulong _((double f));
#endif
#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
! I32 chsize _((int fd, Off_t length));
#endif
OP * ck_gvconst _((OP * o));
OP * ck_retarget _((OP *op));
--- 30,43 ----
OP* bind_match _((I32 type, OP* left, OP* pat));
OP* block_end _((int line, int floor, OP* seq));
int block_start _((void));
+ void boot_core_UNIVERSAL _((void));
void calllist _((AV* list));
I32 cando _((I32 bit, I32 effective, struct stat* statbufp));
#ifndef CASTNEGFLOAT
U32 cast_ulong _((double f));
#endif
#if !defined(HAS_TRUNCATE) && !defined(HAS_CHSIZE) && defined(F_FREESP)
! I32 my_chsize _((int fd, Off_t length));
#endif
OP * ck_gvconst _((OP * o));
OP * ck_retarget _((OP *op));
***************
*** 66,72 ****
void dounwind _((I32 cxix));
bool do_aexec _((SV* really, SV** mark, SV** sp));
void do_chop _((SV* asv, SV* sv));
! bool do_close _((GV* gv, bool explicit));
bool do_eof _((GV* gv));
bool do_exec _((char* cmd));
void do_execfree _((void));
--- 67,73 ----
void dounwind _((I32 cxix));
bool do_aexec _((SV* really, SV** mark, SV** sp));
void do_chop _((SV* asv, SV* sv));
! bool do_close _((GV* gv, bool not_implicit));
bool do_eof _((GV* gv));
bool do_exec _((char* cmd));
void do_execfree _((void));
***************
*** 131,151 ****
void gv_fullname _((SV* sv, GV* gv));
void gv_init _((GV *gv, HV *stash, char *name, STRLEN len, int multi));
HV* gv_stashpv _((char* name, I32 create));
HV* gv_stashsv _((SV* sv, I32 create));
! void he_delayfree _((HE* hent));
! void he_free _((HE* hent));
void hoistmust _((PMOP* pm));
void hv_clear _((HV* tb));
SV* hv_delete _((HV* tb, char* key, U32 klen, I32 flags));
bool hv_exists _((HV* tb, char* key, U32 klen));
SV** hv_fetch _((HV* tb, char* key, U32 klen, I32 lval));
I32 hv_iterinit _((HV* tb));
char* hv_iterkey _((HE* entry, I32* retlen));
HE* hv_iternext _((HV* tb));
! SV * hv_iternextsv _((HV* hv, char** key, I32* retlen));
SV* hv_iterval _((HV* tb, HE* entry));
void hv_magic _((HV* hv, GV* gv, int how));
SV** hv_store _((HV* tb, char* key, U32 klen, SV* val, U32 hash));
void hv_undef _((HV* tb));
I32 ibcmp _((U8* a, U8* b, I32 len));
I32 ingroup _((I32 testgid, I32 effective));
--- 132,158 ----
void gv_fullname _((SV* sv, GV* gv));
void gv_init _((GV *gv, HV *stash, char *name, STRLEN len, int multi));
HV* gv_stashpv _((char* name, I32 create));
+ HV* gv_stashpvn _((char* name, U32 namelen, I32 create));
HV* gv_stashsv _((SV* sv, I32 create));
! void he_delayfree _((HE* hent, I32 shared));
! void he_free _((HE* hent, I32 shared));
void hoistmust _((PMOP* pm));
void hv_clear _((HV* tb));
SV* hv_delete _((HV* tb, char* key, U32 klen, I32 flags));
+ SV* hv_delete_ent _((HV* tb, SV* key, I32 flags, U32 hash));
bool hv_exists _((HV* tb, char* key, U32 klen));
+ bool hv_exists_ent _((HV* tb, SV* key, U32 hash));
SV** hv_fetch _((HV* tb, char* key, U32 klen, I32 lval));
+ HE* hv_fetch_ent _((HV* tb, SV* key, I32 lval, U32 hash));
I32 hv_iterinit _((HV* tb));
char* hv_iterkey _((HE* entry, I32* retlen));
+ SV* hv_iterkeysv _((HE* entry));
HE* hv_iternext _((HV* tb));
! SV* hv_iternextsv _((HV* hv, char** key, I32* retlen));
SV* hv_iterval _((HV* tb, HE* entry));
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 ingroup _((I32 testgid, I32 effective));
***************
*** 164,175 ****
--- 171,184 ----
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_get _((SV* sv, MAGIC* mg));
int magic_getarylen _((SV* sv, MAGIC* mg));
int magic_getpack _((SV* sv, MAGIC* mg));
int magic_getglob _((SV* sv, MAGIC* mg));
int magic_getpos _((SV* sv, MAGIC* mg));
+ int magic_getsig _((SV* sv, MAGIC* mg));
int magic_gettaint _((SV* sv, MAGIC* mg));
int magic_getuvar _((SV* sv, MAGIC* mg));
U32 magic_len _((SV* sv, MAGIC* mg));
***************
*** 202,212 ****
extern Malloc_t malloc _((MEM_SIZE nbytes));
extern Malloc_t realloc _((Malloc_t, MEM_SIZE));
extern Free_t free _((Malloc_t));
#endif
void markstack_grow _((void));
char* mess _((char* pat, va_list* args));
int mg_clear _((SV* sv));
! int mg_copy _((SV *, SV *, char *, STRLEN));
MAGIC* mg_find _((SV* sv, int type));
int mg_free _((SV* sv));
int mg_get _((SV* sv));
--- 211,222 ----
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));
char* mess _((char* pat, va_list* args));
int mg_clear _((SV* sv));
! int mg_copy _((SV *, SV *, char *, I32));
MAGIC* mg_find _((SV* sv, int type));
int mg_free _((SV* sv));
int mg_get _((SV* sv));
***************
*** 313,319 ****
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_i18nl14n _((int printwarn));
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
--- 323,329 ----
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_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
***************
*** 347,363 ****
--- 357,377 ----
#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
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));
void savestack_grow _((void));
void save_aptr _((AV** aptr));
AV* save_ary _((GV* gv));
***************
*** 461,467 ****
#ifdef UNLINK_ALL_VERSIONS
I32 unlnk _((char* f));
#endif
! void utilize _((int aver, I32 floor, OP* id, OP* arg));
I32 wait4pid _((int pid, int* statusp, int flags));
void warn _((char* pat,...)) __attribute__((format(printf,1,2)));
void watch _((char **addr));
--- 475,481 ----
#ifdef UNLINK_ALL_VERSIONS
I32 unlnk _((char* f));
#endif
! void utilize _((int aver, I32 floor, OP* version, OP* id, OP* arg));
I32 wait4pid _((int pid, int* statusp, int flags));
void warn _((char* pat,...)) __attribute__((format(printf,1,2)));
void watch _((char **addr));
#~ Allow redirection of debug messages
diff -Pcr perl5_003/regcomp.c perl5_003_01/regcomp.c
*** perl5_003/regcomp.c Tue Nov 14 21:42:45 1995
--- perl5_003_01/regcomp.c Tue Jun 18 20:10:12 1996
***************
*** 244,250 ****
if (sawplus && (!sawopen || !regsawback))
r->reganch |= ROPT_SKIP; /* x+ must match 1st of run */
! DEBUG_r(fprintf(stderr,"first %d next %d offset %d\n",
OP(first), OP(NEXTOPER(first)), first - scan));
/*
* If there's something expensive in the r.e., find the
--- 244,250 ----
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",
OP(first), OP(NEXTOPER(first)), first - scan));
/*
* If there's something expensive in the r.e., find the
***************
*** 1432,1438 ****
#ifdef DEBUGGING
/*
! - regdump - dump a regexp onto stderr in vaguely comprehensible form
*/
void
regdump(r)
--- 1432,1438 ----
#ifdef DEBUGGING
/*
! - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
*/
void
regdump(r)
***************
*** 1450,1462 ****
s++;
#endif
op = OP(s);
! fprintf(stderr,"%2d%s", s-r->program, regprop(s)); /* Where, what. */
next = regnext(s);
s += regarglen[(U8)op];
if (next == NULL) /* Next ptr. */
! fprintf(stderr,"(0)");
else
! fprintf(stderr,"(%d)", (s-r->program)+(next-s));
s += 3;
if (op == ANYOF) {
s += 32;
--- 1450,1462 ----
s++;
#endif
op = OP(s);
! fprintf(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)");
else
! fprintf(Perl_debug_log,"(%d)", (s-r->program)+(next-s));
s += 3;
if (op == ANYOF) {
s += 32;
***************
*** 1464,1497 ****
if (op == EXACTLY) {
/* Literal string, where present. */
s++;
! (void)putc(' ', stderr);
! (void)putc('<', stderr);
while (*s != '\0') {
! (void)putc(*s, stderr);
s++;
}
! (void)putc('>', stderr);
s++;
}
! (void)putc('\n', stderr);
}
/* Header fields of interest. */
if (r->regstart)
! fprintf(stderr,"start `%s' ", SvPVX(r->regstart));
if (r->regstclass)
! fprintf(stderr,"stclass `%s' ", regprop(r->regstclass));
if (r->reganch & ROPT_ANCH)
! fprintf(stderr,"anchored ");
if (r->reganch & ROPT_SKIP)
! fprintf(stderr,"plus ");
if (r->reganch & ROPT_IMPLICIT)
! fprintf(stderr,"implicit ");
if (r->regmust != NULL)
! fprintf(stderr,"must have \"%s\" back %ld ", SvPVX(r->regmust),
(long) r->regback);
! fprintf(stderr, "minlen %ld ", (long) r->minlen);
! fprintf(stderr,"\n");
}
/*
--- 1464,1497 ----
if (op == EXACTLY) {
/* Literal string, where present. */
s++;
! (void)putc(' ', Perl_debug_log);
! (void)putc('<', Perl_debug_log);
while (*s != '\0') {
! (void)putc(*s, Perl_debug_log);
s++;
}
! (void)putc('>', Perl_debug_log);
s++;
}
! (void)putc('\n', Perl_debug_log);
}
/* Header fields of interest. */
if (r->regstart)
! fprintf(Perl_debug_log,"start `%s' ", SvPVX(r->regstart));
if (r->regstclass)
! fprintf(Perl_debug_log,"stclass `%s' ", regprop(r->regstclass));
if (r->reganch & ROPT_ANCH)
! fprintf(Perl_debug_log,"anchored ");
if (r->reganch & ROPT_SKIP)
! fprintf(Perl_debug_log,"plus ");
if (r->reganch & ROPT_IMPLICIT)
! fprintf(Perl_debug_log,"implicit ");
if (r->regmust != NULL)
! fprintf(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");
}
/*
#~ Allow redirection of debug messages
diff -Pcr perl5_003/regexec.c perl5_003_01/regexec.c
*** perl5_003/regexec.c Tue Nov 14 21:03:18 1995
--- perl5_003_01/regexec.c Tue Jun 18 20:10:17 1996
***************
*** 590,596 ****
#define sayNO goto no
#define saySAME(x) if (x) goto yes; else goto no
if (regnarrate) {
! fprintf(stderr, "%*s%2d%-8.8s\t<%.10s>\n", regindent*2, "",
scan - regprogram, regprop(scan), locinput);
}
#else
--- 590,596 ----
#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, "",
scan - regprogram, regprop(scan), locinput);
}
#else
***************
*** 806,812 ****
#ifdef DEBUGGING
if (regnarrate)
! fprintf(stderr, "%*s %d %lx\n", regindent*2, "",
n, (long)cc);
#endif
--- 806,812 ----
#ifdef DEBUGGING
if (regnarrate)
! fprintf(Perl_debug_log, "%*s %d %lx\n", regindent*2, "",
n, (long)cc);
#endif
#~ Allow redirection of debug messages
diff -Pcr perl5_003/run.c perl5_003_01/run.c
*** perl5_003/run.c Mon Mar 25 01:05:34 1996
--- perl5_003_01/run.c Tue Jun 18 20:10:19 1996
***************
*** 47,53 ****
do {
if (debug) {
if (watchaddr != 0 && *watchaddr != watchok)
! fprintf(stderr, "WARNING: %lx changed from %lx to %lx\n",
(long)watchaddr, (long)watchok, (long)*watchaddr);
DEBUG_s(debstack());
DEBUG_t(debop(op));
--- 47,53 ----
do {
if (debug) {
if (watchaddr != 0 && *watchaddr != watchok)
! fprintf(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,87 ****
deb("%s", op_name[op->op_type]);
switch (op->op_type) {
case OP_CONST:
! fprintf(stderr, "(%s)", SvPEEK(cSVOP->op_sv));
break;
case OP_GVSV:
case OP_GV:
if (cGVOP->op_gv) {
sv = NEWSV(0,0);
gv_fullname(sv, cGVOP->op_gv);
! fprintf(stderr, "(%s)", SvPV(sv, na));
SvREFCNT_dec(sv);
}
else
! fprintf(stderr, "(NULL)");
break;
default:
break;
}
! fprintf(stderr, "\n");
return 0;
}
--- 65,87 ----
deb("%s", op_name[op->op_type]);
switch (op->op_type) {
case OP_CONST:
! fprintf(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));
SvREFCNT_dec(sv);
}
else
! fprintf(Perl_debug_log, "(NULL)");
break;
default:
break;
}
! fprintf(Perl_debug_log, "\n");
return 0;
}
***************
*** 91,97 ****
{
watchaddr = addr;
watchok = *addr;
! fprintf(stderr, "WATCHING, %lx is currently %lx\n",
(long)watchaddr, (long)watchok);
}
--- 91,97 ----
{
watchaddr = addr;
watchok = *addr;
! fprintf(Perl_debug_log, "WATCHING, %lx is currently %lx\n",
(long)watchaddr, (long)watchok);
}
***************
*** 112,118 ****
return;
for (i = 0; i < MAXO; i++) {
if (profiledata[i])
! fprintf(stderr, "%d\t%lu\n", i, profiledata[i]);
}
}
--- 112,118 ----
return;
for (i = 0; i < MAXO; i++) {
if (profiledata[i])
! fprintf(Perl_debug_log, "%d\t%lu\n", i, profiledata[i]);
}
}
#~ Rename global variable to eliminate collision with system headers
#~ Add casts to reflect new GV type
#~ Allow redirection of debug messages
diff -Pcr perl5_003/scope.c perl5_003_01/scope.c
*** perl5_003/scope.c Mon Feb 12 15:00:30 1996
--- perl5_003_01/scope.c Thu Jul 4 14:49:17 1996
***************
*** 22,28 ****
int n;
{
stack_sp = sp;
! av_extend(stack, (p - stack_base) + (n) + 128);
return stack_sp;
}
--- 22,28 ----
int n;
{
stack_sp = sp;
! av_extend(curstack, (p - stack_base) + (n) + 128);
return stack_sp;
}
***************
*** 518,524 ****
break;
case SAVEt_NSTAB:
gv = (GV*)SSPOPPTR;
! (void)sv_clear(gv);
break;
case SAVEt_GP: /* scalar reference */
ptr = SSPOPPTR;
--- 518,524 ----
break;
case SAVEt_NSTAB:
gv = (GV*)SSPOPPTR;
! (void)sv_clear((SV*)gv);
break;
case SAVEt_GP: /* scalar reference */
ptr = SSPOPPTR;
***************
*** 608,699 ****
}
#ifdef DEBUGGING
void
cx_dump(cx)
CONTEXT* cx;
{
! fprintf(stderr, "CX %d = %s\n", cx - cxstack, block_type[cx->cx_type]);
if (cx->cx_type != CXt_SUBST) {
! fprintf(stderr, "BLK_OLDSP = %ld\n", (long)cx->blk_oldsp);
! fprintf(stderr, "BLK_OLDCOP = 0x%lx\n", (long)cx->blk_oldcop);
! fprintf(stderr, "BLK_OLDMARKSP = %ld\n", (long)cx->blk_oldmarksp);
! fprintf(stderr, "BLK_OLDSCOPESP = %ld\n", (long)cx->blk_oldscopesp);
! fprintf(stderr, "BLK_OLDRETSP = %ld\n", (long)cx->blk_oldretsp);
! fprintf(stderr, "BLK_OLDPM = 0x%lx\n", (long)cx->blk_oldpm);
! fprintf(stderr, "BLK_GIMME = %s\n", cx->blk_gimme ? "LIST" : "SCALAR");
}
switch (cx->cx_type) {
case CXt_NULL:
case CXt_BLOCK:
break;
case CXt_SUB:
! fprintf(stderr, "BLK_SUB.CV = 0x%lx\n",
(long)cx->blk_sub.cv);
! fprintf(stderr, "BLK_SUB.GV = 0x%lx\n",
(long)cx->blk_sub.gv);
! fprintf(stderr, "BLK_SUB.DFOUTGV = 0x%lx\n",
(long)cx->blk_sub.dfoutgv);
! fprintf(stderr, "BLK_SUB.OLDDEPTH = %ld\n",
(long)cx->blk_sub.olddepth);
! fprintf(stderr, "BLK_SUB.HASARGS = %d\n",
(int)cx->blk_sub.hasargs);
break;
case CXt_EVAL:
! fprintf(stderr, "BLK_EVAL.OLD_IN_EVAL = %ld\n",
(long)cx->blk_eval.old_in_eval);
! fprintf(stderr, "BLK_EVAL.OLD_OP_TYPE = %s (%s)\n",
op_name[cx->blk_eval.old_op_type],
op_desc[cx->blk_eval.old_op_type]);
! fprintf(stderr, "BLK_EVAL.OLD_NAME = %s\n",
cx->blk_eval.old_name);
! fprintf(stderr, "BLK_EVAL.OLD_EVAL_ROOT = 0x%lx\n",
(long)cx->blk_eval.old_eval_root);
break;
case CXt_LOOP:
! fprintf(stderr, "BLK_LOOP.LABEL = %s\n",
cx->blk_loop.label);
! fprintf(stderr, "BLK_LOOP.RESETSP = %ld\n",
(long)cx->blk_loop.resetsp);
! fprintf(stderr, "BLK_LOOP.REDO_OP = 0x%lx\n",
(long)cx->blk_loop.redo_op);
! fprintf(stderr, "BLK_LOOP.NEXT_OP = 0x%lx\n",
(long)cx->blk_loop.next_op);
! fprintf(stderr, "BLK_LOOP.LAST_OP = 0x%lx\n",
(long)cx->blk_loop.last_op);
! fprintf(stderr, "BLK_LOOP.ITERIX = %ld\n",
(long)cx->blk_loop.iterix);
! fprintf(stderr, "BLK_LOOP.ITERARY = 0x%lx\n",
(long)cx->blk_loop.iterary);
! fprintf(stderr, "BLK_LOOP.ITERVAR = 0x%lx\n",
(long)cx->blk_loop.itervar);
if (cx->blk_loop.itervar)
! fprintf(stderr, "BLK_LOOP.ITERSAVE = 0x%lx\n",
(long)cx->blk_loop.itersave);
break;
case CXt_SUBST:
! fprintf(stderr, "SB_ITERS = %ld\n",
(long)cx->sb_iters);
! fprintf(stderr, "SB_MAXITERS = %ld\n",
(long)cx->sb_maxiters);
! fprintf(stderr, "SB_SAFEBASE = %ld\n",
(long)cx->sb_safebase);
! fprintf(stderr, "SB_ONCE = %ld\n",
(long)cx->sb_once);
! fprintf(stderr, "SB_ORIG = %s\n",
cx->sb_orig);
! fprintf(stderr, "SB_DSTR = 0x%lx\n",
(long)cx->sb_dstr);
! fprintf(stderr, "SB_TARG = 0x%lx\n",
(long)cx->sb_targ);
! fprintf(stderr, "SB_S = 0x%lx\n",
(long)cx->sb_s);
! fprintf(stderr, "SB_M = 0x%lx\n",
(long)cx->sb_m);
! fprintf(stderr, "SB_STREND = 0x%lx\n",
(long)cx->sb_strend);
! fprintf(stderr, "SB_SUBBASE = 0x%lx\n",
(long)cx->sb_subbase);
break;
}
--- 608,700 ----
}
#ifdef DEBUGGING
+
void
cx_dump(cx)
CONTEXT* cx;
{
! fprintf(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");
}
switch (cx->cx_type) {
case CXt_NULL:
case CXt_BLOCK:
break;
case CXt_SUB:
! fprintf(Perl_debug_log, "BLK_SUB.CV = 0x%lx\n",
(long)cx->blk_sub.cv);
! fprintf(Perl_debug_log, "BLK_SUB.GV = 0x%lx\n",
(long)cx->blk_sub.gv);
! fprintf(Perl_debug_log, "BLK_SUB.DFOUTGV = 0x%lx\n",
(long)cx->blk_sub.dfoutgv);
! fprintf(Perl_debug_log, "BLK_SUB.OLDDEPTH = %ld\n",
(long)cx->blk_sub.olddepth);
! fprintf(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",
(long)cx->blk_eval.old_in_eval);
! fprintf(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",
cx->blk_eval.old_name);
! fprintf(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",
cx->blk_loop.label);
! fprintf(Perl_debug_log, "BLK_LOOP.RESETSP = %ld\n",
(long)cx->blk_loop.resetsp);
! fprintf(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",
(long)cx->blk_loop.next_op);
! fprintf(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",
(long)cx->blk_loop.iterix);
! fprintf(Perl_debug_log, "BLK_LOOP.ITERARY = 0x%lx\n",
(long)cx->blk_loop.iterary);
! fprintf(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",
(long)cx->blk_loop.itersave);
break;
case CXt_SUBST:
! fprintf(Perl_debug_log, "SB_ITERS = %ld\n",
(long)cx->sb_iters);
! fprintf(Perl_debug_log, "SB_MAXITERS = %ld\n",
(long)cx->sb_maxiters);
! fprintf(Perl_debug_log, "SB_SAFEBASE = %ld\n",
(long)cx->sb_safebase);
! fprintf(Perl_debug_log, "SB_ONCE = %ld\n",
(long)cx->sb_once);
! fprintf(Perl_debug_log, "SB_ORIG = %s\n",
cx->sb_orig);
! fprintf(Perl_debug_log, "SB_DSTR = 0x%lx\n",
(long)cx->sb_dstr);
! fprintf(Perl_debug_log, "SB_TARG = 0x%lx\n",
(long)cx->sb_targ);
! fprintf(Perl_debug_log, "SB_S = 0x%lx\n",
(long)cx->sb_s);
! fprintf(Perl_debug_log, "SB_M = 0x%lx\n",
(long)cx->sb_m);
! fprintf(Perl_debug_log, "SB_STREND = 0x%lx\n",
(long)cx->sb_strend);
! fprintf(Perl_debug_log, "SB_SUBBASE = 0x%lx\n",
(long)cx->sb_subbase);
break;
}
#~ Correct cast in SAVEDESTRUCTOR macro
diff -Pcr perl5_003/scope.h perl5_003_01/scope.h
*** perl5_003/scope.h Tue Oct 18 12:23:09 1994
--- perl5_003_01/scope.h Tue Jun 18 15:12:07 1996
***************
*** 54,58 ****
#define SAVEFREEPV(p) save_freepv((char*)(p))
#define SAVECLEARSV(sv) save_clearsv((SV**)(&sv))
#define SAVEDELETE(h,k,l) save_delete((HV*)(h), (char*)(k), (I32)l)
! #define SAVEDESTRUCTOR(f,p) save_destructor(f,(void*)p)
--- 54,58 ----
#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)
#~ Don't try stdio tricks under QNX
#~ Mark deleted SV with "impossible" type
#~ Use Safemalloc to allocate memory for SVs, since we'll use Safefree
#~ to deallocate it later
#~ Use casts to reflect new GV type
#~ Allow redirection of debug messages
#~ Add shared hash key support
#~ Tolerate dangling references in debugger during object destruction
#~ Don't warn about unreferenced scalars spotted during sv_clean_all()
#~ If we're not trying stdio tricks, at least give system calls some
#~ breathing room when we use the same line terminator they do (\n)
#~ Add information to sv_dump() output
diff -Pcr perl5_003/sv.c perl5_003_01/sv.c
*** perl5_003/sv.c Tue Feb 27 20:46:38 1996
--- perl5_003_01/sv.c Thu Jul 25 15:26:20 1996
***************
*** 36,42 ****
#endif
#endif
! #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
# define FAST_SV_GETS
#endif
--- 36,42 ----
#endif
#endif
! #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__)
# define FAST_SV_GETS
#endif
***************
*** 103,108 ****
--- 103,109 ----
del_sv(p); \
else { \
SvANY(p) = (void *)sv_root; \
+ SvFLAGS(p) = SVTYPEMASK; \
sv_root = p; \
--sv_count; \
}
***************
*** 176,183 ****
sv_add_arena(nice_chunk, nice_chunk_size, 0);
nice_chunk = Nullch;
}
! else
! sv_add_arena(safemalloc(1008), 1008, 0);
return new_sv();
}
#endif
--- 177,187 ----
sv_add_arena(nice_chunk, nice_chunk_size, 0);
nice_chunk = Nullch;
}
! else {
! char *chunk; /* must use New here to match call to */
! New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
! sv_add_arena(chunk, 1008, 0);
! }
return new_sv();
}
#endif
***************
*** 213,221 ****
#ifndef DISABLE_DESTRUCTOR_KLUDGE
register GV* gv;
for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
! gv = sva + 1;
svend = &sva[SvREFCNT(sva)];
! while (gv < svend) {
if (SvTYPE(gv) == SVt_PVGV && (sv = GvSV(gv)) &&
SvROK(sv) && SvOBJECT(rv = SvRV(sv)))
{
--- 217,225 ----
#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)))
{
***************
*** 248,253 ****
--- 252,259 ----
}
}
+ static int in_clean_all = 0;
+
void
sv_clean_all()
{
***************
*** 255,272 ****
register SV* sv;
register SV* svend;
for (sva = sv_arenaroot; sva; sva = (SV*) SvANY(sva)) {
sv = sva + 1;
svend = &sva[SvREFCNT(sva)];
while (sv < svend) {
if (SvTYPE(sv) != SVTYPEMASK) {
! DEBUG_D((fprintf(stderr, "Cleaning loops:\n "), sv_dump(sv));)
SvFLAGS(sv) |= SVf_BREAK;
SvREFCNT_dec(sv);
}
++sv;
}
}
}
void
--- 261,280 ----
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;
}
}
+ in_clean_all = 0;
}
void
***************
*** 284,290 ****
svanext = (SV*) SvANY(svanext);
if (!SvFAKE(sva))
! Safefree(sva);
}
}
--- 292,298 ----
svanext = (SV*) SvANY(svanext);
if (!SvFAKE(sva))
! Safefree((void *)sva);
}
}
***************
*** 1199,1205 ****
warn(warn_uninit);
return 0;
}
! DEBUG_c(fprintf(stderr,"0x%lx 2iv(%ld)\n",
(unsigned long)sv,(long)SvIVX(sv)));
return SvIVX(sv);
}
--- 1207,1214 ----
warn(warn_uninit);
return 0;
}
! (void)SvIOK_on(sv);
! DEBUG_c(fprintf(Perl_debug_log,"0x%lx 2iv(%ld)\n",
(unsigned long)sv,(long)SvIVX(sv)));
return SvIVX(sv);
}
***************
*** 1252,1258 ****
sv_upgrade(sv, SVt_PVNV);
else
sv_upgrade(sv, SVt_NV);
! DEBUG_c(fprintf(stderr,"0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
--- 1261,1267 ----
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)));
}
else if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
***************
*** 1272,1278 ****
return 0.0;
}
SvNOK_on(sv);
! DEBUG_c(fprintf(stderr,"0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
return SvNVX(sv);
}
--- 1281,1287 ----
return 0.0;
}
SvNOK_on(sv);
! DEBUG_c(fprintf(Perl_debug_log,"0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
return SvNVX(sv);
}
***************
*** 1407,1413 ****
*lp = s - SvPVX(sv);
SvCUR_set(sv, *lp);
SvPOK_on(sv);
! DEBUG_c(fprintf(stderr,"0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
return SvPVX(sv);
tokensave:
--- 1416,1422 ----
*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)));
return SvPVX(sv);
tokensave:
***************
*** 1600,1606 ****
}
(void)SvOK_off(dstr);
GvINTRO_off(dstr); /* one-shot flag */
! gp_free(dstr);
GvGP(dstr) = gp_ref(GvGP(sstr));
SvTAINT(dstr);
if (curcop->cop_stash != GvSTASH(dstr))
--- 1609,1615 ----
}
(void)SvOK_off(dstr);
GvINTRO_off(dstr); /* one-shot flag */
! gp_free((GV*)dstr);
GvGP(dstr) = gp_ref(GvGP(sstr));
SvTAINT(dstr);
if (curcop->cop_stash != GvSTASH(dstr))
***************
*** 1635,1641 ****
GvREFCNT(dstr) = 1;
GvSV(dstr) = NEWSV(72,0);
GvLINE(dstr) = curcop->cop_line;
! GvEGV(dstr) = dstr;
}
GvMULTI_on(dstr);
switch (SvTYPE(sref)) {
--- 1644,1650 ----
GvREFCNT(dstr) = 1;
GvSV(dstr) = NEWSV(72,0);
GvLINE(dstr) = curcop->cop_line;
! GvEGV(dstr) = (GV*)dstr;
}
GvMULTI_on(dstr);
switch (SvTYPE(sref)) {
***************
*** 1991,1996 ****
--- 2000,2007 ----
return sv;
}
+ /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
+
void
sv_magic(sv, obj, how, name, namlen)
register SV *sv;
***************
*** 2026,2033 ****
}
mg->mg_type = how;
mg->mg_len = namlen;
! if (name && namlen >= 0)
! mg->mg_ptr = savepvn(name, namlen);
switch (how) {
case 0:
mg->mg_virtual = &vtbl_sv;
--- 2037,2048 ----
}
mg->mg_type = how;
mg->mg_len = namlen;
! if (name)
! if (namlen >= 0)
! mg->mg_ptr = savepvn(name, namlen);
! else if (namlen == HEf_SVKEY)
! mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
!
switch (how) {
case 0:
mg->mg_virtual = &vtbl_sv;
***************
*** 2134,2140 ****
if (vtbl && vtbl->svt_free)
(*vtbl->svt_free)(sv, mg);
if (mg->mg_ptr && mg->mg_type != 'g')
! Safefree(mg->mg_ptr);
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
--- 2149,2158 ----
if (vtbl && vtbl->svt_free)
(*vtbl->svt_free)(sv, mg);
if (mg->mg_ptr && mg->mg_type != 'g')
! if (mg->mg_len >= 0)
! Safefree(mg->mg_ptr);
! else if (mg->mg_len == HEf_SVKEY)
! SvREFCNT_dec((SV*)mg->mg_ptr);
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
***************
*** 2261,2266 ****
--- 2279,2285 ----
sv_clear(sv);
StructCopy(nsv,sv,SV);
SvREFCNT(sv) = refcnt;
+ SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
del_SV(nsv);
}
***************
*** 2285,2291 ****
Zero(&ref, 1, SV);
sv_upgrade(&ref, SVt_RV);
- SAVEI32(SvREFCNT(sv));
SvRV(&ref) = SvREFCNT_inc(sv);
SvROK_on(&ref);
--- 2304,2309 ----
***************
*** 2295,2300 ****
--- 2313,2319 ----
PUTBACK;
perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
del_XRV(SvANY(&ref));
+ SvREFCNT(sv)--;
}
LEAVE;
}
***************
*** 2305,2310 ****
--- 2324,2342 ----
if (SvTYPE(sv) != SVt_PVIO)
--sv_objcount; /* XXX Might want something more general */
}
+ if (SvREFCNT(sv)) {
+ SV *ret;
+ if ( perldb
+ && (ret = perl_get_sv("DB::ret", FALSE))
+ && SvROK(ret) && SvRV(ret) == sv && SvREFCNT(sv) == 1) {
+ /* Debugger is prone to dangling references. */
+ SvRV(ret) = 0;
+ SvROK_off(ret);
+ SvREFCNT(sv) = 0;
+ } else {
+ croak("panic: dangling references in DESTROY");
+ }
+ }
}
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
mg_free(sv);
***************
*** 2328,2334 ****
av_undef((AV*)sv);
break;
case SVt_PVGV:
! gp_free(sv);
Safefree(GvNAME(sv));
/* FALL THROUGH */
case SVt_PVLV:
--- 2360,2366 ----
av_undef((AV*)sv);
break;
case SVt_PVGV:
! gp_free((GV*)sv);
Safefree(GvNAME(sv));
/* FALL THROUGH */
case SVt_PVLV:
***************
*** 2342,2348 ****
case SVt_RV:
if (SvROK(sv))
SvREFCNT_dec(SvRV(sv));
! else if (SvPVX(sv))
Safefree(SvPVX(sv));
break;
/*
--- 2374,2380 ----
case SVt_RV:
if (SvROK(sv))
SvREFCNT_dec(SvRV(sv));
! else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
break;
/*
***************
*** 2428,2433 ****
--- 2460,2467 ----
if (SvREFCNT(sv) == 0) {
if (SvFLAGS(sv) & SVf_BREAK)
return;
+ if (in_clean_all) /* All is fair */
+ return;
warn("Attempt to free unreferenced scalar");
return;
}
***************
*** 2680,2694 ****
screamer:
if (rslen) {
! register STDCHAR *bpe = buf + sizeof(buf);
! bp = buf;
! while ((i = getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
! ; /* keep reading */
! cnt = bp - buf;
}
else {
cnt = fread((char*)buf, 1, sizeof(buf), fp);
! i = cnt ? (U8)buf[cnt - 1] : EOF;
}
if (append)
--- 2714,2734 ----
screamer:
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;
! }
}
else {
cnt = fread((char*)buf, 1, sizeof(buf), fp);
! i = cnt ? !EOF : EOF;
}
if (append)
***************
*** 3023,3032 ****
for (i = 0; i <= (I32) HvMAX(stash); i++) {
for (entry = HvARRAY(stash)[i];
entry;
! entry = entry->hent_next) {
! if (!todo[(U8)*entry->hent_key])
continue;
! gv = (GV*)entry->hent_val;
sv = GvSV(gv);
(void)SvOK_off(sv);
if (SvTYPE(sv) >= SVt_PV) {
--- 3063,3072 ----
for (i = 0; i <= (I32) HvMAX(stash); i++) {
for (entry = HvARRAY(stash)[i];
entry;
! entry = HeNEXT(entry)) {
! if (!todo[(U8)*HeKEY(entry)])
continue;
! gv = (GV*)HeVAL(entry);
sv = GvSV(gv);
(void)SvOK_off(sv);
if (SvTYPE(sv) >= SVt_PV) {
***************
*** 3225,3231 ****
if (!SvPOK(sv)) {
SvPOK_on(sv); /* validate pointer */
SvTAINT(sv);
! DEBUG_c(fprintf(stderr,"0x%lx 2pv(%s)\n",
(unsigned long)sv,SvPVX(sv)));
}
}
--- 3265,3271 ----
if (!SvPOK(sv)) {
SvPOK_on(sv); /* validate pointer */
SvTAINT(sv);
! DEBUG_c(fprintf(Perl_debug_log,"0x%lx 2pv(%s)\n",
(unsigned long)sv,SvPVX(sv)));
}
}
***************
*** 3394,3400 ****
assert(SvTYPE(sv) == SVt_PVGV);
SvFAKE_off(sv);
if (GvGP(sv))
! gp_free(sv);
sv_unmagic(sv, '*');
Safefree(GvNAME(sv));
GvMULTI_off(sv);
--- 3434,3440 ----
assert(SvTYPE(sv) == SVt_PVGV);
SvFAKE_off(sv);
if (GvGP(sv))
! gp_free((GV*)sv);
sv_unmagic(sv, '*');
Safefree(GvNAME(sv));
GvMULTI_off(sv);
***************
*** 3427,3433 ****
U32 type;
if (!sv) {
! fprintf(stderr, "SV = 0\n");
return;
}
--- 3467,3473 ----
U32 type;
if (!sv) {
! fprintf(Perl_debug_log, "SV = 0\n");
return;
}
***************
*** 3456,3531 ****
if (flags & SVf_READONLY) strcat(d, "READONLY,");
d += strlen(d);
if (flags & SVp_IOK) strcat(d, "pIOK,");
if (flags & SVp_NOK) strcat(d, "pNOK,");
if (flags & SVp_POK) strcat(d, "pPOK,");
if (flags & SVp_SCREAM) strcat(d, "SCREAM,");
d += strlen(d);
if (d[-1] == ',')
d--;
*d++ = ')';
*d = '\0';
! fprintf(stderr, "SV = ");
switch (type) {
case SVt_NULL:
! fprintf(stderr,"NULL%s\n", tmpbuf);
return;
case SVt_IV:
! fprintf(stderr,"IV%s\n", tmpbuf);
break;
case SVt_NV:
! fprintf(stderr,"NV%s\n", tmpbuf);
break;
case SVt_RV:
! fprintf(stderr,"RV%s\n", tmpbuf);
break;
case SVt_PV:
! fprintf(stderr,"PV%s\n", tmpbuf);
break;
case SVt_PVIV:
! fprintf(stderr,"PVIV%s\n", tmpbuf);
break;
case SVt_PVNV:
! fprintf(stderr,"PVNV%s\n", tmpbuf);
break;
case SVt_PVBM:
! fprintf(stderr,"PVBM%s\n", tmpbuf);
break;
case SVt_PVMG:
! fprintf(stderr,"PVMG%s\n", tmpbuf);
break;
case SVt_PVLV:
! fprintf(stderr,"PVLV%s\n", tmpbuf);
break;
case SVt_PVAV:
! fprintf(stderr,"PVAV%s\n", tmpbuf);
break;
case SVt_PVHV:
! fprintf(stderr,"PVHV%s\n", tmpbuf);
break;
case SVt_PVCV:
! fprintf(stderr,"PVCV%s\n", tmpbuf);
break;
case SVt_PVGV:
! fprintf(stderr,"PVGV%s\n", tmpbuf);
break;
case SVt_PVFM:
! fprintf(stderr,"PVFM%s\n", tmpbuf);
break;
case SVt_PVIO:
! fprintf(stderr,"PVIO%s\n", tmpbuf);
break;
default:
! fprintf(stderr,"UNKNOWN%s\n", tmpbuf);
return;
}
if (type >= SVt_PVIV || type == SVt_IV)
! fprintf(stderr, " IV = %ld\n", (long)SvIVX(sv));
if (type >= SVt_PVNV || type == SVt_NV)
! fprintf(stderr, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
if (SvROK(sv)) {
! fprintf(stderr, " RV = 0x%lx\n", (long)SvRV(sv));
sv_dump(SvRV(sv));
return;
}
--- 3496,3588 ----
if (flags & SVf_READONLY) strcat(d, "READONLY,");
d += strlen(d);
+ #ifdef OVERLOAD
+ if (flags & SVf_AMAGIC) strcat(d, "OVERLOAD,");
+ #endif /* OVERLOAD */
if (flags & SVp_IOK) strcat(d, "pIOK,");
if (flags & SVp_NOK) strcat(d, "pNOK,");
if (flags & SVp_POK) strcat(d, "pPOK,");
if (flags & SVp_SCREAM) strcat(d, "SCREAM,");
+
+ switch (type) {
+ case SVt_PVCV:
+ if (CvANON(sv)) strcat(d, "ANON,");
+ if (CvCLONE(sv)) strcat(d, "CLONE,");
+ if (CvCLONED(sv)) strcat(d, "CLONED,");
+ break;
+ case SVt_PVGV:
+ if (GvMULTI(sv)) strcat(d, "MULTI,");
+ #ifdef OVERLOAD
+ if (flags & SVpgv_AM) strcat(d, "withOVERLOAD,");
+ #endif /* OVERLOAD */
+ }
+
d += strlen(d);
if (d[-1] == ',')
d--;
*d++ = ')';
*d = '\0';
! fprintf(Perl_debug_log, "SV = ");
switch (type) {
case SVt_NULL:
! fprintf(Perl_debug_log,"NULL%s\n", tmpbuf);
return;
case SVt_IV:
! fprintf(Perl_debug_log,"IV%s\n", tmpbuf);
break;
case SVt_NV:
! fprintf(Perl_debug_log,"NV%s\n", tmpbuf);
break;
case SVt_RV:
! fprintf(Perl_debug_log,"RV%s\n", tmpbuf);
break;
case SVt_PV:
! fprintf(Perl_debug_log,"PV%s\n", tmpbuf);
break;
case SVt_PVIV:
! fprintf(Perl_debug_log,"PVIV%s\n", tmpbuf);
break;
case SVt_PVNV:
! fprintf(Perl_debug_log,"PVNV%s\n", tmpbuf);
break;
case SVt_PVBM:
! fprintf(Perl_debug_log,"PVBM%s\n", tmpbuf);
break;
case SVt_PVMG:
! fprintf(Perl_debug_log,"PVMG%s\n", tmpbuf);
break;
case SVt_PVLV:
! fprintf(Perl_debug_log,"PVLV%s\n", tmpbuf);
break;
case SVt_PVAV:
! fprintf(Perl_debug_log,"PVAV%s\n", tmpbuf);
break;
case SVt_PVHV:
! fprintf(Perl_debug_log,"PVHV%s\n", tmpbuf);
break;
case SVt_PVCV:
! fprintf(Perl_debug_log,"PVCV%s\n", tmpbuf);
break;
case SVt_PVGV:
! fprintf(Perl_debug_log,"PVGV%s\n", tmpbuf);
break;
case SVt_PVFM:
! fprintf(Perl_debug_log,"PVFM%s\n", tmpbuf);
break;
case SVt_PVIO:
! fprintf(Perl_debug_log,"PVIO%s\n", tmpbuf);
break;
default:
! fprintf(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));
if (SvROK(sv)) {
! fprintf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv));
sv_dump(SvRV(sv));
return;
}
***************
*** 3533,3635 ****
return;
if (type <= SVt_PVLV) {
if (SvPVX(sv))
! fprintf(stderr, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n",
(long)SvPVX(sv), SvPVX(sv), (long)SvCUR(sv), (long)SvLEN(sv));
else
! fprintf(stderr, " PV = 0\n");
}
if (type >= SVt_PVMG) {
if (SvMAGIC(sv)) {
! fprintf(stderr, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv));
}
if (SvSTASH(sv))
! fprintf(stderr, " STASH = %s\n", HvNAME(SvSTASH(sv)));
}
switch (type) {
case SVt_PVLV:
! fprintf(stderr, " TYPE = %c\n", LvTYPE(sv));
! fprintf(stderr, " TARGOFF = %ld\n", (long)LvTARGOFF(sv));
! fprintf(stderr, " TARGLEN = %ld\n", (long)LvTARGLEN(sv));
! fprintf(stderr, " TARG = 0x%lx\n", (long)LvTARG(sv));
sv_dump(LvTARG(sv));
break;
case SVt_PVAV:
! fprintf(stderr, " ARRAY = 0x%lx\n", (long)AvARRAY(sv));
! fprintf(stderr, " ALLOC = 0x%lx\n", (long)AvALLOC(sv));
! fprintf(stderr, " FILL = %ld\n", (long)AvFILL(sv));
! fprintf(stderr, " MAX = %ld\n", (long)AvMAX(sv));
! fprintf(stderr, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv));
flags = AvFLAGS(sv);
d = tmpbuf;
if (flags & AVf_REAL) strcat(d, "REAL,");
if (flags & AVf_REIFY) strcat(d, "REIFY,");
if (flags & AVf_REUSED) strcat(d, "REUSED,");
if (*d)
d[strlen(d)-1] = '\0';
! fprintf(stderr, " FLAGS = (%s)\n", d);
break;
case SVt_PVHV:
! fprintf(stderr, " ARRAY = 0x%lx\n",(long)HvARRAY(sv));
! fprintf(stderr, " KEYS = %ld\n", (long)HvKEYS(sv));
! fprintf(stderr, " FILL = %ld\n", (long)HvFILL(sv));
! fprintf(stderr, " MAX = %ld\n", (long)HvMAX(sv));
! fprintf(stderr, " RITER = %ld\n", (long)HvRITER(sv));
! fprintf(stderr, " EITER = 0x%lx\n",(long) HvEITER(sv));
if (HvPMROOT(sv))
! fprintf(stderr, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv));
if (HvNAME(sv))
! fprintf(stderr, " NAME = \"%s\"\n", HvNAME(sv));
break;
case SVt_PVFM:
case SVt_PVCV:
! fprintf(stderr, " STASH = 0x%lx\n", (long)CvSTASH(sv));
! fprintf(stderr, " START = 0x%lx\n", (long)CvSTART(sv));
! fprintf(stderr, " ROOT = 0x%lx\n", (long)CvROOT(sv));
! fprintf(stderr, " XSUB = 0x%lx\n", (long)CvXSUB(sv));
! fprintf(stderr, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32);
! fprintf(stderr, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv));
! fprintf(stderr, " DEPTH = %ld\n", (long)CvDEPTH(sv));
! fprintf(stderr, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv));
! fprintf(stderr, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv));
if (type == SVt_PVFM)
! fprintf(stderr, " LINES = %ld\n", (long)FmLINES(sv));
break;
case SVt_PVGV:
! fprintf(stderr, " NAME = %s\n", GvNAME(sv));
! fprintf(stderr, " NAMELEN = %ld\n", (long)GvNAMELEN(sv));
! fprintf(stderr, " STASH = 0x%lx\n", (long)GvSTASH(sv));
! fprintf(stderr, " GP = 0x%lx\n", (long)GvGP(sv));
! fprintf(stderr, " SV = 0x%lx\n", (long)GvSV(sv));
! fprintf(stderr, " REFCNT = %ld\n", (long)GvREFCNT(sv));
! fprintf(stderr, " IO = 0x%lx\n", (long)GvIOp(sv));
! fprintf(stderr, " FORM = 0x%lx\n", (long)GvFORM(sv));
! fprintf(stderr, " AV = 0x%lx\n", (long)GvAV(sv));
! fprintf(stderr, " HV = 0x%lx\n", (long)GvHV(sv));
! fprintf(stderr, " CV = 0x%lx\n", (long)GvCV(sv));
! fprintf(stderr, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv));
! fprintf(stderr, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv));
! fprintf(stderr, " LINE = %ld\n", (long)GvLINE(sv));
! fprintf(stderr, " FLAGS = 0x%x\n", (int)GvFLAGS(sv));
! fprintf(stderr, " STASH = 0x%lx\n", (long)GvSTASH(sv));
! fprintf(stderr, " EGV = 0x%lx\n", (long)GvEGV(sv));
break;
case SVt_PVIO:
! fprintf(stderr, " IFP = 0x%lx\n", (long)IoIFP(sv));
! fprintf(stderr, " OFP = 0x%lx\n", (long)IoOFP(sv));
! fprintf(stderr, " DIRP = 0x%lx\n", (long)IoDIRP(sv));
! fprintf(stderr, " LINES = %ld\n", (long)IoLINES(sv));
! fprintf(stderr, " PAGE = %ld\n", (long)IoPAGE(sv));
! fprintf(stderr, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv));
! fprintf(stderr, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv));
! fprintf(stderr, " TOP_NAME = %s\n", IoTOP_NAME(sv));
! fprintf(stderr, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv));
! fprintf(stderr, " FMT_NAME = %s\n", IoFMT_NAME(sv));
! fprintf(stderr, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv));
! fprintf(stderr, " BOTTOM_NAME = %s\n", IoBOTTOM_NAME(sv));
! fprintf(stderr, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv));
! fprintf(stderr, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv));
! fprintf(stderr, " TYPE = %c\n", IoTYPE(sv));
! fprintf(stderr, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv));
break;
}
}
--- 3590,3701 ----
return;
if (type <= SVt_PVLV) {
if (SvPVX(sv))
! fprintf(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");
}
if (type >= SVt_PVMG) {
if (SvMAGIC(sv)) {
! fprintf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv));
}
if (SvSTASH(sv))
! fprintf(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));
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));
flags = AvFLAGS(sv);
d = tmpbuf;
+ *d = '\0';
if (flags & AVf_REAL) strcat(d, "REAL,");
if (flags & AVf_REIFY) strcat(d, "REIFY,");
if (flags & AVf_REUSED) strcat(d, "REUSED,");
if (*d)
d[strlen(d)-1] = '\0';
! fprintf(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));
if (HvPMROOT(sv))
! fprintf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv));
if (HvNAME(sv))
! fprintf(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));
! if (CvGV(sv) && GvNAME(CvGV(sv))) {
! fprintf(stderr, " \"%s\"\n", GvNAME(CvGV(sv)));
! } else {
! fprintf(stderr, "\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));
if (type == SVt_PVFM)
! fprintf(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));
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));
break;
}
}
#~ Add shared hash key support
diff -Pcr perl5_003/sv.h perl5_003_01/sv.h
*** perl5_003/sv.h Mon Mar 25 01:05:36 1996
--- perl5_003_01/sv.h Tue Jun 18 21:47:09 1996
***************
*** 129,134 ****
--- 129,136 ----
#define SVpbm_CASEFOLD 0x40000000
#define SVpbm_TAIL 0x20000000
+ #define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */
+
#ifdef OVERLOAD
#define SVpgv_AM 0x40000000
/* #define SVpgv_badAM 0x20000000 */
#~ Mention when tests were skipped instead of passed
diff -Pcr perl5_003/t/TEST perl5_003_01/t/TEST
*** perl5_003/t/TEST Mon Mar 25 01:05:41 1996
--- perl5_003_01/t/TEST Tue Jul 9 12:11:22 1996
***************
*** 80,87 ****
}
$next = $next - 1;
if ($ok && $next == $max) {
! print "ok\n";
! $good = $good + 1;
} else {
$next += 1;
print "FAILED on test $next\n";
--- 80,92 ----
}
$next = $next - 1;
if ($ok && $next == $max) {
! if ($max) {
! print "ok\n";
! $good = $good + 1;
! } else {
! print "skipping test on this platform\n";
! $files -= 1;
! }
} else {
$next += 1;
print "FAILED on test $next\n";
#~ Add tests to check treatment of numbers between 0 and -1
diff -Pcr perl5_003/t/cmd/mod.t perl5_003_01/t/cmd/mod.t
*** perl5_003/t/cmd/mod.t Mon Mar 25 01:05:37 1996
--- perl5_003_01/t/cmd/mod.t Wed May 1 15:08:47 1996
***************
*** 2,8 ****
# $RCSfile: mod.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:11 $
! print "1..7\n";
print "ok 1\n" if 1;
print "not ok 1\n" unless 1;
--- 2,8 ----
# $RCSfile: mod.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:11 $
! print "1..11\n";
print "ok 1\n" if 1;
print "not ok 1\n" unless 1;
***************
*** 31,33 ****
--- 31,47 ----
$x = 0;
$x++ while <foo>;
print $x > 50 && $x < 1000 ? "ok 7\n" : "not ok 7\n";
+
+ $x = -0.5;
+ print "not " if scalar($x) < 0 and $x >= 0;
+ print "ok 8\n";
+
+ print "not " unless (-(-$x) < 0) == ($x < 0);
+ print "ok 9\n";
+
+ print "ok 10\n" if $x < 0;
+ print "not ok 10\n" unless $x < 0;
+
+ print "ok 11\n" unless $x > 0;
+ print "not ok 11\n" if $x > 0;
+
#~ Updated as part of DB_File update
diff -Pcr perl5_003/t/lib/db-btree.t perl5_003_01/t/lib/db-btree.t
*** perl5_003/t/lib/db-btree.t Sat Jan 20 01:00:26 1996
--- perl5_003_01/t/lib/db-btree.t Fri Jul 5 18:45:38 1996
***************
*** 12,27 ****
use DB_File;
use Fcntl;
! print "1..76\n";
! $Dfile = "Op.db-btree";
unlink $Dfile;
umask(0);
# Check the interface to BTREEINFO
! $dbh = TIEHASH DB_File::BTREEINFO ;
print (($dbh->{flags} == undef) ? "ok 1\n" : "not ok 1\n") ;
print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ;
print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ;
--- 12,28 ----
use DB_File;
use Fcntl;
! print "1..86\n";
! $Dfile = "dbbtree.tmp";
unlink $Dfile;
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") ;
***************
*** 57,65 ****
# Check that an invalid entry is caught both for store & fetch
eval '$dbh->{fred} = 1234' ;
! print ($@ eq '' ? "ok 17\n" : "not ok 17\n") ;
eval '$q = $dbh->{fred}' ;
! print ($@ eq '' ? "ok 18\n" : "not ok 18\n") ;
# Now check the interface to BTREE
--- 58,66 ----
# 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") ;
eval '$q = $dbh->{fred}' ;
! print ($@ =~ /^DB_File::BTREEINFO::FETCH - Unknown element 'fred' at/ ? "ok 18\n" : "not ok 18\n") ;
# Now check the interface to BTREE
***************
*** 77,83 ****
$h{'goner1'} = 'snork';
$h{'abc'} = 'ABC';
! print ($h{'abc'} == 'ABC' ? "ok 22\n" : "not ok 22\n") ;
print (defined $h{'jimmy'} ? "not ok 23\n" : "ok 23\n");
$h{'def'} = 'DEF';
--- 78,84 ----
$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");
$h{'def'} = 'DEF';
***************
*** 152,158 ****
if ($i == 30) {print "ok 26\n";} else {print "not ok 26\n";}
! @keys = ('blurfl', keys(h), 'dyick');
if ($#keys == 31) {print "ok 27\n";} else {print "not ok 27\n";}
#Check that the keys can be retrieved in order
--- 153,159 ----
if ($i == 30) {print "ok 26\n";} else {print "not ok 26\n";}
! @keys = ('blurfl', keys(%h), 'dyick');
if ($#keys == 31) {print "ok 27\n";} else {print "not ok 27\n";}
#Check that the keys can be retrieved in order
***************
*** 345,353 ****
--- 346,398 ----
$status = $Y->fd ;
print ($status == -1 ? "ok 73\n" : "not ok 73\n") ;
+
undef $Y ;
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");
+
+ $hh{'Wall'} = 'Larry' ;
+ $hh{'Wall'} = 'Stone' ; # Note the duplicate key
+ $hh{'Wall'} = 'Brick' ; # Note the duplicate key
+ $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") ;
+
+ # now in list context
+ my @unknown = $YY->get_dup('Unknown') ;
+ print( "@unknown" eq "" ? "ok 78\n" : "not ok 78\n") ;
+
+ my @smith = $YY->get_dup('Smith') ;
+ print( "@smith" eq "John" ? "ok 79\n" : "not ok 79\n") ;
+
+ 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") ;
+
+ # hash
+ my %unknown = $YY->get_dup('Unknown', 1) ;
+ print( keys %unknown == 0 ? "ok 81\n" : "not ok 81\n") ;
+
+ my %smith = $YY->get_dup('Smith', 1) ;
+ print( (keys %smith == 1 && $smith{'John'}) ? "ok 82\n" : "not ok 82\n") ;
+
+ my %wall = $YY->get_dup('Wall', 1) ;
+ print( (keys %wall == 3 && $wall{'Larry'} && $wall{'Stone'} && $wall{'Brick'}) ? "ok 83\n" : "not ok 83\n") ;
+
+ undef $YY ;
+ untie %hh ;
+ unlink $Dfile;
+
+
# test multiple callbacks
$Dfile1 = "btree1" ;
$Dfile2 = "btree2" ;
***************
*** 392,400 ****
1 ;
}
! print ( ArrayCompare (\@srt_1, [keys %h]) ? "ok 74\n" : "not ok 74\n") ;
! print ( ArrayCompare (\@srt_2, [keys %g]) ? "ok 75\n" : "not ok 75\n") ;
! print ( ArrayCompare (\@srt_3, [keys %k]) ? "ok 76\n" : "not ok 76\n") ;
untie %h ;
untie %g ;
--- 437,445 ----
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") ;
untie %h ;
untie %g ;
#~ Updated as part of DB_File update
diff -Pcr perl5_003/t/lib/db-hash.t perl5_003_01/t/lib/db-hash.t
*** perl5_003/t/lib/db-hash.t Tue Oct 18 12:44:07 1994
--- perl5_003_01/t/lib/db-hash.t Fri Jul 5 18:45:41 1996
***************
*** 14,27 ****
print "1..43\n";
! $Dfile = "Op.db-hash";
unlink $Dfile;
umask(0);
# Check the interface to HASHINFO
! $dbh = TIEHASH DB_File::HASHINFO ;
print (($dbh->{bsize} == undef) ? "ok 1\n" : "not ok 1\n") ;
print (($dbh->{ffactor} == undef) ? "ok 2\n" : "not ok 2\n") ;
print (($dbh->{nelem} == undef) ? "ok 3\n" : "not ok 3\n") ;
--- 14,28 ----
print "1..43\n";
! $Dfile = "dbhash.tmp";
unlink $Dfile;
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") ;
***************
*** 49,57 ****
# Check that an invalid entry is caught both for store & fetch
eval '$dbh->{fred} = 1234' ;
! print ($@ eq '' ? "ok 13\n" : "not ok 13\n") ;
eval '$q = $dbh->{fred}' ;
! print ($@ eq '' ? "ok 14\n" : "not ok 14\n") ;
# Now check the interface to HASH
--- 50,58 ----
# 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") ;
# Now check the interface to HASH
***************
*** 69,75 ****
$h{'goner1'} = 'snork';
$h{'abc'} = 'ABC';
! print ($h{'abc'} == 'ABC' ? "ok 18\n" : "not ok 18\n") ;
print (defined $h{'jimmy'} ? "not ok 19\n" : "ok 19\n");
$h{'def'} = 'DEF';
--- 70,76 ----
$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");
$h{'def'} = 'DEF';
***************
*** 135,141 ****
if ($#keys == 29 && $#values == 29) {print "ok 21\n";} else {print "not ok 21\n";}
! while (($key,$value) = each(h)) {
if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
$key =~ y/a-z/A-Z/;
$i++ if $key eq $value;
--- 136,142 ----
if ($#keys == 29 && $#values == 29) {print "ok 21\n";} else {print "not ok 21\n";}
! while (($key,$value) = each(%h)) {
if ($key eq $keys[$i] && $value eq $values[$i] && $key gt $value) {
$key =~ y/a-z/A-Z/;
$i++ if $key eq $value;
***************
*** 144,150 ****
if ($i == 30) {print "ok 22\n";} else {print "not ok 22\n";}
! @keys = ('blurfl', keys(h), 'dyick');
if ($#keys == 31) {print "ok 23\n";} else {print "not ok 23\n";}
$h{'foo'} = '';
--- 145,151 ----
if ($i == 30) {print "ok 22\n";} else {print "not ok 22\n";}
! @keys = ('blurfl', keys(%h), 'dyick');
if ($#keys == 31) {print "ok 23\n";} else {print "not ok 23\n";}
$h{'foo'} = '';
#~ Updated as part of DB_File update
diff -Pcr perl5_003/t/lib/db-recno.t perl5_003_01/t/lib/db-recno.t
*** perl5_003/t/lib/db-recno.t Tue Oct 18 12:44:09 1994
--- perl5_003_01/t/lib/db-recno.t Fri Jul 5 18:45:43 1996
***************
*** 11,34 ****
use DB_File;
use Fcntl;
! print "1..30\n";
! $Dfile = "Op.db-recno";
! unlink $Dfile;
umask(0);
# Check the interface to RECNOINFO
! $dbh = TIEHASH DB_File::RECNOINFO ;
! print (($dbh->{bval} == undef) ? "ok 1\n" : "not ok 1\n") ;
! print (($dbh->{cachesize} == undef) ? "ok 2\n" : "not ok 2\n") ;
! print (($dbh->{psize} == undef) ? "ok 3\n" : "not ok 3\n") ;
! print (($dbh->{flags} == undef) ? "ok 4\n" : "not ok 4\n") ;
! print (($dbh->{lorder} == undef) ? "ok 5\n" : "not ok 5\n") ;
! print (($dbh->{reclen} == undef) ? "ok 6\n" : "not ok 6\n") ;
! print (($dbh->{bfname} == undef) ? "ok 7\n" : "not ok 7\n") ;
$dbh->{bval} = 3000 ;
print ($dbh->{bval} == 3000 ? "ok 8\n" : "not ok 8\n") ;
--- 11,45 ----
use DB_File;
use Fcntl;
+ use strict ;
+ use vars qw($dbh $Dfile) ;
! sub ok
! {
! my $no = shift ;
! my $result = shift ;
!
! print "not " unless $result ;
! print "ok $no\n" ;
! }
! print "1..35\n";
!
! my $Dfile = "recno.tmp";
! unlink $Dfile ;
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);
$dbh->{bval} = 3000 ;
print ($dbh->{bval} == 3000 ? "ok 8\n" : "not ok 8\n") ;
***************
*** 54,80 ****
# Check that an invalid entry is caught both for store & fetch
eval '$dbh->{fred} = 1234' ;
! print ($@ eq '' ? "ok 15\n" : "not ok 15\n") ;
! eval '$q = $dbh->{fred}' ;
! print ($@ eq '' ? "ok 16\n" : "not ok 16\n") ;
# Now check the interface to RECNOINFO
! print (($X = tie(@h, DB_File,$Dfile, O_RDWR|O_CREAT, 0640, $DB_RECNO )) ? "ok 17\n" : "not ok 17");
! ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,
! $blksize,$blocks) = stat($Dfile);
! print (($mode & 0777) == 0640 ? "ok 18\n" : "not ok 18\n");
! #$l = @h ;
! $l = $X->length ;
print (!$l ? "ok 19\n" : "not ok 19\n");
! @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") ;
foreach (@data)
{ $h[++$i] = $_ }
--- 65,93 ----
# 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") ;
! eval 'my $q = $dbh->{fred}' ;
! print ($@ =~ /^DB_File::RECNOINFO::FETCH - Unknown element 'fred' at/ ? "ok 16\n" : "not ok 16\n") ;
# 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) ;
! #my $l = @h ;
! my $l = $X->length ;
print (!$l ? "ok 19\n" : "not ok 19\n");
! 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") ;
+ my $ i;
foreach (@data)
{ $h[++$i] = $_ }
***************
*** 91,97 ****
print ($h[3] eq 'replaced' ? "ok 24\n" : "not ok 24\n");
#PUSH
! @push_data = qw(added to the end) ;
#push (@h, @push_data) ;
$X->push(@push_data) ;
push (@data, @push_data) ;
--- 104,110 ----
print ($h[3] eq 'replaced' ? "ok 24\n" : "not ok 24\n");
#PUSH
! my @push_data = qw(added to the end) ;
#push (@h, @push_data) ;
$X->push(@push_data) ;
push (@data, @push_data) ;
***************
*** 100,106 ****
# POP
pop (@data) ;
#$value = pop(@h) ;
! $value = $X->pop ;
print ($value eq 'end' ? "not ok 26\n" : "ok 26\n");
# SHIFT
--- 113,119 ----
# POP
pop (@data) ;
#$value = pop(@h) ;
! my $value = $X->pop ;
print ($value eq 'end' ? "not ok 26\n" : "ok 26\n");
# SHIFT
***************
*** 114,120 ****
$X->unshift ;
print ($X->length == @data ? "ok 28\n" : "not ok 28\n") ;
! @new_data = qw(add this to the start of the array) ;
#unshift @h, @new_data ;
$X->unshift (@new_data) ;
unshift (@data, @new_data) ;
--- 127,133 ----
$X->unshift ;
print ($X->length == @data ? "ok 28\n" : "not ok 28\n") ;
! my @new_data = qw(add this to the start of the array) ;
#unshift @h, @new_data ;
$X->unshift (@new_data) ;
unshift (@data, @new_data) ;
***************
*** 124,136 ****
# Now both arrays should be identical
! $ok = 1 ;
! $j = 0 ;
foreach (@data)
{
$ok = 0, last if $_ ne $h[$j ++] ;
}
print ($ok ? "ok 30\n" : "not ok 30\n") ;
# IMPORTANT - $X must be undefined before the untie otherwise the
# underlying DB close routine will not get called.
--- 137,164 ----
# Now both arrays should be identical
! my $ok = 1 ;
! my $j = 0 ;
foreach (@data)
{
$ok = 0, last if $_ ne $h[$j ++] ;
}
print ($ok ? "ok 30\n" : "not ok 30\n") ;
+
+ # 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") ;
+
+ # 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") ;
+
+ # 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") ;
# IMPORTANT - $X must be undefined before the untie otherwise the
# underlying DB close routine will not get called.
#~ Check for readdir() directly, rather than more general POSIX test
#~ sort results of glob expansion for better alignment with readdir results
diff -Pcr perl5_003/t/lib/dirhand.t perl5_003_01/t/lib/dirhand.t
*** perl5_003/t/lib/dirhand.t Mon Jan 29 18:30:50 1996
--- perl5_003_01/t/lib/dirhand.t Tue Jul 23 07:11:25 1996
***************
*** 4,10 ****
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
! if ($Config{'extensions'} !~ /\bPOSIX\b/) {
print "1..0\n";
exit 0;
}
--- 4,10 ----
chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
! if (not $Config{'d_readdir'}) {
print "1..0\n";
exit 0;
}
***************
*** 17,23 ****
$dot = new DirHandle ".";
print defined($dot) ? "ok" : "not ok", " 1\n";
! @a = <*>;
do { $first = $dot->read } while defined($first) && $first =~ /^\./;
print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n";
--- 17,23 ----
$dot = new DirHandle ".";
print defined($dot) ? "ok" : "not ok", " 1\n";
! @a = sort <*>;
do { $first = $dot->read } while defined($first) && $first =~ /^\./;
print +(grep { $_ eq $first } @a) ? "ok" : "not ok", " 2\n";
#~ Can't call FileHandle methods on unblessed file handle, since
#~ IO::Handle is now the default class
diff -Pcr perl5_003/t/lib/filehand.t perl5_003_01/t/lib/filehand.t
*** perl5_003/t/lib/filehand.t Mon Mar 25 01:05:37 1996
--- perl5_003_01/t/lib/filehand.t Thu Jul 18 14:17:40 1996
***************
*** 14,20 ****
use strict subs;
$mystdout = new_from_fd FileHandle 1,"w";
! autoflush STDOUT;
autoflush $mystdout;
print "1..4\n";
--- 14,20 ----
use strict subs;
$mystdout = new_from_fd FileHandle 1,"w";
! $| = 1;
autoflush $mystdout;
print "1..4\n";
***************
*** 24,35 ****
$buffer = <$fh>;
print $buffer eq "#!./perl\n" ? "ok 3\n" : "not ok 3\n";
! if ($^O eq 'VMS') {
! ungetc $fh 65;
! CORE::read($fh, $buf,1);
! }
! else {
! ungetc STDIN 65;
! CORE::read(STDIN, $buf,1);
! }
print $buf eq 'A' ? "ok 4\n" : "not ok 4\n";
--- 24,29 ----
$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";
#~ Add tests for new IO extension
diff -Pcr perl5_003/t/lib/io_dup.t perl5_003_01/t/lib/io_dup.t
*** perl5_003/t/lib/io_dup.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/t/lib/io_dup.t Wed Jul 10 14:01:25 1996
***************
*** 0 ****
--- 1,45 ----
+ #!./perl
+
+ BEGIN {
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ use IO::Handle;
+ use IO::File;
+
+ select(STDERR); $| = 1;
+ select(STDOUT); $| = 1;
+
+ print "1..6\n";
+
+ print "ok 1\n";
+
+ $dupout = IO::Handle->new->fdopen( \*STDOUT ,"w");
+ $duperr = IO::Handle->new->fdopen( \*STDERR ,"w");
+
+ $stdout = \*STDOUT; bless $stdout, "IO::File"; # "IO::Handle";
+ $stderr = \*STDERR; bless $stderr, "IO::Handle";
+
+ $stdout->open( "Io.dup","w") || die "Can't open stdout";
+ $stderr->fdopen($stdout,"w");
+
+ print $stdout "ok 2\n";
+ print $stderr "ok 3\n";
+ system 'echo ok 4';
+ system 'echo ok 5 1>&2';
+
+ $stderr->close;
+ $stdout->close;
+
+ $stdout->fdopen($dupout,"w");
+ $stderr->fdopen($duperr,"w");
+
+ system 'cat Io.dup';
+ unlink 'Io.dup';
+
+ print STDOUT "ok 6\n";
#~ Add tests for new IO extension
diff -Pcr perl5_003/t/lib/io_pipe.t perl5_003_01/t/lib/io_pipe.t
*** perl5_003/t/lib/io_pipe.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/t/lib/io_pipe.t Wed Jul 10 14:01:46 1996
***************
*** 0 ****
--- 1,82 ----
+ #!./perl
+
+ BEGIN {
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ use IO::Pipe;
+
+ $| = 1;
+ print "1..6\n";
+
+ $pipe = new IO::Pipe;
+
+ $pid = fork();
+
+ if($pid)
+ {
+ $pipe->writer;
+ print $pipe "Xk 1\n";
+ print $pipe "oY 2\n";
+ $pipe->close;
+ wait;
+ }
+ elsif(defined $pid)
+ {
+ $pipe->reader;
+ $stdin = bless \*STDIN, "IO::Handle";
+ $stdin->fdopen($pipe,"r");
+ exec 'tr', 'YX', 'ko';
+ }
+ else
+ {
+ die;
+ }
+
+ $pipe = new IO::Pipe;
+ $pid = fork();
+
+ if($pid)
+ {
+ $pipe->reader;
+ while(<$pipe>) {
+ s/^not //;
+ print;
+ }
+ $pipe->close;
+ wait;
+ }
+ elsif(defined $pid)
+ {
+ $pipe->writer;
+
+ $stdout = bless \*STDOUT, "IO::Handle";
+ $stdout->fdopen($pipe,"w");
+ print STDOUT "not ok 3\n";
+ exec 'echo', 'not ok 4';
+ }
+ else
+ {
+ die;
+ }
+
+ $pipe = new IO::Pipe;
+ $pipe->writer;
+
+ $SIG{'PIPE'} = 'broken_pipe';
+
+ sub broken_pipe {
+ print "ok 5\n";
+ }
+
+ print $pipe "not ok 5\n";
+ $pipe->close;
+
+
+ print "ok 6\n";
+
#~ Add tests for new IO extension
diff -Pcr perl5_003/t/lib/io_sock.t perl5_003_01/t/lib/io_sock.t
*** perl5_003/t/lib/io_sock.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/t/lib/io_sock.t Wed Jul 10 14:04:02 1996
***************
*** 0 ****
--- 1,75 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ require Config; import Config;
+ if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
+ $Config{'extensions'} !~ /\bIO\b/) &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ $| = 1;
+ print "1..5\n";
+
+ use IO::Socket;
+
+ $port = 4002 + int(rand(time) & 0xff);
+
+ $pid = fork();
+
+ if($pid) {
+
+ $listen = IO::Socket::INET->new(Listen => 2,
+ Proto => 'tcp',
+ LocalPort => $port
+ ) or die "$!";
+
+ print "ok 1\n";
+
+ # Wake out child
+ kill(ALRM => $pid);
+
+ $sock = $listen->accept();
+ print "ok 2\n";
+
+ $sock->autoflush(1);
+ print $sock->getline();
+
+ print $sock "ok 4\n";
+
+ $sock->close;
+
+ waitpid($pid,0);
+
+ print "ok 5\n";
+ } elsif(defined $pid) {
+
+ # 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,
+ Proto => 'tcp',
+ PeerAddr => 'localhost'
+ ) or die "$!";
+
+ $sock->autoflush(1);
+ print $sock "ok 3\n";
+ print $sock->getline();
+ $sock->close;
+ exit;
+ } else {
+ die;
+ }
+
+
+
+
+
+
#~ Add tests for new IO extension
diff -Pcr perl5_003/t/lib/io_tell.t perl5_003_01/t/lib/io_tell.t
*** perl5_003/t/lib/io_tell.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/t/lib/io_tell.t Thu Jul 18 13:35:35 1996
***************
*** 0 ****
--- 1,54 ----
+ #!./perl
+
+ # $RCSfile: tell.t,v $$Revision: 1.1 $$Date: 1996/05/01 10:52:47 $
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bIO\b/ && !($^O eq 'VMS')) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ print "1..13\n";
+
+ use IO::File;
+
+ $tst = IO::File->new("TEST","r") || die("Can't open TEST");
+
+ if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; }
+
+ $firstline = <$tst>;
+ $secondpos = tell;
+
+ $x = 0;
+ while (<$tst>) {
+ if (eof) {$x++;}
+ }
+ if ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
+
+ $lastpos = tell;
+
+ unless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
+
+ if ($tst->seek(0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
+
+ if (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
+
+ if ($firstline eq <$tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
+
+ if ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
+
+ if ($tst->seek(0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
+
+ if ($tst->eof) { print "not ok 9\n"; } else { print "ok 9\n"; }
+
+ if ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
+
+ if ($tst->seek(0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
+
+ if ($lastpos == $tst->tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
+
+ unless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
#~ Add tests for new IO extension
diff -Pcr perl5_003/t/lib/io_udp.t perl5_003_01/t/lib/io_udp.t
*** perl5_003/t/lib/io_udp.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/t/lib/io_udp.t Tue Jul 23 07:13:12 1996
***************
*** 0 ****
--- 1,31 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ require Config; import Config;
+ if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
+ $Config{'extensions'} !~ /\bIO\b/) &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ $| = 1;
+ print "1..3\n";
+
+ use Socket;
+ use IO::Socket qw(AF_INET SOCK_DGRAM INADDR_ANY);
+
+ $udpa = IO::Socket::INET->new(Proto => 'udp', Addr => 'localhost');
+ $udpb = IO::Socket::INET->new(Proto => 'udp', Addr => 'localhost');
+
+ print "ok 1\n";
+
+ $udpa->send("ok 2\n",0,$udpb->sockname);
+ $rem = $udpb->recv($buf="",5);
+ print $buf;
+ $udpb->send("ok 3\n");
+ $udpa->recv($buf="",5);
+ print $buf;
#~ Add tests for new IO extension
diff -Pcr perl5_003/t/lib/io_xs.t perl5_003_01/t/lib/io_xs.t
*** perl5_003/t/lib/io_xs.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/t/lib/io_xs.t Thu Jul 18 13:35:12 1996
***************
*** 0 ****
--- 1,23 ----
+ #!./perl
+ $| = 1;
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bIO\b/ && !($^O eq 'VMS')) {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ use IO::File;
+ use IO::Seekable;
+
+ print "1..2\n";
+ use IO::File;
+ $x = new_tmpfile IO::File or print "not ";
+ print "ok 1\n";
+ print $x "ok 2\n";
+ $x->seek(0,SEEK_SET);
+ print <$x>;
#~ Add tests for new Opcode extension
diff -Pcr perl5_003/t/lib/opcode.t perl5_003_01/t/lib/opcode.t
*** perl5_003/t/lib/opcode.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/t/lib/opcode.t Thu Jul 18 14:24:58 1996
***************
*** 0 ****
--- 1,115 ----
+ #!./perl -w
+
+ $|=1;
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ use Opcode qw(
+ opcodes opdesc opmask verify_opset
+ opset opset_to_ops opset_to_hex invert_opset
+ opmask_add full_opset empty_opset define_optag
+ );
+
+ use strict;
+
+ my $t = 1;
+ my $last_test; # initalised at end
+ print "1..$last_test\n";
+
+ my($s1, $s2, $s3);
+ my(@o1, @o2, @o3);
+
+ # --- opset_to_ops and opset
+
+ my @empty_l = opset_to_ops(empty_opset);
+ print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ my @full_l1 = opset_to_ops(full_opset);
+ print @full_l1 == opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
+ my @full_l2 = @full_l1; # = opcodes(); # XXX to be fixed
+ print "@full_l1" eq "@full_l2" ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ @empty_l = opset_to_ops(opset(':none'));
+ print @empty_l == 0 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ my @full_l3 = opset_to_ops(opset(':all'));
+ print @full_l1 == @full_l3 ? "ok $t\n" : "not ok $t\n"; $t++;
+ print "@full_l1" eq "@full_l3" ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ die $t unless $t == 7;
+ $s1 = opset( 'padsv');
+ $s2 = opset($s1, 'padav');
+ $s3 = opset($s2, '!padav');
+ print $s1 eq $s2 ? "not ok $t\n" : "ok $t\n"; ++$t;
+ print $s1 eq $s3 ? "ok $t\n" : "not ok $t\n"; ++$t;
+
+ # --- define_optag
+
+ print eval { opset(':_tst_') } ? "not ok $t\n" : "ok $t\n"; ++$t;
+ define_optag(":_tst_", opset(qw(padsv padav padhv)));
+ print eval { opset(':_tst_') } ? "ok $t\n" : "not ok $t\n"; ++$t;
+
+ # --- opdesc and opcodes
+
+ die $t unless $t == 11;
+ print opdesc("gv") eq "glob value" ? "ok $t\n" : "not ok $t\n"; $t++;
+ my @desc = opdesc(':_tst_','stub');
+ print "@desc" eq "private variable private array private hash stub"
+ ? "ok $t\n" : "not ok $t\n#@desc\n"; $t++;
+ print opcodes() ? "ok $t\n" : "not ok $t\n"; $t++;
+ print "ok $t\n"; ++$t;
+
+ # --- invert_opset
+
+ $s1 = opset(qw(fileno padsv padav));
+ @o2 = opset_to_ops(invert_opset($s1));
+ print @o2 == opcodes-3 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ # --- opmask
+
+ die $t unless $t == 16;
+ print opmask() eq empty_opset() ? "ok $t\n" : "not ok $t\n"; $t++; # work
+ print length opmask() == int(opcodes()/8)+1 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ # --- verify_opset
+
+ print verify_opset($s1) && !verify_opset(42) ? "ok $t\n":"not ok $t\n"; $t++;
+
+ # --- opmask_add
+
+ opmask_add(opset(qw(fileno))); # add to global op_mask
+ print eval 'fileno STDOUT' ? "not ok $t\n" : "ok $t\n"; $t++; # fail
+ print $@ =~ /fileno trapped/ ? "ok $t\n" : "not ok $t\n# $@\n"; $t++;
+
+ # --- check use of bit vector ops on opsets
+
+ $s1 = opset('padsv');
+ $s2 = opset('padav');
+ $s3 = opset('padsv', 'padav', 'padhv');
+
+ # Non-negated
+ print (($s1 | $s2) eq opset($s1,$s2) ? "ok $t\n":"not ok $t\n"); $t++;
+ print (($s2 & $s3) eq opset($s2) ? "ok $t\n":"not ok $t\n"); $t++;
+ print (($s2 ^ $s3) eq opset('padsv','padhv') ? "ok $t\n":"not ok $t\n"); $t++;
+
+ # Negated, e.g., with possible extra bits in last byte beyond last op bit.
+ # The extra bits mean we can't just say ~mask eq invert_opset(mask).
+
+ @o1 = opset_to_ops( ~ $s3);
+ @o2 = opset_to_ops(invert_opset $s3);
+ print "@o1" eq "@o2" ? "ok $t\n":"not ok $t\n"; $t++;
+
+ # --- finally, check some opname assertions
+
+ foreach(@full_l1) { die "bad opname: $_" if /\W/ or /^\d/ }
+
+ print "ok $last_test\n";
+ BEGIN { $last_test = 25 }
#~ Add tests for new Opcode extension
diff -Pcr perl5_003/t/lib/ops.t perl5_003_01/t/lib/ops.t
*** perl5_003/t/lib/ops.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/t/lib/ops.t Thu Jul 18 14:25:12 1996
***************
*** 0 ****
--- 1,29 ----
+ #!./perl
+
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ print "1..2\n";
+
+ eval <<'EOP';
+ no ops 'fileno'; # equiv to "perl -M-ops=fileno"
+ $a = fileno STDIN;
+ EOP
+
+ print $@ =~ /trapped/ ? "ok 1\n" : "not ok 1\n# $@\n";
+
+ eval <<'EOP';
+ use ops ':default'; # equiv to "perl -M(as above) -Mops=:default"
+ eval 1;
+ EOP
+
+ print $@ =~ /trapped/ ? "ok 2\n" : "not ok 2\n# $@\n";
+
+ 1;
#~ Add tests for new Opcode extension
diff -Pcr perl5_003/t/lib/safe1.t perl5_003_01/t/lib/safe1.t
*** perl5_003/t/lib/safe1.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/t/lib/safe1.t Wed Jul 10 14:06:16 1996
***************
*** 0 ****
--- 1,68 ----
+ #!./perl -w
+ $|=1;
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ # Tests Todo:
+ # 'main' as root
+
+ package test; # test from somewhere other than main
+
+ use vars qw($bar);
+
+ use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
+ opmask_add full_opset empty_opset opcodes opmask define_optag);
+
+ use Safe 1.00;
+
+ my $last_test; # initalised at end
+ print "1..$last_test\n";
+
+ my $t = 1;
+ my $cpt;
+ # create and destroy some automatic Safe compartments first
+ $cpt = new Safe or die;
+ $cpt = new Safe or die;
+ $cpt = new Safe or die;
+
+ $cpt = new Safe "Root" or die;
+
+ foreach(1..3) {
+ $foo = 42;
+
+ $cpt->share(qw($foo));
+
+ print ${$cpt->varglob('foo')} == 42 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ ${$cpt->varglob('foo')} = 9;
+
+ print $foo == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+
+ print $cpt->reval('$foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ # check 'main' has been changed:
+ print $cpt->reval('$::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ print $cpt->reval('$main::foo') == 9 ? "ok $t\n" : "not ok $t\n"; $t++;
+ # check we can't see our test package:
+ print $cpt->reval('$test::foo') ? "not ok $t\n" : "ok $t\n"; $t++;
+ print $cpt->reval('${"test::foo"}') ? "not ok $t\n" : "ok $t\n"; $t++;
+
+ $cpt->erase; # erase the compartment, e.g., delete all variables
+
+ print $cpt->reval('$foo') ? "not ok $t\n" : "ok $t\n"; $t++;
+
+ # Note that we *must* use $cpt->varglob here because if we used
+ # $Root::foo etc we would still see the original values!
+ # This seems to be because the compiler has created an extra ref.
+
+ print ${$cpt->varglob('foo')} ? "not ok $t\n" : "ok $t\n"; $t++;
+ }
+
+ print "ok $last_test\n";
+ BEGIN { $last_test = 28 }
#~ Add tests for new Opcode extension
diff -Pcr perl5_003/t/lib/safe2.t perl5_003_01/t/lib/safe2.t
*** perl5_003/t/lib/safe2.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/t/lib/safe2.t Thu Jul 18 14:32:29 1996
***************
*** 0 ****
--- 1,140 ----
+ #!./perl -w
+ $|=1;
+ BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require Config; import Config;
+ if ($Config{'extensions'} !~ /\bOpcode\b/ && $Config{'osname'} ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
+ }
+
+ # Tests Todo:
+ # 'main' as root
+
+ use vars qw($bar);
+
+ use Opcode 1.00, qw(opdesc opset opset_to_ops opset_to_hex
+ opmask_add full_opset empty_opset opcodes opmask define_optag);
+
+ use Safe 1.00;
+
+ my $last_test; # initalised at end
+ print "1..$last_test\n";
+
+ # Set up a package namespace of things to be visible to the unsafe code
+ $Root::foo = "visible";
+ $bar = "invisible";
+
+ # Stop perl from moaning about identifies which are apparently only used once
+ $Root::foo .= "";
+
+ my $cpt;
+ # create and destroy a couple of automatic Safe compartments first
+ $cpt = new Safe or die;
+ $cpt = new Safe or die;
+
+ $cpt = new Safe "Root";
+
+ $cpt->reval(q{ system("echo not ok 1"); });
+ if ($@ =~ /^system trapped by operation mask/) {
+ print "ok 1\n";
+ } else {
+ print "#$@" if $@;
+ print "not ok 1\n";
+ }
+
+ $cpt->reval(q{
+ print $foo eq 'visible' ? "ok 2\n" : "not ok 2\n";
+ print $main::foo eq 'visible' ? "ok 3\n" : "not ok 3\n";
+ print defined($bar) ? "not ok 4\n" : "ok 4\n";
+ print defined($::bar) ? "not ok 5\n" : "ok 5\n";
+ print defined($main::bar) ? "not ok 6\n" : "ok 6\n";
+ });
+ print $@ ? "not ok 7\n#$@" : "ok 7\n";
+
+ $foo = "ok 8\n";
+ %bar = (key => "ok 9\n");
+ @baz = (); push(@baz, "o", "10"); $" = 'k ';
+ $glob = "ok 11\n";
+ @glob = qw(not ok 16);
+
+ sub sayok { print "ok @_\n" }
+
+ $cpt->share(qw($foo %bar @baz *glob sayok $"));
+
+ $cpt->reval(q{
+ package other;
+ sub other_sayok { print "ok @_\n" }
+ package main;
+ print $foo ? $foo : "not ok 8\n";
+ print $bar{key} ? $bar{key} : "not ok 9\n";
+ (@baz) ? print "@baz\n" : print "not ok 10\n";
+ print $glob;
+ other::other_sayok(12);
+ $foo =~ s/8/14/;
+ $bar{new} = "ok 15\n";
+ @glob = qw(ok 16);
+ });
+ print $@ ? "not ok 13\n#$@" : "ok 13\n";
+ $" = ' ';
+ print $foo, $bar{new}, "@glob\n";
+
+ $Root::foo = "not ok 17";
+ @{$cpt->varglob('bar')} = qw(not ok 18);
+ ${$cpt->varglob('foo')} = "ok 17";
+ @Root::bar = "ok";
+ push(@Root::bar, "18"); # Two steps to prevent "Identifier used only once..."
+
+ print "$Root::foo\n";
+ print "@{$cpt->varglob('bar')}\n";
+
+ use strict;
+
+ print 1 ? "ok 19\n" : "not ok 19\n";
+ print 1 ? "ok 20\n" : "not ok 20\n";
+
+ my $m1 = $cpt->mask;
+ $cpt->trap("negate");
+ my $m2 = $cpt->mask;
+ my @masked = opset_to_ops($m1);
+ print $m2 eq opset("negate", @masked) ? "ok 21\n" : "not ok 21\n";
+
+ print eval { $cpt->mask("a bad mask") } ? "not ok 22\n" : "ok 22\n";
+
+ print $cpt->reval("2 + 2") == 4 ? "ok 23\n" : "not ok 23\n";
+
+ $cpt->mask(empty_opset);
+ my $t_scalar = $cpt->reval('print wantarray ? "not ok 24\n" : "ok 24\n"');
+ print $cpt->reval('@ary=(6,7,8);@ary') == 3 ? "ok 25\n" : "not ok 25\n";
+ my @t_array = $cpt->reval('print wantarray ? "ok 26\n" : "not ok 26\n"; (2,3,4)');
+ print $t_array[2] == 4 ? "ok 27\n" : "not ok 27\n";
+
+ my $t_scalar2 = $cpt->reval('die "foo bar"; 1');
+ print defined $t_scalar2 ? "not ok 28\n" : "ok 28\n";
+ print $@ =~ /foo bar/ ? "ok 29\n" : "not ok 29\n";
+
+ # --- rdo
+
+ my $t = 30;
+ $cpt->rdo('/non/existant/file.name');
+ print +(($! =~ /No such file/ || $! =~ /file specification syntax error/) ?
+ "ok $t\n" : "not ok $t # $!\n"); $t++;
+ print 1 ? "ok $t\n" : "not ok $t\n#$@/$!\n"; $t++;
+
+ #my $rdo_file = "tmp_rdo.tpl";
+ #if (open X,">$rdo_file") {
+ # print X "999\n";
+ # close X;
+ # $cpt->permit_only('const', 'leaveeval');
+ # print $cpt->rdo($rdo_file) == 999 ? "ok $t\n" : "not ok $t\n"; $t++;
+ # unlink $rdo_file;
+ #}
+ #else {
+ # print "# test $t skipped, can't open file: $!\nok $t\n"; $t++;
+ #}
+
+
+ print "ok $last_test\n";
+ BEGIN { $last_test = 32 }
#~ Update name of %Config value under VMS
diff -Pcr perl5_003/t/lib/socket.t perl5_003_01/t/lib/socket.t
*** perl5_003/t/lib/socket.t Mon Mar 25 01:05:40 1996
--- perl5_003_01/t/lib/socket.t Mon Jun 17 19:22:51 1996
***************
*** 5,11 ****
@INC = '../lib' if -d '../lib';
require Config; import Config;
if ($Config{'extensions'} !~ /\bSocket\b/ &&
! !(($^O eq 'VMS') && $Config{d_has_socket})) {
print "1..0\n";
exit 0;
}
--- 5,11 ----
@INC = '../lib' if -d '../lib';
require Config; import Config;
if ($Config{'extensions'} !~ /\bSocket\b/ &&
! !(($^O eq 'VMS') && $Config{d_socket})) {
print "1..0\n";
exit 0;
}
#~ Added tests for multicharacter record delimiters
diff -Pcr perl5_003/t/op/chop.t perl5_003_01/t/op/chop.t
*** perl5_003/t/op/chop.t Tue Oct 18 12:44:35 1994
--- perl5_003_01/t/op/chop.t Mon Jun 17 19:37:49 1996
***************
*** 2,8 ****
# $RCSfile: chop.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:40 $
! print "1..22\n";
# optimized
--- 2,8 ----
# $RCSfile: chop.t,v $$Revision: 4.1 $$Date: 92/08/07 18:27:40 $
! print "1..28\n";
# optimized
***************
*** 70,72 ****
--- 70,87 ----
$/ = "";
print chomp() == 0 ? "ok 21\n" : "not ok 21\n";
print $_ eq "f" ? "ok 22\n" : "not ok 22\n";
+
+ $_ = "xx";
+ $/ = "xx";
+ print chomp() == 2 ? "ok 23\n" : "not ok 23\n";
+ print $_ eq "" ? "ok 24\n" : "not ok 24\n";
+
+ $_ = "axx";
+ $/ = "xx";
+ print chomp() == 2 ? "ok 25\n" : "not ok 25\n";
+ print $_ eq "a" ? "ok 26\n" : "not ok 26\n";
+
+ $_ = "axx";
+ $/ = "yy";
+ print chomp() == 0 ? "ok 27\n" : "not ok 27\n";
+ print $_ eq "axx" ? "ok 28\n" : "not ok 28\n";
#~ Consider alternate location for system groups command
diff -Pcr perl5_003/t/op/groups.t perl5_003_01/t/op/groups.t
*** perl5_003/t/op/groups.t Tue Oct 18 12:45:10 1994
--- perl5_003_01/t/op/groups.t Wed May 1 14:55:44 1996
***************
*** 1,6 ****
#!./perl
! if (! -x '/usr/ucb/groups') {
print "1..0\n";
exit 0;
}
--- 1,6 ----
#!./perl
! if (! -x ($groups = '/usr/ucb/groups') && ! -x ($groups = '/usr/bin/groups')) {
print "1..0\n";
exit 0;
}
***************
*** 26,32 ****
$gr1 = join(' ', sort @gr);
! $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',`/usr/ucb/groups`)));
if ($gr1 eq $gr2) {
print "ok 1\n";
--- 26,32 ----
$gr1 = join(' ', sort @gr);
! $gr2 = join(' ', grep(!$basegroup{$_}++, sort split(' ',`$groups`)));
if ($gr1 eq $gr2) {
print "ok 1\n";
#~ Add tests for new strict untie
diff -Pcr perl5_003/t/op/tie.t perl5_003_01/t/op/tie.t
*** perl5_003/t/op/tie.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/t/op/tie.t Thu Jul 4 09:10:46 1996
***************
*** 0 ****
--- 1,144 ----
+ #!./perl
+
+ # This test harness will (eventually) test the "tie" functionality
+ # without the need for a *DBM* implementation.
+
+ # Currently it only tests use strict "untie".
+
+ chdir 't' if -d 't';
+ @INC = "../lib";
+ $ENV{PERL5LIB} = "../lib";
+
+ $|=1;
+
+ undef $/;
+ @prgs = split "\n########\n", <DATA>;
+ print "1..", scalar @prgs, "\n";
+
+ for (@prgs){
+ my($prog,$expected) = split(/\nEXPECT\n/, $_);
+ eval "$prog" ;
+ $status = $?;
+ $results = $@ ;
+ $results =~ s/\n+$//;
+ $expected =~ s/\n+$//;
+ if ( $status or $results !~ /^$expected/){
+ print STDERR "STATUS: $status\n";
+ print STDERR "PROG: $prog\n";
+ print STDERR "EXPECTED:\n$expected\n";
+ print STDERR "GOT:\n$results\n";
+ print "not ";
+ }
+ print "ok ", ++$i, "\n";
+ }
+
+ __END__
+
+ # standard behaviour, without any extra references
+ use Tie::Hash ;
+ tie %h, Tie::StdHash;
+ untie %h;
+ EXPECT
+ ########
+
+ # standard behaviour, with 1 extra reference
+ use Tie::Hash ;
+ $a = tie %h, Tie::StdHash;
+ untie %h;
+ EXPECT
+ ########
+
+ # standard behaviour, with 1 extra reference via tied
+ use Tie::Hash ;
+ tie %h, Tie::StdHash;
+ $a = tied %h;
+ untie %h;
+ EXPECT
+ ########
+
+ # standard behaviour, with 1 extra reference which is destroyed
+ use Tie::Hash ;
+ $a = tie %h, Tie::StdHash;
+ $a = 0 ;
+ untie %h;
+ EXPECT
+ ########
+
+ # standard behaviour, with 1 extra reference via tied which is destroyed
+ use Tie::Hash ;
+ tie %h, Tie::StdHash;
+ $a = tied %h;
+ $a = 0 ;
+ untie %h;
+ EXPECT
+ ########
+
+ # strict behaviour, without any extra references
+ use strict 'untie';
+ use Tie::Hash ;
+ tie %h, Tie::StdHash;
+ untie %h;
+ EXPECT
+ ########
+
+ # strict behaviour, with 1 extra references generating an error
+ use strict 'untie';
+ use Tie::Hash ;
+ $a = tie %h, Tie::StdHash;
+ untie %h;
+ EXPECT
+ Can't untie: 1 inner references still exist at
+ ########
+
+ # strict behaviour, with 1 extra references via tied generating an error
+ use strict 'untie';
+ use Tie::Hash ;
+ tie %h, Tie::StdHash;
+ $a = tied %h;
+ untie %h;
+ EXPECT
+ Can't untie: 1 inner references still exist at
+ ########
+
+ # strict behaviour, with 1 extra references which are destroyed
+ use strict 'untie';
+ use Tie::Hash ;
+ $a = tie %h, Tie::StdHash;
+ $a = 0 ;
+ untie %h;
+ EXPECT
+ ########
+
+ # strict behaviour, with extra 1 references via tied which are destroyed
+ use strict 'untie';
+ use Tie::Hash ;
+ tie %h, Tie::StdHash;
+ $a = tied %h;
+ $a = 0 ;
+ untie %h;
+ EXPECT
+ ########
+
+ # strict error behaviour, with 2 extra references
+ use strict 'untie';
+ use Tie::Hash ;
+ $a = tie %h, Tie::StdHash;
+ $b = tied %h ;
+ untie %h;
+ EXPECT
+ Can't untie: 2 inner references still exist at
+ ########
+
+ # strict behaviour, check scope of strictness.
+ no strict 'untie';
+ use Tie::Hash ;
+ $A = tie %H, Tie::StdHash;
+ $C = $B = tied %H ;
+ {
+ use strict 'untie';
+ use Tie::Hash ;
+ tie %h, Tie::StdHash;
+ untie %h;
+ }
+ untie %H;
+ EXPECT
#~ Add suport for version check via "use"
#~ Add fast symbol lookup support
#~ Optimize subs returning constant value to constants
#~ Change memory allocation calls to use macros from handy.h
#~ Allow \t as well as ' ' between "perl" and switches on #! line
#~ Allow leading '_' under strict subs in barewords stringified as hash keys
#~ #ifdef out under QNX assertion which gives it trouble
diff -Pcr perl5_003/toke.c perl5_003_01/toke.c
*** perl5_003/toke.c Mon Mar 25 01:05:42 1996
--- perl5_003_01/toke.c Sun Jul 7 19:02:15 1996
***************
***************
*** 16,21 ****
--- 16,22 ----
static void check_uni _((void));
static void force_next _((I32 type));
+ static char *force_version _((char *start));
static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick));
static SV *q _((SV *sv));
static char *scan_const _((char *start));
***************
*** 45,50 ****
--- 46,52 ----
#endif
static char * filter_gets _((SV *sv, FILE *fp));
static void restore_rsfp _((void *f));
+ static SV * sub_const _((CV *cv));
/* 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).
***************
*** 515,520 ****
--- 517,550 ----
}
}
+ static char *
+ force_version(s)
+ char *s;
+ {
+ OP *version = Nullop;
+
+ s = skipspace(s);
+
+ /* default VERSION number -- GBARR */
+
+ if(isDIGIT(*s)) {
+ char *d;
+ int c;
+ for( d=s, c = 1; isDIGIT(*d) || (*d == '.' && c--); d++);
+ if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
+ s = scan_num(s);
+ /* real VERSION number -- GBARR */
+ version = yylval.opval;
+ }
+ }
+
+ /* NOTE: The parser sees the package name and the VERSION swapped */
+ nextval[nexttoke].opval = version;
+ force_next(WORD);
+
+ return (s);
+ }
+
static SV *
q(sv)
SV *sv;
***************
*** 965,971 ****
if (indirgv && GvCV(indirgv))
return 0;
/* filehandle or package name makes it a method */
! if (!gv || GvIO(indirgv) || gv_stashpv(tmpbuf, FALSE)) {
s = skipspace(s);
nextval[nexttoke].opval =
(OP*)newSVOP(OP_CONST, 0,
--- 995,1001 ----
if (indirgv && GvCV(indirgv))
return 0;
/* filehandle or package name makes it a method */
! if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
s = skipspace(s);
nextval[nexttoke].opval =
(OP*)newSVOP(OP_CONST, 0,
***************
*** 1199,1205 ****
return ')';
}
if (lex_casemods > 10) {
! char* newlb = (char*)realloc(lex_casestack, lex_casemods + 2);
if (newlb != lex_casestack) {
SAVEFREEPV(newlb);
lex_casestack = newlb;
--- 1229,1235 ----
return ')';
}
if (lex_casemods > 10) {
! char* newlb = Renew(lex_casestack, lex_casemods + 2, char);
if (newlb != lex_casestack) {
SAVEFREEPV(newlb);
lex_casestack = newlb;
***************
*** 1480,1486 ****
int oldp = minus_p;
while (*d && !isSPACE(*d)) d++;
! while (*d == ' ') d++;
if (*d++ == '-') {
while (d = moreswitches(d)) ;
--- 1510,1516 ----
int oldp = minus_p;
while (*d && !isSPACE(*d)) d++;
! while (*d == ' ' || *d == '\t') d++;
if (*d++ == '-') {
while (d = moreswitches(d)) ;
***************
*** 1725,1731 ****
leftbracket:
s++;
if (lex_brackets > 100) {
! char* newlb = (char*)realloc(lex_brackstack, lex_brackets + 1);
if (newlb != lex_brackstack) {
SAVEFREEPV(newlb);
lex_brackstack = newlb;
--- 1755,1761 ----
leftbracket:
s++;
if (lex_brackets > 100) {
! char* newlb = Renew(lex_brackstack, lex_brackets + 1, char);
if (newlb != lex_brackstack) {
SAVEFREEPV(newlb);
lex_brackstack = newlb;
***************
*** 1746,1752 ****
case XOPERATOR:
while (s < bufend && (*s == ' ' || *s == '\t'))
s++;
! if (s < bufend && isALPHA(*s)) {
d = scan_word(s, tokenbuf, FALSE, &len);
while (d < bufend && (*d == ' ' || *d == '\t'))
d++;
--- 1776,1782 ----
case XOPERATOR:
while (s < bufend && (*s == ' ' || *s == '\t'))
s++;
! if (s < bufend && (isALPHA(*s) || *s == '_')) {
d = scan_word(s, tokenbuf, FALSE, &len);
while (d < bufend && (*d == ' ' || *d == '\t'))
d++;
***************
*** 2445,2450 ****
--- 2475,2491 ----
tokenbuf, tokenbuf);
last_lop = oldbufptr;
last_lop_op = OP_ENTERSUB;
+ /* Check for a constant sub */
+ if (SvPOK(cv) && !SvCUR(cv)) {
+ SV *sv = sub_const(cv);
+ if (sv) {
+ SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
+ ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
+ yylval.opval->op_private = 0;
+ TOKEN(WORD);
+ }
+ }
+
/* Resolve to GV now. */
op_free(yylval.opval);
yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
***************
*** 2944,2949 ****
--- 2985,2991 ----
if (expect != XSTATE)
yyerror("\"no\" not allowed in expression");
s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_version(s);
yylval.ival = 0;
OPERATOR(USE);
***************
*** 3059,3065 ****
*tokenbuf = '\0';
s = force_word(s,WORD,TRUE,TRUE,FALSE);
if (isIDFIRST(*tokenbuf))
! gv_stashpv(tokenbuf, TRUE);
else if (*s == '<')
yyerror("<> should be quotes");
UNI(OP_REQUIRE);
--- 3101,3107 ----
*tokenbuf = '\0';
s = force_word(s,WORD,TRUE,TRUE,FALSE);
if (isIDFIRST(*tokenbuf))
! gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE);
else if (*s == '<')
yyerror("<> should be quotes");
UNI(OP_REQUIRE);
***************
*** 3383,3389 ****
case KEY_use:
if (expect != XSTATE)
yyerror("\"use\" not allowed in expression");
! s = force_word(s,WORD,FALSE,TRUE,FALSE);
yylval.ival = 1;
OPERATOR(USE);
--- 3425,3442 ----
case KEY_use:
if (expect != XSTATE)
yyerror("\"use\" not allowed in expression");
! s = skipspace(s);
! if(isDIGIT(*s)) {
! s = force_version(s);
! if(*s == ';' || (s = skipspace(s), *s == ';')) {
! nextval[nexttoke].opval = Nullop;
! force_next(WORD);
! }
! }
! else {
! s = force_word(s,WORD,FALSE,TRUE,FALSE);
! s = force_version(s);
! }
yylval.ival = 1;
OPERATOR(USE);
***************
*** 4894,4902 ****
--- 4947,4957 ----
CV* outsidecv = compcv;
AV* comppadlist;
+ #ifndef __QNX__
if (compcv) {
assert(SvTYPE(compcv) == SVt_PVCV);
}
+ #endif
save_I32(&subline);
save_item(subname);
SAVEINT(padix);
***************
*** 4930,4935 ****
--- 4985,5011 ----
CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)outsidecv);
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
#~ Add default UNIVERSAL methods to core
diff -Pcr perl5_003/universal.c perl5_003_01/universal.c
*** perl5_003/universal.c Wed Dec 31 19:00:00 1969
--- perl5_003_01/universal.c Mon Jul 8 09:45:42 1996
***************
*** 0 ****
--- 1,232 ----
+ #include "EXTERN.h"
+ #include "perl.h"
+ #include "XSUB.h"
+
+ /*
+ * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
+ * The main guts of traverse_isa was actually copied from gv_fetchmeth
+ */
+
+ static SV *
+ isa_lookup(stash, name, len, level)
+ HV *stash;
+ char *name;
+ int len;
+ int level;
+ {
+ AV* av;
+ GV* gv;
+ GV** gvp;
+ HV* hv = Nullhv;
+
+ if (!stash)
+ return &sv_undef;
+
+ if(strEQ(HvNAME(stash), name))
+ return &sv_yes;
+
+ if (level > 100)
+ croak("Recursive inheritance detected");
+
+ gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
+
+ if (gvp && (gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv))) {
+ SV* sv;
+ SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
+ if (svp && (sv = *svp) != (SV*)&sv_undef)
+ return sv;
+ }
+
+ gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
+
+ if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
+ if(!hv) {
+ gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
+
+ gv = *gvp;
+
+ if (SvTYPE(gv) != SVt_PVGV)
+ gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
+
+ hv = GvHVn(gv);
+ }
+ if(hv) {
+ SV** svp = AvARRAY(av);
+ I32 items = AvFILL(av) + 1;
+ while (items--) {
+ SV* sv = *svp++;
+ HV* basestash = gv_stashsv(sv, FALSE);
+ if (!basestash) {
+ if (dowarn)
+ warn("Can't locate package %s for @%s::ISA",
+ SvPVX(sv), HvNAME(stash));
+ continue;
+ }
+ if(&sv_yes == isa_lookup(basestash, name, len, level + 1)) {
+ (void)hv_store(hv,name,len,&sv_yes,0);
+ return &sv_yes;
+ }
+ }
+ (void)hv_store(hv,name,len,&sv_no,0);
+ }
+ }
+
+ return &sv_no;
+ }
+
+ static
+ XS(XS_UNIVERSAL_isa)
+ {
+ dXSARGS;
+ SV *sv, *rv;
+ char *name;
+
+ if (items != 2)
+ croak("Usage: UNIVERSAL::isa(reference, kind)");
+
+ 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) = rv;
+ XSRETURN(1);
+ }
+
+ static
+ XS(XS_UNIVERSAL_can)
+ {
+ dXSARGS;
+ SV *sv;
+ char *name;
+ SV *rv;
+ GV *gv;
+ CV *cvp;
+
+ if (items != 2)
+ croak("Usage: UNIVERSAL::can(object-ref, method)");
+
+ sv = ST(0);
+ name = (char *)SvPV(ST(1),na);
+ rv = &sv_undef;
+
+ if(SvROK(sv) && (sv = (SV*)SvRV(sv)) && SvOBJECT(sv)) {
+ gv = gv_fetchmethod(SvSTASH(sv), name);
+
+ if(gv && GvCV(gv)) {
+ /* If the sub is only a stub then we may have a gv to AUTOLOAD */
+ GV **gvp = (GV**)hv_fetch(GvSTASH(gv), name, strlen(name), TRUE);
+ if(gvp && (cvp = GvCV(*gvp))) {
+ rv = sv_newmortal();
+ sv_setsv(rv, newRV((SV*)cvp));
+ }
+ }
+ }
+
+ ST(0) = rv;
+ XSRETURN(1);
+ }
+
+ static
+ XS(XS_UNIVERSAL_is_instance)
+ {
+ dXSARGS;
+ ST(0) = SvROK(ST(0)) ? &sv_yes : &sv_no;
+ XSRETURN(1);
+ }
+
+ static
+ XS(XS_UNIVERSAL_class)
+ {
+ dXSARGS;
+ if(SvROK(ST(0))) {
+ SV *sv = sv_newmortal();
+ sv_setpv(sv, HvNAME(SvSTASH(ST(0))));
+ ST(0) = sv;
+ }
+ XSRETURN(1);
+ }
+
+ static
+ XS(XS_UNIVERSAL_VERSION)
+ {
+ dXSARGS;
+ HV *pkg;
+ GV **gvp;
+ GV *gv;
+ SV *sv;
+ char *undef;
+
+ if(SvROK(ST(0))) {
+ sv = (SV*)SvRV(ST(0));
+ if(!SvOBJECT(sv))
+ croak("Cannot find version of an unblessed reference");
+ pkg = SvSTASH(sv);
+ }
+ else {
+ pkg = gv_stashsv(ST(0), FALSE);
+ }
+
+ gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
+
+ if (gvp && (gv = *gvp) != (GV*)&sv_undef && (sv = GvSV(gv))) {
+ SV *nsv = sv_newmortal();
+ sv_setsv(nsv, sv);
+ sv = nsv;
+ undef = Nullch;
+ }
+ else {
+ sv = (SV*)&sv_undef;
+ undef = "(undef)";
+ }
+
+ if(items > 1 && (undef || SvNV(ST(1)) > SvNV(sv)))
+ croak("%s version %s required--this is only version %s",
+ HvNAME(pkg),SvPV(ST(1),na),undef ? undef : SvPV(sv,na));
+
+ ST(0) = sv;
+
+ XSRETURN(1);
+ }
+
+ void
+ boot_core_UNIVERSAL()
+ {
+ char *file = __FILE__;
+
+ newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
+ newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
+ newXS("UNIVERSAL::class", XS_UNIVERSAL_class, file);
+ newXS("UNIVERSAL::is_instance", XS_UNIVERSAL_is_instance, file);
+ newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
+ }
#~ Add OS-specific initialization for macros used in Plan9 and VMS ports
diff -Pcr perl5_003/unixish.h perl5_003_01/unixish.h
*** perl5_003/unixish.h Mon Mar 25 01:05:42 1996
--- perl5_003_01/unixish.h Thu Jul 25 16:13:39 1996
***************
*** 34,39 ****
--- 34,60 ----
#define HAS_KILL
#define HAS_WAIT
+ /* USEMYBINMODE
+ * This symbol, if defined, indicates that the program should
+ * use the routine my_binmode(FILE *fp, char iotype) to insure
+ * that a file is in "binary" mode -- that is, that no translation
+ * of bytes occurs on read or write operations.
+ */
+ #undef USEMYBINMODE
+
+ /* USE_STAT_RDEV:
+ * This symbol is defined if this system has a stat structure declaring
+ * st_rdev
+ */
+ #define USE_STAT_RDEV /**/
+
+ /* ACME_MESS:
+ * This symbol, if defined, indicates that error messages should be
+ * should be generated in a format that allows the use of the Acme
+ * GUI/editor's autofind feature.
+ */
+ #undef ACME_MESS /**/
+
/* UNLINK_ALL_VERSIONS:
* This symbol, if defined, indicates that the program should arrange
* to remove all versions of a file if unlink() is called. This is
#~ Allow redirection of debug messages
#~ Add safe calloc() wrappers
#~ Correct count in i18nl10n
#~ Use Unixish my_p(open|close)() under OS/2 #ifdef HAS_FORK
diff -Pcr perl5_003/util.c perl5_003_01/util.c
*** perl5_003/util.c Mon Mar 25 01:05:43 1996
--- perl5_003_01/util.c Thu Jul 18 11:15:14 1996
***************
*** 83,91 ****
#endif
ptr = malloc(size?size:1); /* malloc(0) is NASTY on our system */
#if !(defined(I286) || defined(atarist))
! DEBUG_m(fprintf(stderr,"0x%x: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
#else
! DEBUG_m(fprintf(stderr,"0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
#endif
if (ptr != Nullch)
return ptr;
--- 83,91 ----
#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));
#else
! DEBUG_m(fprintf(Perl_debug_log,"0x%lx: (%05d) malloc %ld bytes\n",ptr,an++,(long)size));
#endif
if (ptr != Nullch)
return ptr;
***************
*** 130,142 ****
#if !(defined(I286) || defined(atarist))
DEBUG_m( {
! fprintf(stderr,"0x%x: (%05d) rfree\n",where,an++);
! fprintf(stderr,"0x%x: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
} )
#else
DEBUG_m( {
! fprintf(stderr,"0x%lx: (%05d) rfree\n",where,an++);
! fprintf(stderr,"0x%lx: (%05d) realloc %ld bytes\n",ptr,an++,(long)size);
} )
#endif
--- 130,142 ----
#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);
} )
#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);
} )
#endif
***************
*** 158,166 ****
char *where;
{
#if !(defined(I286) || defined(atarist))
! DEBUG_m( fprintf(stderr,"0x%x: (%05d) free\n",where,an++));
#else
! DEBUG_m( fprintf(stderr,"0x%lx: (%05d) free\n",where,an++));
#endif
if (where) {
/*SUPPRESS 701*/
--- 158,166 ----
char *where;
{
#if !(defined(I286) || defined(atarist))
! DEBUG_m( fprintf(Perl_debug_log,"0x%x: (%05d) free\n",where,an++));
#else
! DEBUG_m( fprintf(Perl_debug_log,"0x%lx: (%05d) free\n",where,an++));
#endif
if (where) {
/*SUPPRESS 701*/
***************
*** 168,173 ****
--- 168,212 ----
}
}
+ /* safe version of calloc */
+
+ char *
+ safecalloc(count, size)
+ MEM_SIZE count;
+ MEM_SIZE size;
+ {
+ char *ptr;
+
+ #ifdef MSDOS
+ if (size * count > 0xffff) {
+ fprintf(stderr, "Allocation too large: %lx\n", size * count) FLUSH;
+ my_exit(1);
+ }
+ #endif /* MSDOS */
+ #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));
+ #else
+ DEBUG_m(fprintf(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 */
+ if (ptr != Nullch) {
+ memset((void*)ptr, 0, size);
+ return ptr;
+ }
+ else if (nomemok)
+ return Nullch;
+ else {
+ fputs(no_mem,stderr) FLUSH;
+ my_exit(1);
+ }
+ /*NOTREACHED*/
+ }
+
#endif /* !safemalloc */
#ifdef LEAKTEST
***************
*** 211,216 ****
--- 250,271 ----
safefree(where);
}
+ char *
+ safexcalloc(x,count,size)
+ I32 x;
+ MEM_SIZE count;
+ MEM_SIZE size;
+ {
+ register char *where;
+
+ where = safexmalloc(x, size * count + ALIGN);
+ xcount[x]++;
+ memset((void*)where + ALIGN, 0, size * count);
+ where[0] = x % 100;
+ where[1] = x / 100;
+ return where + ALIGN;
+ }
+
static void
xstat()
{
***************
*** 355,361 ****
/* Initialize locale (and the fold[] array).*/
int
! perl_init_i18nl14n(printwarn)
int printwarn;
{
int ok = 1;
--- 410,416 ----
/* Initialize locale (and the fold[] array).*/
int
! perl_init_i18nl10n(printwarn)
int printwarn;
{
int ok = 1;
***************
*** 463,469 ****
}
BmRARE(sv) = s[rarest];
BmPREVIOUS(sv) = rarest;
! DEBUG_r(fprintf(stderr,"rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
}
char *
--- 518,524 ----
}
BmRARE(sv) = s[rarest];
BmPREVIOUS(sv) = rarest;
! DEBUG_r(fprintf(Perl_debug_log,"rarest char %c at %d\n",BmRARE(sv),BmPREVIOUS(sv)));
}
char *
***************
*** 1364,1370 ****
VTOH(vtohl,long)
#endif
! #if !defined(DOSISH) && !defined(VMS) /* VMS' my_popen() is in
VMS.c, same with OS/2. */
FILE *
my_popen(cmd,mode)
--- 1419,1425 ----
VTOH(vtohl,long)
#endif
! #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in
VMS.c, same with OS/2. */
FILE *
my_popen(cmd,mode)
***************
*** 1499,1505 ****
}
#endif
! #if !defined(DOSISH) && !defined(VMS) /* VMS' my_popen() is in VMS.c */
I32
my_pclose(ptr)
FILE *ptr;
--- 1554,1560 ----
}
#endif
! #if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) /* VMS' my_popen() is in VMS.c */
I32
my_pclose(ptr)
FILE *ptr;
***************
*** 1604,1610 ****
return;
}
! #if defined(atarist) || defined(OS2)
int pclose();
I32
my_pclose(ptr)
--- 1659,1665 ----
return;
}
! #if defined(atarist) || (defined(OS2) && !defined(HAS_FORK))
int pclose();
I32
my_pclose(ptr)
#~ Write output to "install into" directory, not "apparent installed"
#~ directory (the two may differ under e.g. AFS)
diff -Pcr perl5_003/utils/h2ph.PL perl5_003_01/utils/h2ph.PL
*** perl5_003/utils/h2ph.PL Mon Mar 25 01:05:46 1996
--- perl5_003_01/utils/h2ph.PL Fri Jul 5 17:08:07 1996
***************
*** 34,40 ****
'ds 00 \"';
'ig 00 ';
! \$perlincl = "$Config{archlibexp}";
!GROK!THIS!
--- 34,40 ----
'ds 00 \"';
'ig 00 ';
! \$perlincl = "$Config{installsitearchlib}";
!GROK!THIS!
#~ Add documented -p and -s options, and undocumented -x option
#~ Add VMS support
diff -Pcr perl5_003/utils/h2xs.PL perl5_003_01/utils/h2xs.PL
*** perl5_003/utils/h2xs.PL Mon Mar 25 01:05:46 1996
--- perl5_003_01/utils/h2xs.PL Wed Jul 10 12:10:09 1996
***************
*** 33,46 ****
# 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] [headerfile [extra_libraries]]
B<h2xs> B<-h>
--- 33,45 ----
# 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<-h>
***************
*** 98,103 ****
--- 97,113 ----
Specifies a name to be used for the extension, e.g., S<-n RPC::DCE>
+ =item B<-p> I<prefix>
+
+ Specify a prefix which should be removed from the Perl function names, e.g., S<-p sec_rgy_>
+ This sets up the XS B<PREFIX> keyword and removes the prefix from functions that are
+ autoloaded via the C<constant()> mechansim.
+
+ =item B<-s> I<sub1,sub2>
+
+ Create a perl subroutine for the specified macros rather than autoload with the constant() subroutine.
+ These macros are assumed to have a return type of B<char *>, e.g., S<-s sec_rgy_wildcard_name,sec_rgy_wildcard_sid>.
+
=item B<-v> I<version>
Specify a version number for this extension. This version number is added
***************
*** 138,143 ****
--- 148,162 ----
# additional directory /opt/net/lib
h2xs rpcsvc/rusers -L/opt/net/lib -lrpc
+ # Extension is DCE::rgynbase
+ # prefix "sec_rgy_" is dropped from perl function names
+ h2xs -n DCE::rgynbase -p sec_rgy_ dce/rgynbase
+
+ # Extension is DCE::rgynbase
+ # prefix "sec_rgy_" is dropped from perl function names
+ # subroutines are created for sec_rgy_wildcard_name and sec_rgy_wildcard_sid
+ h2xs -n DCE::rgynbase -p sec_rgy_ \
+ -s sec_rgy_wildcard_name,sec_rgy_wildcard_sid dce/rgynbase
=head1 ENVIRONMENT
***************
*** 164,174 ****
sub usage{
warn "@_\n" if @_;
! die "h2xs [-AOPXcfh] [-v version] [-n module_name] [headerfile [extra_libraries]]
version: $H2XS_VERSION
-f Force creation of the extension even if the C header does not exist.
-n Specify a name to use for the extension (recommended).
-c Omit the constant() function and specialised AUTOLOAD from the XS file.
-A Omit all autoloading facilities (implies -c).
-O Allow overwriting of a pre-existing extension directory.
-P Omit the stub POD section.
--- 183,195 ----
sub usage{
warn "@_\n" if @_;
! die "h2xs [-AOPXcfh] [-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).
-O Allow overwriting of a pre-existing extension directory.
-P Omit the stub POD section.
***************
*** 182,188 ****
}
! getopts("AOPXcfhv:n:") || usage;
usage if $opt_h;
--- 203,209 ----
}
! getopts("AOPXcfhxv:n:p:s:") || usage;
usage if $opt_h;
***************
*** 190,195 ****
--- 211,217 ----
$TEMPLATE_VERSION = $opt_v;
}
$opt_c = 1 if $opt_A;
+ %const_xsub = map { $_,1 } split(/,+/, $opt_s) if $opt_s;
$path_h = shift;
$extralibs = "@ARGV";
***************
*** 204,210 ****
warn "Nesting of headerfile ignored with -n\n";
}
$path_h .= ".h" unless $path_h =~ /\.h$/;
! $path_h = "/usr/include/$path_h" unless $path_h =~ m#^[./]#;
die "Can't find $path_h\n" if ( ! $opt_f && ! -f $path_h );
# Scan the header file (we should deal with nested header files)
--- 226,246 ----
warn "Nesting of headerfile ignored with -n\n";
}
$path_h .= ".h" unless $path_h =~ /\.h$/;
! if ($^O eq 'VMS') { # Consider overrides of default location
! if ($path_h !~ m![:>\[]!) {
! my($hadsys) = ($path_h =~ s!^sys/!!i);
! if ($ENV{'DECC$System_Include'}) { $path_h = "DECC\$System_Include:$path_h"; }
! elsif ($ENV{'DECC$Library_Include'}) { $path_h = "DECC\$Library_Include:$path_h"; }
! elsif ($ENV{'GNU_CC_Include'}) { $path_h = 'GNU_CC_Include:' .
! ($hadsys ? '[vms]' : '[000000]') . $path_h; }
! elsif ($ENV{'VAXC$Include'}) { $path_h = "VAXC\$_Include:$path_h"; }
! else { $path_h = "Sys\$Library:$path_h"; }
! }
! }
! elsif ($^O eq 'os2') {
! $path_h = "/usr/include/$path_h" unless $path_h =~ m#^([a-z]:)?[./]#i;
! }
! 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)
***************
*** 212,220 ****
# 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*[^("]/) {
$_ = $1;
next if /^_.*_h_*$/i; # special case, but for what?
$const_names{$_}++;
}
}
--- 248,265 ----
# 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";
$_ = $1;
next if /^_.*_h_*$/i; # special case, but for what?
+ if (defined $opt_p)
+ if (!/^$opt_p(\d)/) {
+ ++$prefix{$_} if s/^$opt_p//;
+ }
+ else {
+ warn "can't remove $opt_p prefix from '$_'!\n";
+ }
+ }
$const_names{$_}++;
}
}
***************
*** 457,462 ****
--- 502,508 ----
if( $path_h ){
my($h) = $path_h;
$h =~ s#^/usr/include/##;
+ if ($^O eq 'VMS') { $h =~ s#.*vms\]#sys/# or $h =~ s#.*[:>\]]##; }
print XS <<"END";
#include <$h>
***************
*** 498,507 ****
my($name);
while (substr($const_names[0],0,1) eq $letter) {
$name = shift(@const_names);
print XS <<"END";
if (strEQ(name, "$name"))
! #ifdef $name
! return $name;
#else
goto not_there;
#endif
--- 544,555 ----
my($name);
while (substr($const_names[0],0,1) eq $letter) {
$name = shift(@const_names);
+ $macro = $prefix{$name} ? "$opt_p$name" : $name;
+ next if $const_xsub{$macro};
print XS <<"END";
if (strEQ(name, "$name"))
! #ifdef $macro
! return $macro;
#else
goto not_there;
#endif
***************
*** 524,536 ****
END
}
# Now switch from C to XS by issuing the first MODULE declaration:
print XS <<"END";
! MODULE = $module PACKAGE = $module
END
# If a constant() function was written then output a corresponding
# XS declaration:
print XS <<"END" unless $opt_c;
--- 572,603 ----
END
}
+ $prefix = "PREFIX = $opt_p" if defined $opt_p;
# Now switch from C to XS by issuing the first MODULE declaration:
print XS <<"END";
! MODULE = $module PACKAGE = $module $prefix
END
+ foreach (sort keys %const_xsub) {
+ print XS <<"END";
+ char *
+ $_()
+
+ CODE:
+ #ifdef $_
+ RETVAL = $_;
+ #else
+ croak("Your vendor has not defined the $module macro $_");
+ #endif
+
+ OUTPUT:
+ RETVAL
+
+ END
+ }
+
# If a constant() function was written then output a corresponding
# XS declaration:
print XS <<"END" unless $opt_c;
***************
*** 542,547 ****
--- 609,666 ----
END
+ sub print_decl {
+ my $fh = shift;
+ my $decl = shift;
+ my ($type, $name, $args) = @$decl;
+ my @argnames = map {$_->[1]} @$args;
+ my @argtypes = map { normalize_type( $_->[0] ) } @$args;
+ my $numargs = @$args;
+ if ($numargs and $argtypes[-1] eq '...') {
+ $numargs--;
+ $argnames[-1] = '...';
+ }
+ local $" = ', ';
+ $type = normalize_type($type);
+
+ print $fh <<"EOP";
+
+ $type
+ $name(@argnames)
+ EOP
+
+ for $arg (0 .. $numargs - 1) {
+ print $fh <<"EOP";
+ $argtypes[$arg] $argnames[$arg]
+ EOP
+ }
+ }
+
+ my $ignore_mods = '(?:\b(?:__const__|static|inline|__inline__)\b\s*)*';
+
+ sub normalize_type {
+ my $type = shift;
+ $type =~ s/$ignore_mods//go;
+ $type =~ s/\s+/ /g;
+ $type =~ s/\s+$//;
+ $type =~ s/^\s+//;
+ $type =~ s/\b\*/ */g;
+ $type =~ s/\*\b/* /g;
+ $type =~ s/\*\s+(?=\*)/*/g;
+ $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) }
+ }
+
close XS;
} # if( ! $opt_X )
#~ More informative prompting
#~ Don't edit precomposed file
#~ Correct socket %Config variable under VMS
#~ Try again if we can't read precomposed file
#~ Be more finicky about command to send message
diff -Pcr perl5_003/utils/perlbug.PL perl5_003_01/utils/perlbug.PL
*** perl5_003/utils/perlbug.PL Mon Mar 25 01:05:47 1996
--- perl5_003_01/utils/perlbug.PL Wed Jul 17 11:25:08 1996
***************
*** 50,56 ****
sub paraprint;
! my($Version) = "1.13";
# Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
# Changed in 1.07 to see more sendmail execs, and added pipe output.
--- 50,56 ----
sub paraprint;
! my($Version) = "1.14";
# Changed in 1.06 to skip Mail::Send and Mail::Util if not available.
# Changed in 1.07 to see more sendmail execs, and added pipe output.
***************
*** 64,75 ****
# clearer and add $ENV{REPLYTO}.
# Changed in 1.13 to hopefully make it more difficult to accidentally
# send mail
# TODO: Allow the user to re-name the file on mail failure, and
# make sure failure (transmission-wise) of Mail::Send is
# accounted for.
! my( $file, $cc, $address, $perlbug, $testaddress, $filename,
$subject, $from, $verbose, $ed,
$fh, $me, $Is_VMS, $msg, $body, $andcc );
--- 64,77 ----
# clearer and add $ENV{REPLYTO}.
# Changed in 1.13 to hopefully make it more difficult to accidentally
# send mail
+ # Changed in 1.14 to make the prompts a little more clear on providing
+ # helpful information. Also let file read fail gracefully.
# TODO: Allow the user to re-name the file on mail failure, and
# make sure failure (transmission-wise) of Mail::Send is
# accounted for.
! my( $file, $usefile, $cc, $address, $perlbug, $testaddress, $filename,
$subject, $from, $verbose, $ed,
$fh, $me, $Is_VMS, $msg, $body, $andcc );
***************
*** 88,94 ****
if($::opt_d or !-t STDOUT) { Dump(*STDOUT); exit; }
Query();
! Edit();
NowWhat();
Send();
--- 90,96 ----
if($::opt_d or !-t STDOUT) { Dump(*STDOUT); exit; }
Query();
! Edit() unless $usefile;
NowWhat();
Send();
***************
*** 134,139 ****
--- 136,144 ----
# Subject of bug-report message
$subject = $::opt_s || "";
+ # Send a file
+ $usefile = ($::opt_f || 0);
+
# File to send as report
$file = $::opt_f || "";
***************
*** 141,150 ****
$body = $::opt_b || "";
# Editor
! $ed = ($::opt_f ? "file" : (
! $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} ||
($Is_VMS ? "edit/tpu" : "vi")
! ));
# My username
$me = getpwuid($<);
--- 146,155 ----
$body = $::opt_b || "";
# Editor
! $ed = ( $::opt_e || $ENV{VISUAL} || $ENV{EDITOR} || $ENV{EDIT} ||
($Is_VMS ? "edit/tpu" : "vi")
! );
!
# My username
$me = getpwuid($<);
***************
*** 157,165 ****
# Explain what perlbug is
paraprint <<EOF;
! This program allows you to create a bug report,
! which will be sent as an e-mail message to $address
! once you have filled in the report.
EOF
--- 162,169 ----
# Explain what perlbug is
paraprint <<EOF;
! This program provides an easy way to create a message reporting a bug in
! perl, and e-mail it to $address.
EOF
***************
*** 168,175 ****
if(! $subject) {
paraprint <<EOF;
First of all, please provide a subject for the
! message. It should be as a concise description of
! the bug as is possible.
EOF
print "Subject: ";
--- 172,179 ----
if(! $subject) {
paraprint <<EOF;
First of all, please provide a subject for the
! message. It should be a concise description of
! the bug or problem.
EOF
print "Subject: ";
***************
*** 209,215 ****
if( !$domain) {
$guess = "";
! } elsif ($Is_VMS && !$::Config{'d_has_sockets'}) {
$guess = "$domain\:\:$me";
} else {
$guess = "$me\@$domain" if $domain;
--- 213,219 ----
if( !$domain) {
$guess = "";
! } elsif ($Is_VMS && !$::Config{'has_sockets'}) {
$guess = "$domain\:\:$me";
} else {
$guess = "$me\@$domain" if $domain;
***************
*** 283,289 ****
$andcc = " and $cc" if $cc;
!
# Prompt for editor, if no override is given
if(! $::opt_e and ! $::opt_f and ! $::opt_b) {
paraprint <<EOF;
--- 287,294 ----
$andcc = " and $cc" if $cc;
! editor:
!
# Prompt for editor, if no override is given
if(! $::opt_e and ! $::opt_f and ! $::opt_b) {
paraprint <<EOF;
***************
*** 291,299 ****
Now you need to supply the bug report. Try to make
the report concise but descriptive. Include any
! relevant detail. Some information about your local
perl configuration will automatically be included
! at the end of the report.
You will probably want to use an editor to enter
the report. If "$ed" is the editor you want
--- 296,311 ----
Now you need to supply the bug report. Try to make
the report concise but descriptive. Include any
! relevant detail. If you are reporting something
! that does not work as you think it should, please
! try to include example of both the actual
! result, and what you expected.
!
! Some information about your local
perl configuration will automatically be included
! at the end of the report. If you are using any
! unusual version of perl, please try and confirm
! exactly which versions are relevant.
You will probably want to use an editor to enter
the report. If "$ed" is the editor you want
***************
*** 309,316 ****
my($entry) =scalar(<>);
chop $entry;
!
! if($entry ne "") {
$ed = $entry;
}
}
--- 321,331 ----
my($entry) =scalar(<>);
chop $entry;
!
! $usefile = 0;
! if($entry eq "file") {
! $usefile = 1;
! } elsif($entry ne "") {
$ed = $entry;
}
}
***************
*** 328,337 ****
# Prompt for file to read report from, if needed
! if( $ed eq "file" and ! $file) {
paraprint <<EOF;
-
What is the name of the file that contains your report?
EOF
--- 343,352 ----
# Prompt for file to read report from, if needed
! if( $usefile and ! $file) {
! filename:
paraprint <<EOF;
What is the name of the file that contains your report?
EOF
***************
*** 341,349 ****
my($entry) = scalar(<>);
chop($entry);
if(!-f $entry or !-r $entry) {
! print "\n\nUnable to read from `$entry'.\nExiting.\n";
! exit;
}
$file = $entry;
--- 356,379 ----
my($entry) = scalar(<>);
chop($entry);
+ if($entry eq "") {
+ paraprint <<EOF;
+
+ No filename? I'll let you go back and choose an editor again.
+
+ EOF
+ goto editor;
+ }
+
if(!-f $entry or !-r $entry) {
! paraprint <<EOF;
!
! I'm sorry, but I can't read from `$entry'. Maybe you mistyped the name of
! the file? If you don't want to send a file, just enter a blank line and you
! can get back to the editor selection.
!
! EOF
! goto filename;
}
$file = $entry;
***************
*** 362,369 ****
if($body) {
print REP $body;
! } elsif($file) {
! open(F,"<$file") or die "Unable to read report file: $!\n";
while(<F>) {
print REP $_
}
--- 392,399 ----
if($body) {
print REP $body;
! } elsif($usefile) {
! open(F,"<$file") or die "Unable to read report file from `$file': $!\n";
while(<F>) {
print REP $_
}
***************
*** 407,415 ****
sub Edit {
# Edit the report
! tryagain:
! if(!$file and !$body) {
my($sts) = system("$ed $filename");
if( $Is_VMS ? !($sts & 1) : $sts ) {
#print "\nUnable to run editor!\n";
--- 437,462 ----
sub Edit {
# Edit the report
+
+ if($usefile) {
+ $usefile = 0;
+ paraprint <<EOF;
+
+ Please make sure that the name of the editor you want to use is correct.
+
+ EOF
+ print "Editor [$ed]: ";
+
+ my($entry) =scalar(<>);
+ chop $entry;
! if($entry ne "") {
! $ed = $entry;
! }
! }
!
! tryagain:
! if(!$usefile and !$body) {
my($sts) = system("$ed $filename");
if( $Is_VMS ? !($sts & 1) : $sts ) {
#print "\nUnable to run editor!\n";
***************
*** 493,498 ****
--- 540,554 ----
chop($reply);
if( $reply eq "yes" ) {
last;
+ } else {
+ paraprint <<EOF;
+
+ That wasn't a clear "yes", so I won't send your message. If you are sure
+ your message should be sent, type in "yes" (without the quotes) at the
+ confirmation prompt.
+
+ EOF
+
}
} elsif( $action =~ /^[er]/i ) { # <E>dit, <R>e-edit
# edit the message
#~ Updates matching vms/descrip.mms
diff -Pcr perl5_003/vms/Makefile perl5_003_01/vms/Makefile
*** perl5_003/vms/Makefile Sun Jun 23 22:54:44 1996
--- perl5_003_01/vms/Makefile Fri Jul 26 17:49:51 1996
***************
*** 31,41 ****
ARCH = VMS_VAX
OBJVAL = $@
- .first:
- @ $$@[.vms]fndvers.com "" "" "[.vms]Makefile"
-
# Updated by fndvers.com -- do not edit by hand
! PERL_VERSION = 5_003 #
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
--- 31,38 ----
ARCH = VMS_VAX
OBJVAL = $@
# Updated by fndvers.com -- do not edit by hand
! PERL_VERSION = 5_00301#
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
***************
*** 57,62 ****
--- 54,60 ----
# off SYSNAM for the MM[SK] subprocess doesn't hurt anything, so we do it
# just in case.
.first:
+ @ $$@[.vms]fndvers.com "" "" "[.vms]Makefile"
@ If f$$TrnLnm("Sys").eqs."" .and. f$$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS sys$$Library
@ If f$$TrnLnm("Sys").eqs."" .and. f$$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include
***************
*** 119,125 ****
h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h
h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS)
! c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c
c2 = perl.c, perly.c, pp.c, pp_hot.c, pp_ctl.c, pp_sys.c, regcomp.c, regexec.c
c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, globals.c, vms.c $(SOCKCLIS)
--- 117,123 ----
h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h
h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS)
! c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c, universal.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)
***************
*** 127,133 ****
obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O)
obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O)
! obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), globals$(O), vms$(O) $(SOCKOBJ)
obj = $(obj1), $(obj2), $(obj3)
--- 125,131 ----
obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O)
obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O)
! obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), universal$(O), globals$(O), vms$(O) $(SOCKOBJ)
obj = $(obj1), $(obj2), $(obj3)
***************
*** 161,171 ****
$(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c
! all : base extras archcorefiles preplibrary perlpods
@ $(NOOP)
base : miniperl perl
@ $(NOOP)
! extras : Fcntl FileHandle Safe libmods utils podxform
@ $(NOOP)
libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm
@ $(NOOP)
--- 159,169 ----
$(CC) $(CFLAGS) $(MMS$SOURCE_NAME).c
! all : base extras libmods utils podxform archcorefiles preplibrary perlpods
@ $(NOOP)
base : miniperl perl
@ $(NOOP)
! extras : Fcntl FileHandle IO Opcode libmods utils podxform
@ $(NOOP)
libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm
@ $(NOOP)
***************
*** 193,199 ****
@ Continue
miniperl_objs = miniperlmain$(O), $(obj)
$(MINIPERL_EXE) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
! Link $(LINKFLAGS)/NoDebug/Exe=$@ miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
$(DBG)miniperl$(E) : $(miniperl_objs), $(DBG)libperl$(OLB) $(CRTL)
Link $(LINKFLAGS)/Exe=$@ miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
--- 191,197 ----
@ Continue
miniperl_objs = miniperlmain$(O), $(obj)
$(MINIPERL_EXE) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
! Link $(LINKFLAGS)/NoDebug/NoMap/NoFull/NoCross/Exe=$@ miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
$(DBG)miniperl$(E) : $(miniperl_objs), $(DBG)libperl$(OLB) $(CRTL)
Link $(LINKFLAGS)/Exe=$@ miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
***************
*** 253,276 ****
@ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]DynaLoader.pm
! Safe : [.lib]Safe.pm [.lib.auto.Safe]Safe$(E)
@ $(NOOP)
! [.lib]Safe.pm : [.ext.Safe]Makefile
@ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
! @ Set Default [.ext.Safe]
$(MMS)
@ Set Default [--]
! [.lib.auto.Safe]Safe$(E) : [.ext.Safe]Makefile
! @ Set Default [.ext.Safe]
$(MMS)
@ Set Default [--]
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
! [.ext.Safe]Makefile : [.ext.Safe]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
! $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Safe]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
FileHandle : [.lib]FileHandle.pm [.lib.auto.FileHandle]FileHandle$(E)
@ $(NOOP)
--- 251,286 ----
@ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]DynaLoader.pm
! Opcode : [.lib]Opcode.pm [.lib]ops.pm [.lib]Safe.pm [.lib.auto.Opcode]Opcode$(E)
@ $(NOOP)
! [.lib]Opcode.pm : [.ext.Opcode]Makefile
! @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
! @ Set Default [.ext.Opcode]
! $(MMS)
! @ Set Default [--]
!
! [.lib]ops.pm : [.ext.Opcode]Makefile
! @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
! @ Set Default [.ext.Opcode]
! $(MMS)
! @ Set Default [--]
!
! [.lib]Safe.pm : [.ext.Opcode]Makefile
@ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
! @ Set Default [.ext.Opcode]
$(MMS)
@ Set Default [--]
! [.lib.auto.Opcode]Opcode$(E) : [.ext.Opcode]Makefile
! @ Set Default [.ext.Opcode]
$(MMS)
@ Set Default [--]
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
! [.ext.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)
@ $(NOOP)
***************
*** 288,294 ****
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
! [.ext.FileHandle]Makefile : [.ext.FileHandle]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.FileHandle]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
--- 298,304 ----
# 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]"
Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
***************
*** 307,315 ****
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
! [.ext.Fcntl]Makefile : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
@ If f$$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
Copy/Log/NoConfirm [.vms.ext]Filespec.pm $@
--- 317,374 ----
# 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]"
+ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]Seekable.pm [.lib.IO]Socket.pm [.lib.auto.IO]IO$(E)
+ @ $(NOOP)
+
+ [.lib]IO.pm : [.ext.IO]Makefile
+ @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.IO]File.pm : [.ext.IO]Makefile
+ @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.IO]Handle.pm : [.ext.IO]Makefile
+ @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.IO]Pipe.pm : [.ext.IO]Makefile
+ @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.IO]Seekable.pm : [.ext.IO]Makefile
+ @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.IO]Socket.pm : [.ext.IO]Makefile
+ @ If f$$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.auto.IO]IO$(E) : [.ext.IO]Makefile
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
+ # ${@} necessary to distract different versions of MM[SK]/make
+ [.ext.IO]Makefile : [.ext.IO]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+ $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.IO]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+
[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
@ If f$$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
Copy/Log/NoConfirm [.vms.ext]Filespec.pm $@
***************
*** 534,540 ****
$(CC) $(CFLAGS) perly.c
test : all
! - @[.VMS]Test.Com
# CORE subset for MakeMaker, so we can build Perl without sources
# Should move to VMS installperl when we get one
--- 593,599 ----
$(CC) $(CFLAGS) perly.c
test : all
! - @[.VMS]Test.Com "$(E)"
# CORE subset for MakeMaker, so we can build Perl without sources
# Should move to VMS installperl when we get one
***************
*** 817,822 ****
--- 876,904 ----
mg$(O) : sv.h
mg$(O) : vmsish.h
mg$(O) : util.h
+ universal$(O) : EXTERN.h
+ universal$(O) : av.h
+ universal$(O) : config.h
+ universal$(O) : cop.h
+ universal$(O) : cv.h
+ universal$(O) : embed.h
+ universal$(O) : form.h
+ universal$(O) : gv.h
+ universal$(O) : handy.h
+ universal$(O) : hv.h
+ universal$(O) : mg.h
+ universal$(O) : op.h
+ universal$(O) : opcode.h
+ universal$(O) : perl.h
+ universal$(O) : perly.h
+ universal$(O) : pp.h
+ universal$(O) : proto.h
+ universal$(O) : regexp.h
+ universal$(O) : scope.h
+ universal$(O) : sv.h
+ universal$(O) : vmsish.h
+ universal$(O) : util.h
+ universal$(O) : universal.c
perl$(O) : EXTERN.h
perl$(O) : av.h
perl$(O) : config.h
***************
*** 1291,1297 ****
- If f$$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar
- If f$$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O)
- If f$$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C
! - If f$$Search("[.Ext.Safe...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.Safe]
- If f$$Search("[.Ext.FileHandle...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.FileHandle]
- If f$$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*.C
- If f$$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*$(O)
--- 1373,1379 ----
- If f$$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar
- If f$$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O)
- If f$$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C
! - If f$$Search("[.Ext.Opcode...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.Opcode]
- If f$$Search("[.Ext.FileHandle...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.FileHandle]
- If f$$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*.C
- If f$$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*$(O)
***************
*** 1314,1320 ****
Set Default [.ext.FileHandle]
- $(MMS) clean
Set Default [--]
! Set Default [.ext.Safe]
- $(MMS) clean
Set Default [--]
- If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
--- 1396,1405 ----
Set Default [.ext.FileHandle]
- $(MMS) clean
Set Default [--]
! Set Default [.ext.IO]
! - $(MMS) clean
! Set Default [--]
! Set Default [.ext.Opcode]
- $(MMS) clean
Set Default [--]
- If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
***************
*** 1344,1356 ****
Set Default [.ext.FileHandle]
- $(MMS) realclean
Set Default [--]
! Set Default [.ext.Safe]
- $(MMS) realclean
Set Default [--]
- If f$$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);"
- If f$$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
- If f$$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
- If f$$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;*
- If f$$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;*
--- 1429,1445 ----
Set Default [.ext.FileHandle]
- $(MMS) realclean
Set Default [--]
! Set Default [.ext.IO]
! - $(MMS) realclean
! Set Default [--]
! Set Default [.ext.Opcode]
- $(MMS) realclean
Set Default [--]
- If f$$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If f$$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);"
- If f$$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
+ - If f$$Search("[.Lib]Socket.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Socket.pm;*
- If f$$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
- If f$$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;*
- If f$$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;*
#~ Incorporate recent changes to config_h.SH: DB_File macros and BIN_SH
#~ Update default version number
#~ Remove dead code
#~ Correct #defines for non-blocking reads until better sorted out
#~ Remove duplicate I_SYS_STAT
diff -Pcr perl5_003/vms/config.vms perl5_003_01/vms/config.vms
*** perl5_003/vms/config.vms Sun Jun 23 22:54:20 1996
--- perl5_003_01/vms/config.vms Thu Jul 18 10:35:43 1996
***************
*** 72,78 ****
* when Perl is built. Please do not change it by hand; make
* any changes to FndVers.Com instead.
*/
! #define ARCHLIB_EXP "/perl_root/lib/VMS_VAX/5_003" /**/
/* CPPSTDIN:
* This symbol contains the first part of the string which will invoke
--- 72,78 ----
* 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" /**/
/* CPPSTDIN:
* This symbol contains the first part of the string which will invoke
***************
*** 134,142 ****
* trigger the necessary tests.
*/
#define HASCONST /**/
- #ifndef HASCONST
- #define const
- #endif
/* HAS_CRYPT:
* This symbol, if defined, indicates that the crypt routine is available
--- 134,139 ----
***************
*** 566,576 ****
*/
#define HAS_STRERROR /**/
#undef HAS_SYS_ERRLIST /**/
! #ifdef HAS_STRERROR
! # define Strerror(e) strerror((e),vaxc$errno)
! #else
! #define Strerror(e) ((e)<0||(e)>=sys_nerr?"unknown":sys_errlist[e]) /**/ /* config-skip */
! #endif
/* HAS_SYMLINK:
* This symbol, if defined, indicates that the symlink routine is available
--- 563,569 ----
*/
#define HAS_STRERROR /**/
#undef HAS_SYS_ERRLIST /**/
! #define Strerror(e) strerror((e),vaxc$errno)
/* HAS_SYMLINK:
* This symbol, if defined, indicates that the symlink routine is available
***************
*** 1197,1208 ****
*/
#undef I_LOCALE /**/
- /* I_SYS_STAT:
- * This symbol, if defined, indicates to the C program that it should
- * include <sys/stat.h>.
- */
- #define I_SYS_STAT /**/
-
/* INTSIZE:
* This symbol contains the size of an int, so that the C preprocessor
* can make decisions based on it.
--- 1190,1195 ----
***************
*** 1302,1310 ****
* a non-blocking file descriptor will return 0 on EOF, and not the value
* held in RD_NODATA (-1 usually, in that case!).
*/
! #define VAL_O_NONBLOCK
! #define VAL_EAGAIN
! #define RD_NODATA
#undef EOF_NONBLOCK
/* OLDARCHLIB_EXP:
--- 1289,1297 ----
* a non-blocking file descriptor will return 0 on EOF, and not the value
* held in RD_NODATA (-1 usually, in that case!).
*/
! #undef VAL_O_NONBLOCK
! #undef VAL_EAGAIN
! #undef RD_NODATA
#undef EOF_NONBLOCK
/* OLDARCHLIB_EXP:
***************
*** 1377,1391 ****
*/
#undef I_SYS_PARAM
- /* GNUC_ATTRIBUTE_CHECK:
- * This symbol indicates the C compiler can check for function attributes,
- * such as printf formats.
- */
- /* VMS: true for gcc, undef for VAXC/DECC. This is handled in Descrip.MMS
- * C. Bailey 26-Aug-1994
- */
- /*#define GNUC_ATTRIBUTE_CHECK /**/
-
/* VOID_CLOSEDIR:
* This symbol, if defined, indicates that the closedir() routine
* does not return a value.
--- 1364,1369 ----
***************
*** 1542,1547 ****
--- 1520,1555 ----
*/
#define STARTPERL "" /**/
+ /* Groups_t:
+ * This symbol holds the type used for the second argument to
+ * getgroups(). Usually, this is the same of gidtype, but
+ * sometimes it isn't. It can be int, ushort, uid_t, etc...
+ * It may be necessary to include <sys/types.h> to get any
+ * typedef'ed information. This is only required if you have
+ * getgroups().
+ */
+ #ifdef HAS_GETGROUPS
+ #define Groups_t unsigned int /* Type for 2nd arg to getgroups() */ /* config-skip */
+ #endif
+
+ /* DB_Prefix_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is u_int32_t.
+ */
+ /* DB_Hash_t:
+ * This symbol contains the type of the prefix structure element
+ * in the <db.h> header file. In older versions of DB, it was
+ * int, while in newer ones it is size_t.
+ */
+ #undef DB_Hash_t /**/
+ #undef DB_Prefix_t /**/
+
+ /* BIN_SH:
+ * This variable contains the path to the shell.
+ */
+ #define BIN_SH "MCR" /**/
+
/* VOIDFLAGS:
* This symbol indicates how much support of the void type is given by this
* compiler. What various bits mean:
***************
*** 1594,1624 ****
* include <netinet/in.h>. Otherwise, you may try <sys/in.h>.
*/
#undef I_NETINET_IN /**/ /* config-skip */
-
- /* Groups_t:
- * This symbol holds the type used for the second argument to
- * getgroups(). Usually, this is the same of gidtype, but
- * sometimes it isn't. It can be int, ushort, uid_t, etc...
- * It may be necessary to include <sys/types.h> to get any
- * typedef'ed information. This is only required if you have
- * getgroups().
- */
- #ifdef HAS_GETGROUPS
- #define Groups_t unsigned int /* Type for 2nd arg to getgroups() */ /* config-skip */
- #endif
-
- /* DB_Prefix_t:
- * This symbol contains the type of the prefix structure element
- * in the <db.h> header file. In older versions of DB, it was
- * int, while in newer ones it is u_int32_t.
- */
- /* DB_Hash_t:
- * This symbol contains the type of the prefix structure element
- * in the <db.h> header file. In older versions of DB, it was
- * int, while in newer ones it is size_t.
- */
- #undef DB_Hash_t /**/
- #undef DB_Prefix_t /**/
/* I_NET_ERRNO:
* This symbol, if defined, indicates that <net/errno.h> exists and
--- 1602,1607 ----
#~ Use a single .first target -- MMS only processes last one encountered
#~ Update default version
#~ Add dependencies for new universal.c, Opcode, and IO
#~ Remove dependencies for obsolete Safe
#~ Turn off all debug options for non-debug link if miniperl
#~ Eliminate duplicate library specification to link when using gcc
#~ Tell test driver if we're using non-default filetype for executable images
diff -Pcr perl5_003/vms/descrip.mms perl5_003_01/vms/descrip.mms
*** perl5_003/vms/descrip.mms Sun Jun 23 22:53:30 1996
--- perl5_003_01/vms/descrip.mms Wed Jul 24 09:29:46 1996
***************
*** 64,74 ****
OBJVAL = $(MMS$TARGET_NAME)$(O)
.endif
- .first
- @ @[.vms]fndvers.com "" "" "[.vms]descrip.mms"
-
# Updated by fndvers.com -- do not edit by hand
! PERL_VERSION = 5_003 #
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
--- 64,71 ----
OBJVAL = $(MMS$TARGET_NAME)$(O)
.endif
# Updated by fndvers.com -- do not edit by hand
! PERL_VERSION = 5_00301#
ARCHDIR = [.lib.$(ARCH).$(PERL_VERSION)]
***************
*** 85,90 ****
--- 82,88 ----
#: >>>>>Compiler-specific options <<<<<
.ifdef GNUC
.first
+ @ @[.vms]fndvers.com "" "" "[.vms]descrip.mms"
@ If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]
CC = gcc
# -fno-builtin avoids bug in gcc up to version 2.6.2 which can destroy
***************
*** 108,113 ****
--- 106,112 ----
# just in case.
.first
@ Set Process/Privilege=(NoSYSNAM)
+ @ @[.vms]fndvers.com "" "" "[.vms]descrip.mms"
@ If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include
.ifdef __AXP__
@ If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS Sys$Library
***************
*** 120,125 ****
--- 119,125 ----
XTRADEF =
.else # VAXC
.first
+ @ @[.vms]fndvers.com "" "" "[.vms]descrip.mms"
@ If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library
@ If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include
***************
*** 214,220 ****
h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h
h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS)
! c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c
c2 = perl.c, perly.c, pp.c, pp_hot.c, pp_ctl.c, pp_sys.c, regcomp.c, regexec.c
c3 = gv.c, sv.c, taint.c, toke.c, util.c, deb.c, run.c, globals.c, vms.c $(SOCKCLIS)
--- 214,220 ----
h4 = regexp.h, scope.h, sv.h, vmsish.h, util.h
h = $(h1), $(h2), $(h3), $(h4) $(SOCKHLIS)
! c1 = av.c, scope.c, op.c, doop.c, doio.c, dump.c, hv.c, mg.c, universal.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)
***************
*** 222,228 ****
obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O)
obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O)
! obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), globals$(O), vms$(O) $(SOCKOBJ)
obj = $(obj1), $(obj2), $(obj3)
--- 222,228 ----
obj1 = perl$(O), gv$(O), toke$(O), perly$(O), op$(O), regcomp$(O), dump$(O), util$(O), mg$(O)
obj2 = hv$(O), av$(O), run$(O), pp_hot$(O), sv$(O), pp$(O), scope$(O), pp_ctl$(O), pp_sys$(O)
! obj3 = doop$(O), doio$(O), regexec$(O), taint$(O), deb$(O), universal$(O), globals$(O), vms$(O) $(SOCKOBJ)
obj = $(obj1), $(obj2), $(obj3)
***************
*** 263,273 ****
.endif
! all : base extras archcorefiles preplibrary perlpods
@ $(NOOP)
base : miniperl perl
@ $(NOOP)
! extras : Fcntl FileHandle Safe libmods utils podxform
@ $(NOOP)
libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm
@ $(NOOP)
--- 263,273 ----
.endif
! all : base extras libmods utils podxform archcorefiles preplibrary perlpods
@ $(NOOP)
base : miniperl perl
@ $(NOOP)
! extras : Fcntl FileHandle IO Opcode libmods utils podxform
@ $(NOOP)
libmods : [.lib]Config.pm $(ARCHDIR)Config.pm [.lib]DynaLoader.pm [.lib.VMS]Filespec.pm
@ $(NOOP)
***************
*** 295,301 ****
@ Continue
miniperl_objs = miniperlmain$(O), $(obj)
$(MINIPERL_EXE) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
! Link $(LINKFLAGS)/NoDebug/Exe=$(MMS$TARGET) miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
$(DBG)miniperl$(E) : $(miniperl_objs), $(DBG)libperl$(OLB) $(CRTL)
Link $(LINKFLAGS)/Exe=$(MMS$TARGET) miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
--- 295,301 ----
@ Continue
miniperl_objs = miniperlmain$(O), $(obj)
$(MINIPERL_EXE) : miniperlmain$(O), $(DBG)libperl$(OLB) $(CRTL)
! Link $(LINKFLAGS)/NoDebug/NoMap/NoFull/NoCross/Exe=$(MMS$TARGET) miniperlmain$(O), $(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
$(DBG)miniperl$(E) : $(miniperl_objs), $(DBG)libperl$(OLB) $(CRTL)
Link $(LINKFLAGS)/Exe=$(MMS$TARGET) miniperlmain$(O),$(DBG)libperl$(OLB)/Library/Include=globals $(CRTLOPTS)
***************
*** 313,321 ****
$(DBG)perl$(E) : perlmain$(O), $(DBG)perlshr$(E), $(MINIPERL_EXE)
@ @[.vms]genopt "PerlShr.Opt/Write" "|" "''F$Environment("Default")'$(DBG)PerlShr$(E)/Share"
.ifdef gnuc
! @ @[.vms]genopt "PerlShr.Opt/Append" "|" "$(LIBS1)|$(LIBS2)"
! .endif
Link $(LINKFLAGS)/Exe=$(MMS$TARGET) perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option
$(DBG)perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts
Link /NoTrace$(LINKFLAGS)/Share=$(MMS$TARGET) $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option
--- 313,322 ----
$(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=$(MMS$TARGET) perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option, crtl.opt/Option
! .else
Link $(LINKFLAGS)/Exe=$(MMS$TARGET) perlmain$(O), perlshr.opt/Option, perlshr_attr.opt/Option
+ .endif
$(DBG)perlshr$(E) : $(DBG)libperl$(OLB) $(extobj) $(DBG)perlshr_xtras.ts
Link /NoTrace$(LINKFLAGS)/Share=$(MMS$TARGET) $(extobj) []$(DBG)perlshr_bld.opt/Option, perlshr_attr.opt/Option
***************
*** 369,392 ****
@ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]DynaLoader.pm
! Safe : [.lib]Safe.pm [.lib.auto.Safe]Safe$(E)
@ $(NOOP)
! [.lib]Safe.pm : [.ext.Safe]Descrip.MMS
@ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
! @ Set Default [.ext.Safe]
$(MMS)
@ Set Default [--]
! [.lib.auto.Safe]Safe$(E) : [.ext.Safe]Descrip.MMS
! @ Set Default [.ext.Safe]
$(MMS)
@ Set Default [--]
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
! [.ext.Safe]Descrip.MMS : [.ext.Safe]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
! $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Safe]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
FileHandle : [.lib]FileHandle.pm [.lib.auto.FileHandle]FileHandle$(E)
@ $(NOOP)
--- 370,405 ----
@ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
@ $(MINIPERL) -e "use AutoSplit; autosplit_lib_modules(@ARGV)" [.lib]DynaLoader.pm
! Opcode : [.lib]Opcode.pm [.lib]ops.pm [.lib]Safe.pm [.lib.auto.Opcode]Opcode$(E)
@ $(NOOP)
! [.lib]Opcode.pm : [.ext.Opcode]Descrip.MMS
@ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
! @ Set Default [.ext.Opcode]
$(MMS)
@ Set Default [--]
! [.lib]ops.pm : [.ext.Opcode]Descrip.MMS
! @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
! @ Set Default [.ext.Opcode]
! $(MMS)
! @ Set Default [--]
!
! [.lib]Safe.pm : [.ext.Opcode]Descrip.MMS
! @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
! @ Set Default [.ext.Opcode]
! $(MMS)
! @ Set Default [--]
!
! [.lib.auto.Opcode]Opcode$(E) : [.ext.Opcode]Descrip.MMS
! @ Set Default [.ext.Opcode]
$(MMS)
@ Set Default [--]
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
! [.ext.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)
@ $(NOOP)
***************
*** 404,410 ****
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
! [.ext.FileHandle]Descrip.MMS : [.ext.FileHandle]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.FileHandle]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
--- 417,423 ----
# 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]"
Fcntl : [.lib]Fcntl.pm [.lib.auto.Fcntl]Fcntl$(E)
***************
*** 423,431 ****
# Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
# ${@} necessary to distract different versions of MM[SK]/make
! [.ext.Fcntl]Descrip.MMS : [.ext.Fcntl]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm perlshr$(E)
$(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.Fcntl]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
@ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
--- 436,493 ----
# 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]"
+ IO : [.lib]IO.pm [.lib.IO]File.pm [.lib.IO]Handle.pm [.lib.IO]Pipe.pm [.lib.IO]Seekable.pm [.lib.IO]Socket.pm [.lib.auto.IO]IO$(E)
+ @ $(NOOP)
+
+ [.lib]IO.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.IO]File.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.IO]Handle.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.IO]Pipe.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.IO]Seekable.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.IO]Socket.pm : [.ext.IO]Descrip.MMS
+ @ If F$Search("[.lib]auto.dir").eqs."" Then Create/Directory [.lib.auto]
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ [.lib.auto.IO]IO$(E) : [.ext.IO]Descrip.MMS
+ @ Set Default [.ext.IO]
+ $(MMS)
+ @ Set Default [--]
+
+ # Add "-I[--.lib]" t $(MINIPERL) so we use this copy of lib after C<chdir>
+ # ${@} necessary to distract different versions of MM[SK]/make
+ [.ext.IO]Descrip.MMS : [.ext.IO]Makefile.PL $(ARCHDIR)Config.pm [.lib.VMS]Filespec.pm [.lib]DynaLoader.pm $(DBG)perlshr$(E)
+ $(MINIPERL) "-I[--.lib]" -e "chdir('[.ext.IO]') or die $!; do 'Makefile.PL'; print ${@} if ${@};" "INST_LIB=[--.lib]" "INST_ARCHLIB=[--.lib]"
+
[.lib.VMS]Filespec.pm : [.vms.ext]Filespec.pm
@ If F$Search("[.lib]VMS.Dir").eqs."" Then Create/Directory [.lib.VMS]
Copy/Log/NoConfirm $(MMS$SOURCE) $(MMS$TARGET)
***************
*** 677,683 ****
.endif
test : all
! - @[.VMS]Test.Com
# CORE subset for MakeMaker, so we can build Perl without sources
# Should move to VMS installperl when we get one
--- 739,745 ----
.endif
test : all
! - @[.VMS]Test.Com "$(E)"
# CORE subset for MakeMaker, so we can build Perl without sources
# Should move to VMS installperl when we get one
***************
*** 967,972 ****
--- 1029,1057 ----
mg$(O) : sv.h
mg$(O) : vmsish.h
mg$(O) : util.h
+ universal$(O) : EXTERN.h
+ universal$(O) : av.h
+ universal$(O) : config.h
+ universal$(O) : cop.h
+ universal$(O) : cv.h
+ universal$(O) : embed.h
+ universal$(O) : form.h
+ universal$(O) : gv.h
+ universal$(O) : handy.h
+ universal$(O) : hv.h
+ universal$(O) : mg.h
+ universal$(O) : op.h
+ universal$(O) : opcode.h
+ universal$(O) : perl.h
+ universal$(O) : perly.h
+ universal$(O) : pp.h
+ universal$(O) : proto.h
+ universal$(O) : regexp.h
+ universal$(O) : scope.h
+ universal$(O) : sv.h
+ universal$(O) : vmsish.h
+ universal$(O) : util.h
+ universal$(O) : universal.c
perl$(O) : EXTERN.h
perl$(O) : av.h
perl$(O) : config.h
***************
*** 1442,1448 ****
- If F$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar
- If F$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O)
- If F$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C
! - If F$Search("[.Ext.Safe...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.Safe]
- If F$Search("[.Ext.FileHandle...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.FileHandle]
- If F$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*.C
- If F$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*$(O)
--- 1527,1533 ----
- If F$Search("Perlshr_Gbl*.Mar;-1") .nes."" Then Purge/NoConfirm/Log Perlshr_Gbl*.Mar
- If F$Search("[.Ext.DynaLoader]DL_VMS$(O);-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS$(O)
- If F$Search("[.Ext.DynaLoader]DL_VMS.C;-1").nes."" Then Purge/NoConfirm/Log [.Ext.DynaLoader]DL_VMS.C
! - If F$Search("[.Ext.Opcode...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.Opcode]
- If F$Search("[.Ext.FileHandle...];-1").nes."" Then Purge/NoConfirm/Log [.Ext.FileHandle]
- If F$Search("[.VMS.Ext...]*.C;-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*.C
- If F$Search("[.VMS.Ext...]*$(O);-1").nes."" Then Purge/NoConfirm/Log [.VMS.Ext...]*$(O)
***************
*** 1465,1471 ****
Set Default [.ext.FileHandle]
- $(MMS) clean
Set Default [--]
! Set Default [.ext.Safe]
- $(MMS) clean
Set Default [--]
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
--- 1550,1559 ----
Set Default [.ext.FileHandle]
- $(MMS) clean
Set Default [--]
! Set Default [.ext.IO]
! - $(MMS) clean
! Set Default [--]
! Set Default [.ext.Opcode]
- $(MMS) clean
Set Default [--]
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*/Exclude=PerlShr_*.Opt
***************
*** 1495,1507 ****
Set Default [.ext.FileHandle]
- $(MMS) realclean
Set Default [--]
! Set Default [.ext.Safe]
- $(MMS) realclean
Set Default [--]
- If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);"
- If F$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
- If F$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
- If F$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;*
- If F$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;*
--- 1583,1599 ----
Set Default [.ext.FileHandle]
- $(MMS) realclean
Set Default [--]
! Set Default [.ext.IO]
! - $(MMS) realclean
! Set Default [--]
! Set Default [.ext.Opcode]
- $(MMS) realclean
Set Default [--]
- If F$Search("*$(OLB)").nes."" Then Delete/NoConfirm/Log *$(OLB);*
- If F$Search("*.Opt").nes."" Then Delete/NoConfirm/Log *.Opt;*
- $(MINIPERL) -e "use File::Path; rmtree(['lib/auto','lib/VMS','lib/$(ARCH)'],1,0);"
- If F$Search("[.Lib]DynaLoader.pm").nes."" Then Delete/NoConfirm/Log [.Lib]DynaLoader.pm;*
+ - If F$Search("[.Lib]Socket.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Socket.pm;*
- If F$Search("[.Lib]Config.pm").nes."" Then Delete/NoConfirm/Log [.Lib]Config.pm;*
- If F$Search("[.Lib]perlbug.").nes."" Then Delete/NoConfirm/Log [.Lib]perlbug.;*
- If F$Search("$(ARCHDIR)Config.pm").nes."" Then Delete/NoConfirm/Log $(ARCHDIR)Config.pm;*
#~ Document rmsexpand routine and move it to default export list
diff -Pcr perl5_003/vms/ext/Filespec.pm perl5_003_01/vms/ext/Filespec.pm
*** perl5_003/vms/ext/Filespec.pm Tue Feb 27 16:32:08 1996
--- perl5_003_01/vms/ext/Filespec.pm Tue Jun 25 09:50:23 1996
***************
*** 12,17 ****
--- 12,18 ----
=head1 SYNOPSIS
use VMS::Filespec;
+ $fullspec = rmsexpand('[.VMS]file.specification');
$vmsspec = vmsify('/my/Unix/file/specification');
$unixspec = unixify('my:[VMS]file.specification');
$path = pathify('my:[VMS.or.Unix.directory]specification.dir');
***************
*** 61,66 ****
--- 62,75 ----
The routines provided are:
+ =head2 rmsexpand
+
+ Uses the RMS $PARSE and $SEARCH services to expand the input
+ specification to its fully qualified form. (If the file does
+ not exist, the input specification is expanded as much as
+ possible.) If an error occurs, returns C<undef> and sets C<$!>
+ and C<$^E>.
+
=head2 vmsify
Converts a file specification to VMS syntax.
***************
*** 124,133 ****
require Exporter;
@ISA = qw( Exporter );
! @EXPORT = qw( &vmsify &unixify &pathify &fileify
! &vmspath &unixpath &candelete);
- @EXPORT_OK = qw( &rmsexpand );
1;
--- 133,141 ----
require Exporter;
@ISA = qw( Exporter );
! @EXPORT = qw( &vmsify &unixify &pathify &fileify
! &vmspath &unixpath &candelete &rmsexpand );
1;
***************
*** 142,148 ****
# should be adequate for most purposes.
# A sort-of sys$parse() replacement
! sub rmsexpand {
my($fspec,$defaults) = @_;
if (!$fspec) { return undef }
my($node,$dev,$dir,$name,$type,$ver,$dnode,$ddev,$ddir,$dname,$dtype,$dver);
--- 150,156 ----
# should be adequate for most purposes.
# A sort-of sys$parse() replacement
! sub rmsexpand ($;$) {
my($fspec,$defaults) = @_;
if (!$fspec) { return undef }
my($node,$dev,$dir,$name,$type,$ver,$dnode,$ddev,$ddir,$dname,$dtype,$dver);
#~ Add tests for VMS-Unix file syntax conversion routines
diff -Pcr perl5_003/vms/ext/filespec.t perl5_003_01/vms/ext/filespec.t
*** perl5_003/vms/ext/filespec.t Wed Dec 31 19:00:00 1969
--- perl5_003_01/vms/ext/filespec.t Thu Jun 27 15:13:01 1996
***************
*** 0 ****
--- 1,88 ----
+ #!./perl
+
+ use VMS::Filespec;
+
+ foreach (<DATA>) {
+ chomp;
+ s/\s*#.*//;
+ next if /^\s*$/;
+ push(@tests,$_);
+ }
+ print '1..',scalar(@tests)+1,"\n";
+
+ foreach $test (@tests) {
+ ($arg,$func,$expect) = split(/\t+/,$test);
+ $idx++;
+ $rslt = eval "$func('$arg')";
+ if ($@) { print "not ok $idx : eval error: $@\n"; next; }
+ else {
+ if ($rslt ne $expect) {
+ print "not ok $idx : $func('$arg') expected |$expect|, got |$rslt|\n";
+ }
+ else { print "ok $idx\n"; }
+ }
+ }
+
+ print +(rmsexpand('[]') eq "\U$ENV{DEFAULT}" ? 'ok ' : 'not ok '),++$idx,"\n";
+
+ __DATA__
+
+ # Basic VMS to Unix filespecs
+ some:[where.over]the.rainbow unixify /some/where/over/the.rainbow
+ [.some.where.over]the.rainbow unixify some/where/over/the.rainbow
+ [-.some.where.over]the.rainbow unixify ../some/where/over/the.rainbow
+ [.some.--.where.over]the.rainbow unixify some/../../where/over/the.rainbow
+ [] unixify ./
+ [-] unixify ../
+ [--] unixify ../../
+
+ # and back again
+ /some/where/over/the.rainbow vmsify some:[where.over]the.rainbow
+ some/where/over/the.rainbow vmsify [.some.where.over]the.rainbow
+ ../some/where/over/the.rainbow vmsify [-.some.where.over]the.rainbow
+ some/../../where/over/the.rainbow vmsify [-.where.over]the.rainbow
+ . vmsify []
+ .. vmsify [-]
+ ../.. vmsify [--]
+
+ # Fileifying directory specs
+ down:[the.garden.path] fileify down:[the.garden]path.dir;1
+ [.down.the.garden.path] fileify [.down.the.garden]path.dir;1
+ /down/the/garden/path fileify /down/the/garden/path.dir;1
+ /down/the/garden/path/ fileify /down/the/garden/path.dir;1
+ down/the/garden/path fileify down/the/garden/path.dir;1
+ down:[the.garden]path fileify down:[the.garden]path.dir;1
+ down:[the.garden]path. fileify # N.B. trailing . ==> null type
+ down:[the]garden.path fileify
+ /down/the/garden/path. fileify # N.B. trailing . ==> null type
+ /down/the/garden.path fileify
+
+ # and pathifying them
+ down:[the.garden]path.dir;1 pathify down:[the.garden.path]
+ [.down.the.garden]path.dir pathify [.down.the.garden.path]
+ /down/the/garden/path.dir pathify /down/the/garden/path/
+ down/the/garden/path.dir pathify down/the/garden/path/
+ down:[the.garden]path pathify down:[the.garden.path]
+ down:[the.garden]path. pathify # N.B. trailing . ==> null type
+ down:[the]garden.path pathify
+ /down/the/garden/path. pathify # N.B. trailing . ==> null type
+ /down/the/garden.path pathify
+ down:[the.garden]path.dir;2 pathify #N.B. ;2
+ path pathify path/
+ path.notdir pathify
+
+ # Both VMS/Unix and file/path conversions
+ down:[the.garden]path.dir;1 unixpath /down/the/garden/path/
+ /down/the/garden/path vmspath down:[the.garden.path]
+ down:[the.garden.path] unixpath /down/the/garden/path/
+ /down/the/garden/path.dir vmspath down:[the.garden.path]
+ [.down.the.garden]path.dir unixpath down/the/garden/path/
+ down/the/garden/path vmspath [.down.the.garden.path]
+ path vmspath [.path]
+
+ # Redundant characters in Unix paths
+ /some/where//over/./the.rainbow vmsify some:[where.over]the.rainbow
+ ..//../ vmspath [--]
+ ./././ vmspath []
+ ./../. vmsify [-]
+
#~ Catch oddball global when using gcc
diff -Pcr perl5_003/vms/gen_shrfls.pl perl5_003_01/vms/gen_shrfls.pl
*** perl5_003/vms/gen_shrfls.pl Mon Mar 25 01:06:00 1996
--- perl5_003_01/vms/gen_shrfls.pl Thu Jul 18 17:37:13 1996
***************
*** 257,262 ****
--- 257,270 ----
print STDERR "Unrecognized enum constant \"$_\" ignored\n";
}
}
+ elsif ($isgcc) {
+ # gcc creates this as a SHR,WRT psect in globals.c, but we
+ # don't see it in the perl.h scan, since it's only declared
+ # if DOINIT is #defined. Bleah. It's cheaper to just add
+ # it by hand than to add /Define=DOINIT to the preprocessing
+ # run and wade through all the extra junk.
+ $vars{'Error'}++;
+ }
# Eventually, we'll check against existing copies here, so we can add new
# symbols to an existing options file in an upwardly-compatible manner.
#~ Move several values up to initial set of declarations
#~ Determine gcc version
#~ Add several socket-dependent values
#~ Add file-type values
#~ Use names of shell vars corresponding to cpp manifests, rather then
#~ the names of the manifests themselves
#~ Add d_eunice value, since Configure equates it with VMS :-(
#~ Eliminiate list of hand-configured values
diff -Pcr perl5_003/vms/genconfig.pl perl5_003_01/vms/genconfig.pl
*** perl5_003/vms/genconfig.pl Mon Mar 25 01:05:59 1996
--- perl5_003_01/vms/genconfig.pl Thu Jul 18 21:06:32 1996
***************
*** 6,14 ****
# that went into your perl binary. In addition, values which change from run
# to run may be supplied on the command line as key=val pairs.
#
! # Rev. 13-Dec-1995 Charles Bailey bailey@genetics.upenn.edu
#
unshift(@INC,'lib'); # In case someone didn't define Perl_Root
# before the build
--- 6,22 ----
# 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
#
+ #==== Locations of installed Perl components
+ $prefix='perl_root';
+ $builddir="$prefix:[000000]";
+ $installbin="$prefix:[000000]";
+ $installman1dir="$prefix:[man.man1]";
+ $installman3dir="$prefix:[man.man3]";
+ $installprivlib="$prefix:[lib]";
+
unshift(@INC,'lib'); # In case someone didn't define Perl_Root
# before the build
***************
*** 37,42 ****
--- 45,57 ----
open(OUT,">${outdir}Config.sh") || die "Can't open ${outdir}Config.sh: $!\n";
$time = localtime;
+ $cf_by = (getpwuid($<))[0];
+ $archsufx = `Write Sys\$Output F\$GetSyi("HW_MODEL")` > 1024 ? 'AXP' : 'VAX';
+ ($vers = $]) =~ tr/./_/;
+ $installarchlib = VMS::Filespec::vmspath($installprivlib);
+ $installarchlib =~ s#\]#.VMS_$archsufx.$vers\]#;
+ ($osvers = `Write Sys\$Output F\$GetSyi("VERSION")`) =~ s/^V?(\S+)\s*\n?$/$1/;
+
print OUT <<EndOfIntro;
# This file generated by GenConfig.pl on a VMS system.
# Input obtained from:
***************
*** 47,52 ****
--- 62,72 ----
package='perl5'
CONFIG='true'
cf_time='$time'
+ cf_by='$cf_by'
+ ccdlflags=''
+ cccdlflags=''
+ mab=''
+ libpth='/sys\$share /sys\$library'
ld='Link'
lddlflags='/Share'
ranlib=''
***************
*** 58,84 ****
alignbytes='8'
shrplib='define'
usemymalloc='n'
spitshell='write sys\$output '
EndOfIntro
- $cf_by = (getpwuid($<))[0];
- print OUT "cf_by='$cf_by'\n";
-
- $hw_model = `Write Sys\$Output F\$GetSyi("HW_MODEL")`;
- chomp $hw_model;
- if ($hw_model > 1024) {
- print OUT "arch='VMS_AXP'\n";
- print OUT "archname='VMS_AXP'\n";
- $archsufx = "AXP";
- }
- else {
- print OUT "arch='VMS_VAX'\n";
- print OUT "archname='VMS_VAX'\n";
- $archsufx = 'VAX';
- }
- $osvers = `Write Sys\$Output F\$GetSyi("VERSION")`;
- $osvers =~ s/^V?(\S+)\s*\n?$/$1/;
- print OUT "osvers='$osvers'\n";
foreach (@ARGV) {
($key,$val) = split('=',$_,2);
if ($key eq 'cc') { # Figure out which C compiler we're using
--- 78,102 ----
alignbytes='8'
shrplib='define'
usemymalloc='n'
+ usevfork='true'
+ useposix='false'
spitshell='write sys\$output '
+ dlsrc='dl_vms.c'
+ binexp='$installbin'
+ man1ext='rno'
+ man3ext='rno'
+ arch='VMS_$archsufx'
+ archname='VMS_$archsufx'
+ osvers='$osvers'
+ prefix='$prefix'
+ builddir='$builddir'
+ installbin='$installbin'
+ installman1dir='$installman1dir'
+ installman3dir='$installman3dir'
+ installprivlib='$installprivlib'
+ installarchlib='$installarchlib'
EndOfIntro
foreach (@ARGV) {
($key,$val) = split('=',$_,2);
if ($key eq 'cc') { # Figure out which C compiler we're using
***************
*** 95,103 ****
$cctype = 'vaxc';
$d_attr = 'undef';
}
! elsif (`$val/NoObject/NoList _nla0:/Version` =~ /GNU/) {
$cctype = 'gcc';
$d_attr = 'define';
}
elsif ($archsufx eq 'VAX' &&
`$val/NoObject/NoList /prefix=all _nla0:` =~ /IVQUAL/) {
--- 113,122 ----
$cctype = 'vaxc';
$d_attr = 'undef';
}
! elsif (`$val/NoObject/NoList _nla0:/Version` =~ /GNU C version (\S+)/) {
$cctype = 'gcc';
$d_attr = 'define';
+ print OUT "gccversion='$1'\n";
}
elsif ($archsufx eq 'VAX' &&
`$val/NoObject/NoList /prefix=all _nla0:` =~ /IVQUAL/) {
***************
*** 120,128 ****
print OUT "ccflags='$ccflags'\n";
$dosock = ($ccflags =~ m!/DEF[^/]+VMS_DO_SOCKETS!i and
$ccflags !~ m!/UND[^/]+VMS_DO_SOCKETS!i);
next;
}
! print OUT "$key=\'$val\'\n";
}
# Are there any other logicals which TCP/IP stacks use for the host name?
--- 139,160 ----
print OUT "ccflags='$ccflags'\n";
$dosock = ($ccflags =~ m!/DEF[^/]+VMS_DO_SOCKETS!i and
$ccflags !~ m!/UND[^/]+VMS_DO_SOCKETS!i);
+ print OUT "d_vms_do_sockets=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "d_socket=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "d_sockpair=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "d_gethent=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "d_select=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "i_niin=",$dosock ? "'define'\n" : "'undef'\n";
+ print OUT "i_neterrno=",$dosock ? "'define'\n" : "'undef'\n";
next;
}
! elsif ($key eq 'exe_ext') {
! my($nodot) = $val;
! $nodot =~ s!\.!!;
! print OUT "so='$nodot'\ndlext='$nodot'\n";
! }
! elsif ($key eq 'obj_ext') { print OUT "dlobj='dl_vms$val'\n"; }
! print OUT "$key='$val'\n";
}
# Are there any other logicals which TCP/IP stacks use for the host name?
***************
*** 152,157 ****
--- 184,216 ----
$hwname = $archsufx if $hwname =~ /IVKEYW/; # *really* old VMS version
print OUT "myuname='VMS $myname $osvers $hwname'\n";
+ # Before we read the C header file, find out what config.sh constants are
+ # equivalent to the C preprocessor macros
+ if (open(SH,"${outdir}config_h.SH")) {
+ while (<SH>) {
+ next unless m%^#(?!if).*\$%;
+ s/^#//; s!(.*?)\s*/\*.*!$1!;
+ my(@words) = split;
+ $words[1] =~ s/\(.*//; # Clip off args from macro
+ # Did we use a shell variable for the preprocessor directive?
+ if ($words[0] =~ m!^\$(\w+)!) { $pp_vars{$words[1]} = $1; }
+ if (@words > 2) { # We may also have a shell var in the value
+ shift @words; # Discard preprocessor directive
+ my($token) = shift @words; # and keep constant name
+ my($word);
+ foreach $word (@words) {
+ next unless $word =~ m!\$(\w+)!;
+ $val_vars{$token} = $1;
+ last;
+ }
+ }
+ }
+ close SH;
+ }
+ else { warn "Couldn't read ${outdir}config_h.SH: $!\n"; }
+ $pp_vars{UNLINK_ALL_VERSIONS} = 'd_unlink_all_versions'; # VMS_specific
+
+ # OK, now read the C header file, and retcon statements into config.sh
while (<IN>) { # roll through the comment header in Config.VMS
last if /config-start/;
}
***************
*** 165,218 ****
s/^\s*//;
$_ = $line . $_;
}
! next unless my ($blocked,$un,$token,$val) = m%^(\/\*)?\s*\#\s*(un)?def\w*\s*([A-za-z0-9]\w+)\S*\s*(.*)%;
! next if /config-skip/;
$state = ($blocked || $un) ? 'undef' : 'define';
! $token =~ tr/A-Z/a-z/;
! $token =~ s/_exp$/exp/; # Config.pm has 'privlibexp' etc. where config.h
! # has 'privlib_exp' etc.
! # Fixup differences between Configure vars and config.h manifests
! # This isn't comprehensize; we fix 'em as we need 'em.
! $token = 'castneg' if $token eq 'castnegfloat';
! $token = 'dlsymun' if $token eq 'dlsym_needs_underscore';
! $token = 'stdstdio' if $token eq 'use_stdio_ptr';
! $token = 'stdiobase' if $token eq 'use_stdio_base';
! $val =~ s%/\*.*\*/\s*%%g; $val =~ s/\s*$//; # strip off trailing comment
! $val =~ s/^"//; $val =~ s/"$//; # remove end quotes
! $val =~ s/","/ /g; # make signal list look nice
! if ($val) { print OUT "$token=\'$val\'\n"; }
! else {
$token = "d_$token" unless $token =~ /^i_/;
print OUT "$token='$state'\n";
}
}
close IN;
! while (<DATA>) {
! next if /^\s*#/ or /^\s*$/;
! s/#.*$//; s/\s*$//;
! ($key,$val) = split('=',$_,2);
! print OUT "$key='$val'\n";
! eval "\$$key = '$val'";
}
- # Add in some of the architecture-dependent stuff which has to be consistent
- print OUT "d_vms_do_sockets=",$dosock ? "'define'\n" : "'undef'\n";
- print OUT "d_has_sockets=",$dosock ? "'define'\n" : "'undef'\n";
- $archlib = &VMS::Filespec::vmspath($privlib);
- $installarchlib = &VMS::Filespec::vmspath($installprivlib);
- $sitearch = &VMS::Filespec::vmspath($sitelib);
- $archlib =~ s#\]#.VMS_$archsufx\]#;
- $sitearch =~ s#\]#.VMS_$archsufx\]#;
- print OUT "oldarchlib='$archlib'\n";
- print OUT "oldarchlibexp='$archlib'\n";
- ($vers = $]) =~ tr/./_/;
- $archlib =~ s#\]#.$vers\]#;
- $installarchlib =~ s#\]#.VMS_$archsufx.$vers\]#;
- print OUT "archlib='$archlib'\n";
- print OUT "archlibexp='$archlib'\n";
- print OUT "installarchlib='$installarchlib'\n";
- print OUT "sitearch='$sitearch'\n";
- print OUT "sitearchexp='$sitearch'\n";
if (open(OPT,"${outdir}crtl.opt")) {
while (<OPT>) {
--- 224,284 ----
s/^\s*//;
$_ = $line . $_;
}
! next unless my ($blocked,$un,$token,$val) =
! m%^(\/\*)?\s*\#\s*(un)?def\w*\s+([A-Za-z0-9]\w+)\S*\s*(.*)%;
! if (/config-skip/) {
! delete $pp_vars{$token} if exists $pp_vars{$token};
! delete $val_vars{$token} if exists $val_vars{$token};
! next;
! }
! $val =~ s!\s*/\*.*!!; # strip off trailing comment
! my($had_val); # Maybe a macro with args that we just #undefd or commented
! if (!length($val) and $val_vars{$token} and ($un || $blocked)) {
! print OUT "$val_vars{$token}=''\n";
! delete $val_vars{$token};
! $had_val = 1;
! }
$state = ($blocked || $un) ? 'undef' : 'define';
! if ($pp_vars{$token}) {
! print OUT "$pp_vars{$token}='$state'\n";
! delete $pp_vars{$token};
! }
! elsif (not length $val and not $had_val) {
! # Wups -- should have been shell var for C preprocessor directive
! warn "Constant $token not found in config_h.SH\n";
! $token =~ tr/A-Z/a-z/;
$token = "d_$token" unless $token =~ /^i_/;
print OUT "$token='$state'\n";
}
+ next unless length $val;
+ $val =~ s/^"//; $val =~ s/"$//; # remove end quotes
+ $val =~ s/","/ /g; # make signal list look nice
+ # Library directory; convert to VMS syntax
+ $val = VMS::Filespec::vmspath($val) if ($token =~ /EXP$/);
+ if ($val_vars{$token}) {
+ print OUT "$val_vars{$token}='$val'\n";
+ if ($val_vars{$token} =~ s/exp$//) {print OUT "$val_vars{$token}='$val'\n";}
+ delete $val_vars{$token};
+ }
+ elsif (!$pp_vars{$token}) { # Haven't seen it previously, either
+ warn "Constant $token not found in config_h.SH (val=|$val|)\n";
+ $token =~ tr/A-Z/a-z/;
+ print OUT "$token='$val'\n";
+ if ($token =~ s/exp$//) {print OUT "$token='$val'\n";}
+ }
}
close IN;
+ # Special case -- preprocessor manifest "VMS" is defined automatically
+ # on VMS systems, but is also used erroneously by the Perl build process
+ # as the manifest for the obsolete variable $d_eunice.
+ print OUT "d_eunice='undef'\n"; delete $pp_vars{VMS};
! foreach (sort keys %pp_vars) {
! warn "Didn't see $_ in $infile\n";
! }
! foreach (sort keys %val_vars) {
! warn "Didn't see $_ in $infile(val)\n";
}
if (open(OPT,"${outdir}crtl.opt")) {
while (<OPT>) {
***************
*** 237,243 ****
}
else { warn "Can't read ${outdir}patchlevel.h - skipping 'PATCHLEVEL'"; }
! # simple pager support for perldoc
if (`most` =~ /IVVERB/) {
$pager = 'more';
if (`more nl:` =~ /IVVERB/) { $pager = 'type/page'; }
--- 303,309 ----
}
else { warn "Can't read ${outdir}patchlevel.h - skipping 'PATCHLEVEL'"; }
! # simple pager support for perldoc
if (`most` =~ /IVVERB/) {
$pager = 'more';
if (`more nl:` =~ /IVVERB/) { $pager = 'type/page'; }
***************
*** 246,281 ****
print OUT "pager='$pager'\n";
close OUT;
- __END__
-
- # This list is incomplete in comparison to what ends up in config.sh, but
- # should contain the essentials. Some of these definitions reflect
- # options chosen when building perl or site-specific data; these should
- # be hand-edited appropriately. Someday, perhaps, we'll get this automated.
-
- # The definitions in this block are constant across most systems, and
- # should only rarely need to be changed.
- ccdlflags=
- cccdlflags=
- usedl=true
- dlobj=dl_vms.obj
- dlsrc=dl_vms.c
- so=exe
- dlext=exe
- libpth=/sys$share /sys$library
- usevfork=false
- castflags=0
- signal_t=void
- timetype=long
- builddir=perl_root:[000000]
- prefix=perl_root
- installprivlib=perl_root:[lib] # The *lib constants should match the
- privlib=perl_root:[lib] # equivalent *(?:ARCH)LIB_EXP constants
- sitelib=perl_root:[lib.site_perl] # in config.h
- installbin=perl_root:[000000]
- installman1dir=perl_root:[man.man1]
- installman3dir=perl_root:[man.man3]
- man1ext=rno
- man3ext=rno
- binexp=perl_root:[000000] # should be same as installbin
- useposix=false
--- 312,314 ----
#~ Fix type osver --> osvers
diff -Pcr perl5_003/vms/myconfig.com perl5_003_01/vms/myconfig.com
*** perl5_003/vms/myconfig.com Mon Mar 25 01:06:03 1996
--- perl5_003_01/vms/myconfig.com Thu Jul 11 10:09:33 1996
***************
*** 299,305 ****
$ ECHO " "
$ ECHO "Summary of my ''$package' (patchlevel ''$PATCHLEVEL' subversion ''$SUBVERSION') configuration:"
$ ECHO " Platform:"
! $ ECHO " osname=''$osname', osver=''$osvers', archname=''$archname'"
$ ECHO " uname=''$myuname'" !->d_has_uname?
$ ECHO " hint=''$hint' d_sigaction='undef'" !->hintfile?
$ ECHO " static exts=''$staticexts'" ! added for VMS
--- 299,305 ----
$ ECHO " "
$ ECHO "Summary of my ''$package' (patchlevel ''$PATCHLEVEL' subversion ''$SUBVERSION') configuration:"
$ ECHO " Platform:"
! $ ECHO " osname=''$osname', osvers=''$osvers', archname=''$archname'"
$ ECHO " uname=''$myuname'" !->d_has_uname?
$ ECHO " hint=''$hint' d_sigaction='undef'" !->hintfile?
$ ECHO " static exts=''$staticexts'" ! added for VMS
#~ Mention VMS::Filespec routines in discussion of file syntax
#~ Update documentation of binmode() -- now used as a hook for
#~ disabling carriage control interpretation on record-structured files
#~ Mention that the CORE "time" operator returns a Unix-like time
diff -Pcr perl5_003/vms/perlvms.pod perl5_003_01/vms/perlvms.pod
*** perl5_003/vms/perlvms.pod Mon Mar 25 01:06:06 1996
--- perl5_003_01/vms/perlvms.pod Thu Jul 25 16:21:20 1996
***************
*** 165,176 ****
style file specifications wherever possible. You may use
either style, or both, on the command line and in scripts,
but you may not combine the two styles within a single fle
! specification. Filenames are, of course, still case-
! insensitive. For consistency, most Perl routines return
! filespecs using lower case letters only, regardless of the
! case used in the arguments passed to them. (This is true
! only when running under VMS; Perl respects the case-
! sensitivity of OSs like Unix.)
We've tried to minimize the dependence of Perl library
modules on Unix syntax, but you may find that some of these,
--- 165,184 ----
style file specifications wherever possible. You may use
either style, or both, on the command line and in scripts,
but you may not combine the two styles within a single fle
! specification. VMS Perl interprets Unix pathnames in much
! the same way as the CRTL (I<e.g.> the first component of
! an absolute path is read as the device name for the
! VMS file specification). There are a set of functions
! provided in the C<VMS::Filespec> package for explicit
! interconversion between VMS and Unix syntax; its
! documentation provides more details.
!
! Filenames are, of course, still case-insensitive. For
! consistency, most Perl routines return filespecs using
! lower case letters only, regardless of the case used in
! the arguments passed to them. (This is true only when
! running under VMS; Perl respects the case-sensitivity
! of OSs like Unix.)
We've tried to minimize the dependence of Perl library
modules on Unix syntax, but you may find that some of these,
***************
*** 351,359 ****
=item binmode FILEHANDLE
! The C<binmode> operator has no effect under VMS. It will
! return TRUE whenever called, but will not affect I/O
! operations on the filehandle given as its argument.
=item crypt PLAINTEXT, USER
--- 359,377 ----
=item binmode FILEHANDLE
! The C<binmode> operator will attempt to insure that no translation
! of carriage control occurs on input from or output to this filehandle.
! Since this involves reopening the file and then restoring its
! file position indicator, if this function returns FALSE, the
! underlying filehandle may no longer point to an open file, or may
! point to a different position in the file than before C<binmode>
! was called.
!
! Note that C<binmode> is generally not necessary when using normal
! filehandles; it is provided so that you can control I/O to existing
! record-structured files when necessary. You can also use the
! C<vmsfopen> function in the VMS::Stdio extension to gain finer
! control of I/O to files and devices with different record structures.
=item crypt PLAINTEXT, USER
***************
*** 502,507 ****
--- 520,531 ----
in the same fashion as typiing B<SPAWN> at the DCL prompt.
Perl waits for the subprocess to complete before continuing
execution in the current process.
+
+ =item time
+
+ The value returned by C<time> is the offset in seconds from
+ 01-JAN-1970 00:00:00 (just like the CRTL's times() routine), in order
+ to make life easier for code coming in from the POSIX/Unix world.
=item times
#~ Update to reflect changes in perly.y
#~ Use safefree instead of Safefree to free memory allocated by safemalloc
#~ Allow redirection of debug messages
diff -Pcr perl5_003/vms/perly_c.vms perl5_003_01/vms/perly_c.vms
*** perl5_003/vms/perly_c.vms Wed Feb 14 18:49:04 1996
--- perl5_003_01/vms/perly_c.vms Sun Jul 7 10:04:02 1996
***************
*** 38,44 ****
6, 6, 4, 4, 0, 2, 7, 7, 5, 5,
8, 7, 10, 3, 0, 1, 0, 1, 0, 1,
1, 1, 1, 1, 4, 3, 5, 5, 0, 1,
! 0, 3, 2, 5, 3, 3, 1, 2, 3, 1,
3, 5, 6, 3, 5, 2, 4, 4, 1, 1,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 5, 3, 2, 2, 2, 2, 2, 2,
--- 38,44 ----
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,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 5, 3, 2, 2, 2, 2, 2, 2,
***************
*** 76,90 ****
55, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 69, 0, 70,
0, 0, 0, 0, 0, 0, 0, 120, 0, 48,
! 47, 54, 3, 0, 141, 0, 68, 101, 0, 29,
0, 30, 0, 0, 0, 23, 0, 24, 0, 0,
0, 140, 149, 67, 0, 125, 0, 127, 0, 99,
0, 0, 0, 0, 0, 0, 0, 107, 0, 105,
! 0, 116, 0, 121, 65, 0, 0, 0, 0, 19,
! 0, 0, 0, 0, 0, 62, 126, 128, 115, 0,
! 113, 0, 0, 106, 0, 111, 117, 103, 142, 27,
! 28, 21, 0, 22, 0, 32, 0, 114, 112, 63,
! 0, 0, 31, 0, 0, 20, 33,
};
dEXT short yydgoto[] = { 1,
9, 10, 83, 17, 86, 3, 11, 12, 66, 195,
--- 76,90 ----
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,
};
dEXT short yydgoto[] = { 1,
9, 10, 83, 17, 86, 3, 11, 12, 66, 195,
***************
*** 93,1105 ****
2, 14, 15, 16,
};
dEXT short yysindex[] = { 0,
! 0, 0, -82, 0, 0, 0, -52, 0, 0, 0,
! 0, 0, 853, 0, 0, 0, -80, -256, -19, 0,
! -245, 0, 0, 0, 19, 19, 0, 20, 0, 2177,
! 0, 0, -2, 1, 28, 41, 133, 2177, 27, 33,
! 52, 19, 1028, 2177, 1303, -210, 19, 2177, 965, 1359,
! 2177, 2177, 2177, 2177, 2177, 1415, 0, 2177, 2177, 1478,
! 19, 19, 19, 19, -225, 0, 71, 209, 1535, -49,
! -30, 0, 0, 8, 101, 42, 0, 30, 0, -112,
! 0, 2177, 0, 0, 0, 0, 0, 2177, 127, 2177,
! 1535, 30, -112, 2177, 30, 2177, 30, 2177, 30, 2177,
! 30, 1712, 128, 1535, 139, 1768, 965, 0, 141, 0,
! 1485, -14, 1485, 65, -42, 2177, 0, 71, 0, 71,
! -49, 0, 2177, 0, 1485, 334, 334, 334, -47, -47,
! 92, -26, 334, 334, 0, 63, 0, 0, 0, 0,
! 30, 0, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
! 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177, 2177,
! 2177, 2177, 2177, 2177, 0, 0, -27, 2177, 2177, 2177,
! 2177, 2177, 2177, 1824, 0, 0, 0, -48, 137, -92,
! 0, 2177, 221, 2177, 30, -191, 151, -225, -22, -225,
! -12, -147, 7, -147, 138, 5, 0, 2177, 0, 0,
! 9, -39, 160, 2177, 1887, 2121, 0, 77, 0, 71,
! 2177, 113, 0, 0, 1535, -191, -191, -191, -191, -86,
! 0, -20, 395, 1485, 1566, 461, -88, 1535, 4122, 1064,
! 679, 364, 1120, 728, 334, 334, 2177, 0, 2177, 0,
! 174, 89, 51, 98, 55, 118, 57, 0, 11, 0,
! 0, 0, 0, 175, 0, 2177, 0, 0, 30, 0,
! 30, 0, 30, 30, 178, 0, 30, 0, 2177, 30,
! 15, 0, 0, 0, 22, 0, 25, 0, 29, 0,
! 152, 2177, 94, 2177, 59, 177, 2177, 0, 96, 0,
! 97, 0, 102, 0, 0, 1190, -225, -225, -147, 0,
! 2177, -147, 176, -225, 30, 0, 0, 0, 0, 205,
! 0, 3039, 111, 0, 206, 0, 0, 0, 0, 0,
! 0, 0, 37, 0, 1712, 0, -225, 0, 0, 0,
! 30, 208, 0, -147, 30, 0, 0,
};
dEXT short yyrindex[] = { 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,
! 0, 0, 0, 0, 0, 0, 0, 2253, 505, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 2847, 2935,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 107, 0, -35, 10, 53, 3109,
! 3156, 0, 0, 2298, 1976, 0, 0, 0, 0, -23,
! 0, 230, 0, 0, 0, 0, 0, 2385, 0, 0,
! 1004, 0, 168, 253, 0, 0, 0, 0, 0, 0,
! 0, 254, 0, 2242, 0, 0, 274, 0, 2032, 0,
! 3844, 3109, 3902, 0, 0, 2385, 0, 2440, 452, 2554,
! 572, 0, 0, 0, 3981, 3274, 3312, 3421, 3200, 3237,
! 2661, 0, 3560, 3596, 0, 0, 0, 0, 0, 0,
! 0, 0, 2714, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 909,
! 0, 274, 0, 2385, 0, 39, 0, 107, 0, 107,
! 0, 170, 0, 170, 0, 262, 0, 0, 0, 0,
! 0, 288, 0, 0, 0, 0, 0, 0, 0, 2805,
! 0, 2757, 0, 0, 2650, 49, 58, 61, 64, 365,
! 0, 0, -31, 4018, 4028, 3719, 630, 2995, 0, 1623,
! 4106, 4096, 4064, 3756, 3640, 3683, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 277, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 274, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 107, 107, 170, 0,
! 0, 170, 0, 107, 0, 0, 0, 0, 0, 0,
! 0, 13, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 300, 0, 107, 0, 0, 0,
! 0, 0, 0, 170, 0, 0, 0,
};
dEXT short yygindex[] = { 0,
! 0, 0, 0, 506, -13, 255, 0, 0, 0, 18,
! -180, 839, -11, 4398, 2162, 0, 0, 0, 0, 0,
! 342, -57, -174, 1032, 90, 0, 0, 267, 0, -172,
0, 0, 0, 0,
};
! #define YYTABLESIZE 4682
dEXT short yytable[] = { 65,
! 80, 68, 168, 79, 273, 57, 20, 254, 61, 80,
! 250, 82, 80, 268, 212, 260, 208, 262, 261, 95,
! 97, 99, 101, 57, 179, 206, 80, 80, 263, 110,
! 181, 80, 253, 115, 150, 49, 124, 94, 283, 81,
! 96, 170, 23, 168, 132, 270, 116, 267, 136, 272,
! 13, 294, 141, 83, 61, 305, 83, 57, 209, 90,
! 172, 80, 306, 239, 176, 307, 105, 98, 13, 308,
! 83, 83, 106, 169, 23, 150, 170, 331, 184, 38,
! 100, 188, 186, 190, 189, 192, 191, 194, 193, 16,
! 196, 107, 171, 60, 201, 237, 60, 38, 17, 49,
! 175, 14, 148, 149, 15, 83, 25, 16, 169, 289,
! 60, 60, 315, 291, 143, 293, 17, 313, 322, 14,
! 23, 324, 15, 23, 320, 321, 257, 214, 264, 265,
! 173, 326, 216, 217, 218, 219, 220, 221, 222, 25,
! 174, 23, 25, 25, 25, 60, 25, 177, 25, 25,
! 23, 25, 23, 336, 333, 213, 242, 243, 244, 245,
! 246, 247, 249, 23, 251, 25, 182, 198, 61, 18,
! 25, 258, 102, 4, 5, 6, 78, 7, 8, 199,
! 205, 288, 211, 4, 5, 6, 271, 7, 8, 207,
! 290, 259, 275, 277, 279, 252, 269, 25, 154, 281,
! 274, 280, 18, 282, 19, 18, 18, 18, 149, 18,
! 292, 18, 18, 287, 18, 295, 163, 301, 311, 164,
! 316, 317, 165, 166, 167, 285, 318, 286, 18, 25,
! 238, 25, 25, 18, 325, 329, 57, 57, 57, 57,
! 80, 80, 80, 80, 309, 297, 330, 298, 335, 299,
! 300, 148, 149, 302, 148, 149, 304, 186, 57, 57,
! 18, 255, 80, 80, 256, 167, 80, 148, 149, 314,
! 310, 148, 149, 148, 149, 84, 144, 145, 146, 147,
! 85, 148, 149, 157, 83, 83, 83, 83, 145, 323,
! 49, 327, 18, 37, 18, 18, 2, 328, 148, 149,
! 148, 149, 148, 149, 148, 149, 83, 83, 148, 149,
! 83, 168, 35, 68, 147, 148, 149, 334, 148, 149,
! 13, 337, 148, 149, 60, 60, 60, 60, 148, 39,
! 148, 149, 39, 39, 39, 37, 39, 180, 39, 39,
! 35, 39, 332, 150, 148, 149, 60, 60, 148, 149,
! 148, 149, 148, 149, 76, 39, 148, 149, 303, 185,
! 39, 0, 25, 25, 25, 25, 25, 25, 0, 25,
25, 25, 25, 25, 25, 25, 25, 25, 25, 25,
! 25, 25, 148, 149, 0, 25, 25, 39, 25, 25,
! 25, 148, 149, 0, 0, 25, 25, 25, 25, 25,
! 0, 0, 25, 25, 0, 56, 0, 0, 56, 25,
! 0, 148, 149, 25, 0, 25, 25, 0, 0, 39,
! 0, 0, 39, 56, 168, 18, 18, 18, 18, 18,
! 18, 0, 18, 18, 18, 18, 18, 18, 18, 18,
! 18, 18, 18, 18, 18, 148, 149, 0, 18, 18,
! 0, 18, 18, 18, 168, 0, 150, 56, 18, 18,
! 18, 18, 18, 0, 0, 18, 18, 0, 0, 0,
! 148, 149, 18, 0, 0, 0, 18, 0, 18, 18,
! 144, 145, 146, 147, 156, 168, 150, 156, 156, 156,
! 0, 156, 143, 156, 156, 143, 156, 0, 148, 149,
! 0, 151, 148, 149, 0, 152, 153, 154, 155, 143,
! 143, 18, 0, 21, 143, 156, 0, 150, 156, 158,
! 159, 160, 161, 0, 162, 163, 0, 0, 164, 0,
! 0, 165, 166, 167, 0, 0, 92, 93, 0, 0,
! 0, 0, 143, 0, 143, 136, 0, 0, 136, 0,
! 0, 168, 39, 39, 39, 39, 39, 39, 0, 39,
! 39, 39, 136, 136, 0, 39, 0, 136, 39, 39,
! 39, 39, 0, 0, 143, 39, 39, 156, 39, 39,
! 39, 0, 0, 150, 0, 39, 39, 39, 39, 39,
! 0, 0, 39, 39, 0, 136, 0, 136, 0, 39,
! 0, 0, 0, 39, 157, 39, 39, 157, 157, 157,
! 0, 157, 102, 157, 157, 102, 157, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 136, 0, 102,
! 102, 0, 0, 0, 102, 157, 56, 56, 56, 56,
! 0, 164, 0, 0, 165, 166, 167, 0, 152, 153,
! 154, 155, 0, 0, 0, 0, 0, 0, 56, 0,
! 0, 0, 0, 0, 102, 161, 0, 162, 163, 0,
! 74, 164, 0, 74, 165, 166, 167, 0, 0, 152,
! 153, 154, 155, 0, 0, 0, 0, 74, 74, 0,
! 0, 0, 74, 158, 159, 160, 161, 157, 162, 163,
! 0, 0, 164, 0, 0, 165, 166, 167, 156, 156,
! 156, 156, 156, 0, 156, 156, 156, 0, 0, 0,
! 156, 0, 74, 143, 143, 143, 143, 0, 0, 0,
! 0, 156, 143, 156, 156, 156, 143, 143, 143, 143,
! 156, 156, 156, 156, 156, 143, 143, 156, 156, 143,
! 143, 143, 143, 143, 156, 143, 143, 0, 156, 143,
! 156, 156, 143, 143, 143, 163, 0, 0, 164, 168,
! 0, 165, 166, 167, 0, 0, 136, 136, 136, 136,
! 0, 0, 0, 0, 0, 136, 0, 0, 0, 136,
! 136, 136, 136, 0, 0, 0, 0, 0, 136, 136,
! 0, 150, 136, 136, 136, 136, 136, 0, 136, 136,
! 0, 0, 136, 0, 0, 136, 136, 136, 168, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 157, 157,
! 157, 157, 157, 0, 157, 157, 157, 0, 0, 0,
! 157, 0, 0, 102, 102, 102, 102, 0, 0, 0,
! 150, 157, 102, 157, 157, 157, 102, 102, 102, 102,
! 157, 157, 157, 157, 157, 102, 102, 157, 157, 102,
! 102, 102, 102, 102, 157, 102, 102, 0, 157, 102,
! 157, 157, 102, 102, 102, 51, 118, 120, 61, 63,
! 47, 0, 56, 0, 64, 59, 0, 58, 0, 0,
! 0, 74, 74, 74, 74, 0, 0, 0, 0, 0,
! 74, 57, 0, 0, 74, 74, 62, 74, 0, 0,
! 120, 0, 0, 74, 74, 0, 120, 74, 74, 74,
! 74, 74, 0, 74, 0, 0, 0, 0, 0, 0,
! 0, 39, 0, 60, 39, 39, 39, 0, 39, 0,
! 39, 39, 0, 39, 120, 0, 0, 0, 0, 0,
! 0, 210, 0, 152, 153, 154, 155, 39, 0, 0,
! 0, 0, 39, 0, 0, 23, 0, 0, 52, 160,
! 161, 0, 162, 163, 0, 0, 164, 0, 0, 165,
! 166, 167, 0, 0, 0, 0, 0, 51, 0, 39,
! 61, 63, 47, 0, 56, 0, 64, 59, 0, 58,
! 0, 0, 0, 0, 154, 155, 0, 0, 0, 0,
! 0, 0, 120, 0, 0, 0, 0, 0, 62, 0,
! 0, 39, 163, 0, 39, 164, 0, 0, 165, 166,
! 167, 0, 0, 0, 135, 0, 0, 135, 0, 0,
! 0, 0, 0, 0, 0, 60, 0, 89, 0, 0,
! 51, 135, 135, 61, 63, 47, 0, 56, 0, 64,
! 59, 0, 58, 108, 0, 0, 0, 0, 117, 0,
! 123, 0, 0, 0, 0, 0, 0, 23, 0, 0,
! 52, 62, 137, 138, 139, 140, 135, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 22, 24,
! 25, 26, 27, 28, 0, 29, 30, 31, 60, 0,
! 0, 32, 0, 0, 33, 34, 35, 36, 0, 0,
! 0, 37, 38, 0, 39, 40, 41, 0, 204, 0,
! 0, 42, 43, 44, 45, 46, 0, 0, 48, 49,
! 23, 0, 0, 52, 168, 50, 0, 0, 0, 53,
! 0, 54, 55, 0, 39, 39, 39, 39, 39, 39,
! 0, 39, 39, 39, 0, 0, 0, 39, 0, 0,
! 39, 39, 39, 39, 0, 0, 150, 39, 39, 0,
! 39, 39, 39, 0, 0, 0, 0, 39, 39, 39,
! 39, 39, 0, 0, 39, 39, 0, 0, 0, 0,
! 168, 39, 0, 0, 0, 39, 0, 39, 39, 0,
! 0, 119, 25, 26, 27, 28, 85, 29, 30, 31,
! 319, 0, 0, 32, 0, 0, 0, 0, 0, 0,
! 0, 0, 150, 0, 38, 0, 39, 40, 41, 0,
! 0, 0, 157, 42, 43, 44, 45, 46, 0, 0,
! 48, 49, 0, 0, 0, 0, 0, 50, 0, 0,
! 0, 53, 0, 54, 55, 135, 135, 135, 135, 0,
! 168, 0, 0, 0, 109, 25, 26, 27, 28, 0,
! 29, 30, 31, 0, 0, 0, 32, 135, 135, 0,
! 0, 0, 0, 0, 0, 0, 0, 38, 0, 39,
! 40, 41, 150, 0, 0, 0, 42, 43, 44, 45,
! 46, 0, 0, 48, 49, 0, 0, 0, 0, 0,
! 50, 0, 0, 0, 53, 51, 54, 55, 61, 63,
! 47, 0, 56, 0, 64, 59, 0, 58, 152, 153,
! 154, 155, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 114, 0, 159, 160, 161, 62, 162, 163, 0,
0, 164, 0, 0, 165, 166, 167, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 51, 0, 60, 61, 63, 47, 0, 56, 0,
! 64, 59, 0, 58, 152, 153, 154, 155, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 62, 162, 163, 0, 0, 164, 52, 0,
! 165, 166, 167, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 51, 0, 60,
! 61, 63, 47, 0, 56, 131, 64, 59, 0, 58,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 151, 0, 0, 0, 152, 153, 154, 155, 62, 0,
! 0, 23, 0, 0, 52, 0, 0, 156, 158, 159,
! 160, 161, 0, 162, 163, 0, 0, 164, 0, 0,
! 165, 166, 167, 0, 0, 60, 0, 0, 0, 0,
! 51, 0, 0, 61, 63, 47, 0, 56, 0, 64,
! 59, 0, 58, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 52, 62, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 24,
! 25, 26, 27, 28, 0, 29, 30, 31, 60, 0,
! 135, 32, 0, 0, 0, 168, 0, 0, 0, 0,
! 0, 0, 38, 0, 39, 40, 41, 0, 0, 0,
! 0, 42, 43, 44, 45, 46, 0, 157, 48, 49,
! 0, 0, 0, 52, 0, 50, 0, 150, 0, 53,
! 0, 54, 55, 0, 0, 24, 25, 26, 27, 28,
! 0, 29, 30, 31, 0, 168, 0, 32, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 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, 0, 0, 82, 0, 50, 0, 0,
! 0, 53, 0, 54, 55, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 24, 25, 26, 27, 28, 0,
! 29, 30, 31, 0, 51, 0, 32, 61, 63, 47,
! 0, 56, 0, 64, 59, 0, 58, 38, 0, 39,
! 40, 41, 0, 0, 0, 0, 42, 43, 44, 45,
! 46, 154, 155, 48, 49, 62, 0, 0, 0, 0,
! 50, 0, 0, 0, 53, 0, 54, 55, 162, 163,
! 0, 0, 164, 0, 0, 165, 166, 167, 0, 0,
! 51, 0, 60, 61, 63, 47, 0, 56, 200, 64,
! 59, 0, 58, 0, 0, 151, 0, 0, 0, 152,
! 153, 154, 155, 0, 0, 0, 0, 0, 0, 0,
! 0, 62, 156, 158, 159, 160, 161, 52, 162, 163,
! 0, 0, 164, 0, 0, 165, 166, 167, 0, 0,
! 152, 0, 154, 155, 0, 0, 51, 0, 60, 61,
! 63, 47, 0, 56, 248, 64, 59, 0, 58, 162,
! 163, 0, 0, 164, 0, 0, 165, 166, 167, 0,
! 0, 0, 0, 0, 0, 0, 0, 62, 0, 0,
! 0, 0, 0, 52, 82, 82, 82, 82, 0, 0,
! 0, 0, 0, 82, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 60, 0, 82, 82, 0, 51,
! 82, 82, 61, 63, 47, 0, 56, 276, 64, 59,
! 0, 58, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 52,
! 62, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 22, 24, 25,
! 26, 27, 28, 0, 29, 30, 31, 60, 0, 0,
! 32, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 38, 0, 39, 40, 41, 0, 0, 0, 0,
! 42, 43, 44, 45, 46, 0, 0, 48, 49, 0,
! 0, 0, 52, 0, 50, 0, 119, 0, 53, 119,
! 54, 55, 0, 0, 24, 25, 26, 27, 28, 0,
! 29, 30, 31, 119, 119, 0, 32, 0, 119, 0,
! 0, 0, 0, 0, 0, 0, 0, 38, 0, 39,
40, 41, 0, 0, 0, 0, 42, 43, 44, 45,
! 46, 0, 0, 48, 49, 0, 119, 0, 119, 0,
! 50, 0, 143, 0, 53, 143, 54, 55, 0, 0,
! 24, 25, 26, 27, 28, 0, 29, 30, 31, 143,
! 143, 0, 32, 0, 143, 0, 0, 0, 119, 0,
0, 0, 0, 38, 0, 39, 40, 41, 0, 0,
0, 0, 42, 43, 44, 45, 46, 0, 0, 48,
! 49, 0, 143, 0, 143, 0, 50, 0, 0, 0,
! 53, 0, 54, 55, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 24, 25, 26, 27, 28, 0, 29,
! 30, 31, 0, 51, 143, 32, 61, 63, 47, 0,
! 56, 278, 64, 59, 0, 58, 38, 0, 39, 40,
! 41, 0, 0, 0, 0, 42, 43, 44, 45, 46,
! 0, 0, 48, 49, 62, 0, 87, 87, 0, 50,
! 0, 0, 0, 53, 0, 54, 55, 0, 103, 0,
! 0, 0, 0, 87, 112, 0, 0, 0, 87, 51,
! 121, 60, 61, 63, 47, 0, 56, 0, 64, 59,
! 0, 58, 87, 87, 87, 87, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 62, 0, 0, 0, 0, 0, 52, 119, 119, 119,
! 119, 0, 0, 0, 0, 0, 119, 0, 0, 0,
! 119, 119, 119, 119, 0, 0, 0, 60, 121, 119,
! 119, 0, 0, 119, 119, 119, 119, 119, 0, 119,
! 119, 0, 130, 119, 0, 130, 119, 119, 119, 0,
! 0, 0, 0, 129, 0, 0, 129, 0, 0, 130,
! 130, 0, 52, 143, 143, 143, 143, 0, 0, 0,
! 129, 129, 143, 0, 0, 129, 143, 143, 143, 143,
! 0, 0, 0, 0, 0, 143, 143, 0, 240, 143,
! 143, 143, 143, 143, 130, 143, 143, 0, 104, 143,
! 0, 104, 143, 143, 143, 129, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 104, 104, 0, 0, 0,
! 104, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 129, 0, 24, 25, 26,
! 27, 28, 0, 29, 30, 31, 0, 0, 104, 32,
! 104, 0, 0, 0, 0, 0, 0, 0, 0, 0,
38, 0, 39, 40, 41, 0, 0, 0, 0, 42,
43, 44, 45, 46, 0, 0, 48, 49, 0, 0,
! 0, 0, 0, 50, 0, 145, 0, 53, 145, 54,
55, 0, 0, 24, 25, 26, 27, 28, 0, 29,
! 30, 31, 145, 145, 0, 32, 0, 145, 0, 0,
0, 0, 0, 0, 0, 0, 38, 0, 39, 40,
41, 0, 0, 0, 0, 42, 43, 44, 45, 46,
! 0, 0, 48, 49, 0, 0, 0, 145, 0, 50,
! 131, 0, 0, 53, 0, 54, 55, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 131, 131, 0,
! 0, 0, 131, 0, 0, 0, 0, 145, 0, 0,
! 0, 0, 0, 130, 130, 130, 130, 0, 0, 0,
! 0, 0, 0, 0, 129, 129, 129, 129, 0, 0,
! 131, 0, 131, 129, 0, 130, 130, 129, 129, 129,
! 129, 0, 0, 0, 0, 0, 129, 129, 0, 0,
! 129, 129, 129, 129, 129, 0, 129, 129, 0, 0,
! 129, 0, 131, 129, 129, 129, 0, 0, 0, 104,
! 104, 104, 104, 0, 0, 0, 0, 0, 104, 0,
! 0, 0, 104, 104, 104, 104, 0, 0, 0, 0,
! 0, 104, 104, 0, 146, 104, 104, 104, 104, 104,
! 0, 104, 104, 0, 0, 104, 0, 0, 104, 104,
! 104, 146, 146, 0, 0, 0, 146, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 146, 0, 146, 0, 0, 0,
0, 0, 0, 0, 0, 0, 145, 145, 145, 145,
! 0, 0, 0, 0, 0, 145, 0, 0, 0, 145,
! 145, 145, 145, 0, 0, 0, 146, 0, 145, 145,
0, 0, 145, 145, 145, 145, 145, 0, 145, 145,
! 59, 0, 145, 59, 0, 145, 145, 145, 0, 0,
! 0, 96, 0, 0, 96, 0, 0, 59, 59, 0,
! 0, 131, 131, 131, 131, 0, 0, 0, 96, 96,
! 131, 0, 0, 96, 131, 131, 131, 131, 0, 0,
! 0, 0, 0, 131, 131, 0, 0, 131, 131, 131,
! 131, 131, 59, 131, 131, 0, 0, 131, 0, 0,
! 131, 131, 131, 96, 58, 0, 0, 58, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 58, 58, 0, 0, 0, 58, 0, 0, 0,
- 0, 0, 0, 96, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 95, 0, 0,
! 95, 0, 0, 0, 0, 0, 58, 0, 0, 0,
! 0, 0, 0, 0, 95, 95, 0, 0, 0, 95,
! 0, 0, 0, 0, 0, 146, 146, 146, 146, 0,
! 0, 0, 0, 0, 146, 0, 58, 0, 146, 146,
! 146, 146, 0, 0, 0, 61, 0, 146, 146, 95,
! 0, 146, 146, 146, 146, 146, 0, 146, 146, 0,
! 0, 146, 61, 61, 146, 146, 146, 61, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 95,
! 0, 0, 0, 0, 0, 0, 0, 145, 0, 0,
! 145, 0, 0, 0, 0, 61, 0, 61, 0, 0,
! 0, 0, 0, 0, 145, 145, 0, 0, 0, 145,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 59, 59, 59, 59, 0, 0, 61, 0, 0,
! 0, 0, 96, 96, 96, 96, 0, 0, 0, 145,
! 0, 96, 0, 59, 59, 96, 96, 96, 96, 0,
! 0, 0, 0, 0, 96, 96, 0, 0, 96, 96,
! 96, 96, 96, 0, 96, 96, 0, 0, 96, 0,
! 0, 96, 96, 96, 0, 132, 0, 0, 132, 0,
! 0, 0, 0, 0, 0, 58, 58, 58, 58, 0,
! 0, 0, 132, 132, 58, 0, 0, 132, 58, 58,
! 58, 58, 0, 0, 0, 0, 0, 58, 58, 0,
! 0, 58, 58, 58, 58, 58, 0, 58, 58, 0,
! 0, 58, 0, 0, 58, 58, 58, 132, 95, 95,
! 95, 95, 0, 0, 0, 71, 0, 95, 71, 0,
! 0, 95, 95, 95, 95, 0, 0, 0, 0, 0,
! 95, 95, 71, 71, 95, 95, 95, 95, 95, 0,
! 95, 95, 0, 0, 95, 0, 0, 95, 95, 95,
! 0, 0, 0, 0, 0, 0, 61, 61, 61, 61,
! 0, 0, 0, 0, 0, 61, 0, 71, 0, 61,
! 61, 61, 61, 0, 0, 0, 0, 0, 61, 61,
! 0, 157, 61, 61, 61, 61, 61, 0, 61, 61,
! 0, 0, 61, 0, 0, 61, 61, 61, 145, 145,
! 145, 145, 0, 0, 0, 0, 0, 145, 0, 168,
! 0, 145, 145, 145, 145, 0, 0, 0, 0, 0,
! 145, 145, 0, 0, 145, 145, 145, 145, 145, 102,
! 145, 145, 102, 0, 145, 0, 0, 145, 145, 145,
! 0, 150, 0, 0, 0, 0, 102, 102, 0, 0,
! 0, 102, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 109, 0, 0, 109,
! 0, 102, 0, 0, 0, 0, 132, 132, 132, 132,
! 0, 0, 0, 109, 109, 132, 0, 0, 109, 132,
! 132, 132, 132, 0, 0, 0, 0, 0, 132, 132,
! 0, 0, 132, 132, 132, 132, 132, 0, 132, 132,
! 92, 0, 132, 92, 0, 132, 132, 132, 109, 0,
! 0, 0, 0, 0, 0, 0, 0, 92, 92, 0,
! 0, 0, 92, 0, 0, 0, 71, 71, 71, 71,
! 0, 0, 0, 0, 0, 0, 0, 93, 0, 0,
! 93, 0, 0, 0, 0, 0, 0, 0, 71, 71,
! 0, 0, 92, 0, 93, 93, 0, 0, 0, 93,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 87, 0, 0, 87, 0, 151,
! 0, 0, 0, 152, 153, 154, 155, 0, 0, 93,
! 0, 87, 87, 0, 0, 0, 87, 158, 159, 160,
! 161, 0, 162, 163, 0, 0, 164, 0, 0, 165,
! 166, 167, 88, 0, 0, 88, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 87, 0, 0, 88,
! 88, 0, 0, 0, 88, 0, 0, 0, 0, 0,
! 102, 102, 102, 102, 0, 0, 0, 0, 0, 102,
! 0, 0, 0, 102, 102, 102, 102, 0, 0, 0,
! 0, 0, 102, 102, 88, 0, 102, 102, 102, 102,
! 102, 0, 102, 102, 0, 0, 102, 0, 0, 102,
! 102, 102, 0, 0, 0, 0, 0, 109, 109, 109,
! 109, 0, 0, 0, 0, 0, 109, 0, 0, 0,
! 109, 109, 109, 109, 0, 0, 0, 0, 0, 109,
! 109, 0, 0, 109, 109, 109, 109, 109, 0, 109,
! 109, 89, 0, 109, 89, 0, 109, 109, 109, 0,
! 0, 92, 92, 92, 92, 0, 0, 0, 89, 89,
! 92, 0, 0, 89, 92, 92, 92, 92, 0, 0,
! 0, 0, 0, 92, 92, 0, 0, 92, 92, 92,
! 92, 92, 0, 92, 92, 0, 0, 92, 93, 93,
! 93, 93, 0, 89, 0, 0, 0, 93, 0, 0,
! 0, 93, 93, 93, 93, 0, 0, 0, 0, 0,
! 93, 93, 0, 0, 93, 93, 93, 93, 93, 0,
! 93, 93, 0, 0, 93, 87, 87, 87, 87, 0,
! 0, 0, 0, 0, 87, 0, 0, 0, 87, 87,
! 87, 87, 0, 0, 0, 0, 0, 87, 87, 0,
! 0, 87, 87, 87, 87, 87, 0, 87, 87, 0,
! 0, 0, 0, 88, 88, 88, 88, 0, 0, 0,
! 0, 0, 88, 0, 0, 0, 88, 88, 88, 88,
! 85, 0, 0, 85, 0, 88, 88, 0, 0, 88,
! 88, 88, 88, 88, 0, 88, 88, 85, 85, 0,
! 0, 0, 85, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 86, 0, 0, 86,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 85, 86, 86, 0, 0, 0, 86, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 84, 0, 0, 84, 0, 0, 0, 0, 86, 0,
! 0, 0, 89, 89, 89, 89, 0, 84, 84, 0,
! 0, 89, 84, 0, 0, 89, 89, 89, 89, 0,
! 0, 0, 0, 0, 89, 89, 0, 0, 89, 89,
! 89, 89, 89, 72, 89, 89, 72, 0, 0, 0,
0, 0, 84, 0, 0, 0, 0, 0, 0, 0,
! 72, 72, 0, 0, 0, 72, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 73,
! 0, 0, 73, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 72, 73, 73, 0, 0,
! 0, 73, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 75, 0, 0, 75,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 73, 0, 75, 75, 0, 0, 0, 75, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 85, 85, 85, 85, 0, 0, 0, 0, 0,
! 85, 0, 0, 0, 85, 85, 85, 85, 75, 0,
! 0, 0, 0, 85, 85, 0, 0, 85, 85, 85,
! 85, 85, 0, 85, 85, 0, 0, 86, 86, 86,
! 86, 0, 0, 0, 0, 0, 86, 0, 0, 0,
! 86, 86, 86, 86, 123, 0, 0, 123, 0, 86,
! 86, 0, 0, 86, 86, 86, 86, 86, 0, 86,
! 86, 123, 123, 0, 0, 0, 123, 0, 0, 0,
! 0, 84, 84, 84, 84, 0, 0, 0, 0, 0,
! 84, 0, 0, 0, 84, 84, 84, 84, 0, 0,
! 0, 0, 0, 84, 84, 0, 123, 84, 84, 84,
! 84, 84, 94, 84, 84, 94, 0, 0, 0, 0,
! 0, 0, 0, 0, 72, 72, 72, 72, 0, 94,
! 94, 0, 0, 72, 94, 0, 0, 72, 72, 72,
! 72, 0, 0, 0, 0, 0, 72, 72, 0, 0,
! 72, 72, 72, 72, 72, 0, 72, 72, 0, 0,
! 73, 73, 73, 73, 94, 0, 0, 0, 0, 73,
! 0, 0, 0, 73, 73, 73, 73, 0, 0, 0,
! 0, 0, 73, 73, 0, 0, 73, 73, 73, 73,
! 73, 134, 73, 0, 134, 0, 0, 75, 75, 75,
! 75, 0, 0, 0, 0, 0, 75, 0, 134, 134,
! 75, 75, 0, 134, 0, 0, 0, 0, 0, 75,
! 75, 0, 0, 75, 75, 75, 75, 75, 76, 75,
! 0, 76, 0, 0, 0, 0, 0, 0, 77, 0,
! 0, 77, 0, 134, 0, 76, 76, 0, 0, 0,
! 76, 0, 0, 0, 0, 77, 77, 0, 0, 0,
! 77, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 78, 0, 0, 78, 0, 0,
! 76, 0, 0, 0, 0, 123, 123, 123, 123, 0,
! 77, 78, 78, 0, 123, 0, 78, 0, 123, 123,
! 0, 0, 0, 0, 0, 0, 79, 123, 123, 79,
! 0, 123, 123, 123, 123, 123, 81, 0, 0, 81,
! 0, 0, 0, 79, 79, 0, 78, 0, 79, 0,
! 0, 0, 0, 81, 81, 0, 0, 0, 81, 0,
! 0, 0, 0, 94, 94, 94, 94, 0, 0, 284,
! 0, 0, 94, 0, 157, 0, 94, 94, 79, 0,
! 0, 0, 0, 0, 0, 94, 94, 0, 81, 94,
! 94, 94, 94, 94, 0, 0, 0, 0, 0, 0,
! 0, 0, 168, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 150, 0, 0, 0, 0, 0,
! 0, 0, 134, 134, 134, 134, 0, 0, 0, 0,
! 0, 134, 0, 0, 0, 134, 134, 0, 0, 0,
! 0, 0, 0, 0, 134, 134, 0, 0, 134, 134,
! 134, 134, 134, 0, 0, 0, 0, 0, 0, 76,
! 76, 76, 76, 0, 0, 0, 0, 0, 76, 77,
! 77, 77, 77, 76, 0, 0, 0, 0, 77, 0,
! 0, 76, 76, 0, 0, 76, 76, 76, 76, 76,
! 0, 77, 77, 0, 0, 77, 77, 77, 77, 77,
! 0, 0, 0, 0, 0, 78, 78, 78, 78, 0,
! 0, 0, 0, 0, 78, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 78, 78, 0,
! 0, 78, 78, 78, 78, 78, 0, 79, 79, 79,
! 79, 0, 0, 0, 0, 0, 79, 81, 81, 81,
! 81, 0, 0, 0, 0, 0, 81, 0, 0, 79,
! 79, 0, 0, 79, 79, 79, 79, 0, 0, 81,
! 81, 0, 151, 81, 81, 81, 152, 153, 154, 155,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 156,
! 158, 159, 160, 161, 0, 162, 163, 91, 0, 164,
! 0, 0, 165, 166, 167, 104, 0, 0, 0, 0,
! 111, 113, 0, 0, 0, 0, 0, 125, 126, 127,
! 128, 129, 130, 0, 0, 133, 134, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 0, 0, 0, 0, 0, 0, 0, 183, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
- 215, 0, 0, 0, 0, 0, 0, 0, 223, 224,
- 225, 226, 227, 228, 229, 230, 231, 232, 233, 234,
- 235, 236, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 296, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 312,
};
dEXT short yycheck[] = { 13,
! 257, 13, 91, 17, 44, 41, 59, 182, 36, 41,
! 59, 257, 44, 194, 41, 188, 59, 190, 41, 33,
! 34, 35, 36, 59, 82, 40, 58, 59, 41, 43,
! 88, 63, 125, 45, 123, 59, 50, 40, 59, 59,
! 40, 91, 123, 91, 56, 41, 257, 41, 60, 41,
! 41, 41, 278, 41, 36, 41, 44, 93, 116, 40,
! 91, 93, 41, 91, 78, 41, 40, 40, 59, 41,
! 58, 59, 40, 123, 123, 123, 91, 41, 92, 41,
! 40, 95, 94, 97, 96, 99, 98, 101, 100, 41,
! 102, 40, 123, 41, 106, 123, 44, 59, 41, 123,
! 59, 41, 294, 295, 41, 93, 0, 59, 123, 59,
! 58, 59, 287, 59, 44, 59, 59, 59, 299, 59,
! 123, 302, 59, 123, 297, 298, 184, 141, 276, 277,
! 123, 304, 144, 145, 146, 147, 148, 149, 150, 33,
! 40, 123, 36, 37, 38, 93, 40, 260, 42, 43,
! 123, 45, 123, 334, 327, 93, 168, 169, 170, 171,
! 172, 173, 174, 123, 178, 59, 40, 40, 36, 0,
! 64, 185, 40, 266, 267, 268, 257, 270, 271, 41,
! 40, 93, 91, 266, 267, 268, 198, 270, 271, 125,
! 93, 41, 204, 205, 206, 59, 59, 91, 287, 211,
! 41, 125, 33, 91, 257, 36, 37, 38, 295, 40,
! 93, 42, 43, 40, 45, 41, 305, 40, 125, 308,
! 125, 125, 311, 312, 313, 237, 125, 239, 59, 123,
! 258, 125, 126, 64, 59, 125, 272, 273, 274, 275,
! 272, 273, 274, 275, 93, 259, 41, 261, 41, 263,
! 264, 294, 295, 267, 294, 295, 270, 269, 294, 295,
! 91, 41, 294, 295, 44, 313, 298, 294, 295, 93,
! 282, 294, 295, 294, 295, 257, 272, 273, 274, 275,
! 262, 294, 295, 63, 272, 273, 274, 275, 59, 301,
! 123, 305, 123, 41, 125, 126, 0, 93, 294, 295,
! 294, 295, 294, 295, 294, 295, 294, 295, 294, 295,
! 298, 91, 59, 325, 41, 294, 295, 331, 294, 295,
! 59, 335, 294, 295, 272, 273, 274, 275, 41, 33,
! 294, 295, 36, 37, 38, 59, 40, 83, 42, 43,
! 41, 45, 325, 123, 294, 295, 294, 295, 294, 295,
! 294, 295, 294, 295, 13, 59, 294, 295, 269, 93,
! 64, -1, 256, 257, 258, 259, 260, 261, -1, 263,
264, 265, 266, 267, 268, 269, 270, 271, 272, 273,
! 274, 275, 294, 295, -1, 279, 280, 91, 282, 283,
! 284, 294, 295, -1, -1, 289, 290, 291, 292, 293,
! -1, -1, 296, 297, -1, 41, -1, -1, 44, 303,
! -1, 294, 295, 307, -1, 309, 310, -1, -1, 123,
! -1, -1, 126, 59, 91, 256, 257, 258, 259, 260,
! 261, -1, 263, 264, 265, 266, 267, 268, 269, 270,
! 271, 272, 273, 274, 275, 294, 295, -1, 279, 280,
! -1, 282, 283, 284, 91, -1, 123, 93, 289, 290,
! 291, 292, 293, -1, -1, 296, 297, -1, -1, -1,
! 294, 295, 303, -1, -1, -1, 307, -1, 309, 310,
! 272, 273, 274, 275, 33, 91, 123, 36, 37, 38,
! -1, 40, 41, 42, 43, 44, 45, -1, 294, 295,
! -1, 281, 294, 295, -1, 285, 286, 287, 288, 58,
! 59, 6, -1, 8, 63, 64, -1, 123, 298, 299,
! 300, 301, 302, -1, 304, 305, -1, -1, 308, -1,
! -1, 311, 312, 313, -1, -1, 31, 32, -1, -1,
! -1, -1, 91, -1, 93, 41, -1, -1, 44, -1,
! -1, 91, 256, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, 58, 59, -1, 269, -1, 63, 272, 273,
! 274, 275, -1, -1, 123, 279, 280, 126, 282, 283,
! 284, -1, -1, 123, -1, 289, 290, 291, 292, 293,
! -1, -1, 296, 297, -1, 91, -1, 93, -1, 303,
! -1, -1, -1, 307, 33, 309, 310, 36, 37, 38,
! -1, 40, 41, 42, 43, 44, 45, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 123, -1, 58,
! 59, -1, -1, -1, 63, 64, 272, 273, 274, 275,
! -1, 308, -1, -1, 311, 312, 313, -1, 285, 286,
! 287, 288, -1, -1, -1, -1, -1, -1, 294, -1,
! -1, -1, -1, -1, 93, 302, -1, 304, 305, -1,
! 41, 308, -1, 44, 311, 312, 313, -1, -1, 285,
! 286, 287, 288, -1, -1, -1, -1, 58, 59, -1,
! -1, -1, 63, 299, 300, 301, 302, 126, 304, 305,
! -1, -1, 308, -1, -1, 311, 312, 313, 257, 258,
! 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
! 269, -1, 93, 272, 273, 274, 275, -1, -1, -1,
! -1, 280, 281, 282, 283, 284, 285, 286, 287, 288,
! 289, 290, 291, 292, 293, 294, 295, 296, 297, 298,
! 299, 300, 301, 302, 303, 304, 305, -1, 307, 308,
! 309, 310, 311, 312, 313, 305, -1, -1, 308, 91,
! -1, 311, 312, 313, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, -1, -1, 281, -1, -1, -1, 285,
! 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
! -1, 123, 298, 299, 300, 301, 302, -1, 304, 305,
! -1, -1, 308, -1, -1, 311, 312, 313, 91, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 257, 258,
! 259, 260, 261, -1, 263, 264, 265, -1, -1, -1,
! 269, -1, -1, 272, 273, 274, 275, -1, -1, -1,
! 123, 280, 281, 282, 283, 284, 285, 286, 287, 288,
! 289, 290, 291, 292, 293, 294, 295, 296, 297, 298,
! 299, 300, 301, 302, 303, 304, 305, -1, 307, 308,
! 309, 310, 311, 312, 313, 33, 48, 49, 36, 37,
! 38, -1, 40, -1, 42, 43, -1, 45, -1, -1,
! -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
! 281, 59, -1, -1, 285, 286, 64, 288, -1, -1,
! 82, -1, -1, 294, 295, -1, 88, 298, 299, 300,
! 301, 302, -1, 304, -1, -1, -1, -1, -1, -1,
! -1, 33, -1, 91, 36, 37, 38, -1, 40, -1,
! 42, 43, -1, 45, 116, -1, -1, -1, -1, -1,
! -1, 123, -1, 285, 286, 287, 288, 59, -1, -1,
! -1, -1, 64, -1, -1, 123, -1, -1, 126, 301,
! 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
! 312, 313, -1, -1, -1, -1, -1, 33, -1, 91,
! 36, 37, 38, -1, 40, -1, 42, 43, -1, 45,
! -1, -1, -1, -1, 287, 288, -1, -1, -1, -1,
! -1, -1, 184, -1, -1, -1, -1, -1, 64, -1,
! -1, 123, 305, -1, 126, 308, -1, -1, 311, 312,
! 313, -1, -1, -1, 41, -1, -1, 44, -1, -1,
! -1, -1, -1, -1, -1, 91, -1, 26, -1, -1,
! 33, 58, 59, 36, 37, 38, -1, 40, -1, 42,
! 43, -1, 45, 42, -1, -1, -1, -1, 47, -1,
! 49, -1, -1, -1, -1, -1, -1, 123, -1, -1,
! 126, 64, 61, 62, 63, 64, 93, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 256, 257,
! 258, 259, 260, 261, -1, 263, 264, 265, 91, -1,
! -1, 269, -1, -1, 272, 273, 274, 275, -1, -1,
! -1, 279, 280, -1, 282, 283, 284, -1, 107, -1,
! -1, 289, 290, 291, 292, 293, -1, -1, 296, 297,
! 123, -1, -1, 126, 91, 303, -1, -1, -1, 307,
! -1, 309, 310, -1, 256, 257, 258, 259, 260, 261,
! -1, 263, 264, 265, -1, -1, -1, 269, -1, -1,
! 272, 273, 274, 275, -1, -1, 123, 279, 280, -1,
! 282, 283, 284, -1, -1, -1, -1, 289, 290, 291,
! 292, 293, -1, -1, 296, 297, -1, -1, -1, -1,
! 91, 303, -1, -1, -1, 307, -1, 309, 310, -1,
! -1, 257, 258, 259, 260, 261, 262, 263, 264, 265,
! 41, -1, -1, 269, -1, -1, -1, -1, -1, -1,
! -1, -1, 123, -1, 280, -1, 282, 283, 284, -1,
! -1, -1, 63, 289, 290, 291, 292, 293, -1, -1,
! 296, 297, -1, -1, -1, -1, -1, 303, -1, -1,
! -1, 307, -1, 309, 310, 272, 273, 274, 275, -1,
! 91, -1, -1, -1, 257, 258, 259, 260, 261, -1,
! 263, 264, 265, -1, -1, -1, 269, 294, 295, -1,
! -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
! 283, 284, 123, -1, -1, -1, 289, 290, 291, 292,
! 293, -1, -1, 296, 297, -1, -1, -1, -1, -1,
! 303, -1, -1, -1, 307, 33, 309, 310, 36, 37,
! 38, -1, 40, -1, 42, 43, -1, 45, 285, 286,
! 287, 288, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 59, -1, 300, 301, 302, 64, 304, 305, -1,
-1, 308, -1, -1, 311, 312, 313, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 33, -1, 91, 36, 37, 38, -1, 40, -1,
! 42, 43, -1, 45, 285, 286, 287, 288, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, 64, 304, 305, -1, -1, 308, 126, -1,
! 311, 312, 313, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 33, -1, 91,
! 36, 37, 38, -1, 40, 41, 42, 43, -1, 45,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 281, -1, -1, -1, 285, 286, 287, 288, 64, -1,
! -1, 123, -1, -1, 126, -1, -1, 298, 299, 300,
! 301, 302, -1, 304, 305, -1, -1, 308, -1, -1,
! 311, 312, 313, -1, -1, 91, -1, -1, -1, -1,
! 33, -1, -1, 36, 37, 38, -1, 40, -1, 42,
! 43, -1, 45, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 126, 64, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 257,
! 258, 259, 260, 261, -1, 263, 264, 265, 91, -1,
! 93, 269, -1, -1, -1, 91, -1, -1, -1, -1,
! -1, -1, 280, -1, 282, 283, 284, -1, -1, -1,
! -1, 289, 290, 291, 292, 293, -1, 63, 296, 297,
! -1, -1, -1, 126, -1, 303, -1, 123, -1, 307,
! -1, 309, 310, -1, -1, 257, 258, 259, 260, 261,
! -1, 263, 264, 265, -1, 91, -1, 269, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 280, -1,
! 282, 283, 284, -1, -1, -1, -1, 289, 290, 291,
! 292, 293, -1, -1, 296, 297, 91, 123, -1, -1,
! -1, 303, -1, 41, -1, 307, 44, 309, 310, -1,
! -1, 257, 258, 259, 260, 261, -1, 263, 264, 265,
! 58, 59, -1, 269, -1, 63, -1, -1, 123, -1,
! -1, -1, -1, -1, 280, -1, 282, 283, 284, -1,
! -1, -1, -1, 289, 290, 291, 292, 293, -1, -1,
! 296, 297, -1, -1, -1, 93, -1, 303, -1, -1,
! -1, 307, -1, 309, 310, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 257, 258, 259, 260, 261, -1,
! 263, 264, 265, -1, 33, -1, 269, 36, 37, 38,
! -1, 40, -1, 42, 43, -1, 45, 280, -1, 282,
! 283, 284, -1, -1, -1, -1, 289, 290, 291, 292,
! 293, 287, 288, 296, 297, 64, -1, -1, -1, -1,
! 303, -1, -1, -1, 307, -1, 309, 310, 304, 305,
! -1, -1, 308, -1, -1, 311, 312, 313, -1, -1,
! 33, -1, 91, 36, 37, 38, -1, 40, 41, 42,
! 43, -1, 45, -1, -1, 281, -1, -1, -1, 285,
! 286, 287, 288, -1, -1, -1, -1, -1, -1, -1,
! -1, 64, 298, 299, 300, 301, 302, 126, 304, 305,
! -1, -1, 308, -1, -1, 311, 312, 313, -1, -1,
! 285, -1, 287, 288, -1, -1, 33, -1, 91, 36,
! 37, 38, -1, 40, 41, 42, 43, -1, 45, 304,
! 305, -1, -1, 308, -1, -1, 311, 312, 313, -1,
! -1, -1, -1, -1, -1, -1, -1, 64, -1, -1,
! -1, -1, -1, 126, 272, 273, 274, 275, -1, -1,
! -1, -1, -1, 281, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 91, -1, 294, 295, -1, 33,
! 298, 299, 36, 37, 38, -1, 40, 41, 42, 43,
! -1, 45, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 126,
! 64, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, 256, 257, 258,
259, 260, 261, -1, 263, 264, 265, 91, -1, -1,
! 269, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 280, -1, 282, 283, 284, -1, -1, -1, -1,
289, 290, 291, 292, 293, -1, -1, 296, 297, -1,
! -1, -1, 126, -1, 303, -1, 41, -1, 307, 44,
! 309, 310, -1, -1, 257, 258, 259, 260, 261, -1,
! 263, 264, 265, 58, 59, -1, 269, -1, 63, -1,
! -1, -1, -1, -1, -1, -1, -1, 280, -1, 282,
283, 284, -1, -1, -1, -1, 289, 290, 291, 292,
! 293, -1, -1, 296, 297, -1, 91, -1, 93, -1,
! 303, -1, 41, -1, 307, 44, 309, 310, -1, -1,
! 257, 258, 259, 260, 261, -1, 263, 264, 265, 58,
! 59, -1, 269, -1, 63, -1, -1, -1, 123, -1,
-1, -1, -1, 280, -1, 282, 283, 284, -1, -1,
-1, -1, 289, 290, 291, 292, 293, -1, -1, 296,
! 297, -1, 91, -1, 93, -1, 303, -1, -1, -1,
! 307, -1, 309, 310, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, -1, 33, 123, 269, 36, 37, 38, -1,
! 40, 41, 42, 43, -1, 45, 280, -1, 282, 283,
! 284, -1, -1, -1, -1, 289, 290, 291, 292, 293,
! -1, -1, 296, 297, 64, -1, 25, 26, -1, 303,
! -1, -1, -1, 307, -1, 309, 310, -1, 37, -1,
! -1, -1, -1, 42, 43, -1, -1, -1, 47, 33,
! 49, 91, 36, 37, 38, -1, 40, -1, 42, 43,
! -1, 45, 61, 62, 63, 64, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- 64, -1, -1, -1, -1, -1, 126, 272, 273, 274,
- 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
- 285, 286, 287, 288, -1, -1, -1, 91, 107, 294,
- 295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
- 305, -1, 41, 308, -1, 44, 311, 312, 313, -1,
- -1, -1, -1, 41, -1, -1, 44, -1, -1, 58,
- 59, -1, 126, 272, 273, 274, 275, -1, -1, -1,
- 58, 59, 281, -1, -1, 63, 285, 286, 287, 288,
- -1, -1, -1, -1, -1, 294, 295, -1, 167, 298,
- 299, 300, 301, 302, 93, 304, 305, -1, 41, 308,
- -1, 44, 311, 312, 313, 93, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 58, 59, -1, -1, -1,
- 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, 123, -1, 257, 258, 259,
- 260, 261, -1, 263, 264, 265, -1, -1, 91, 269,
- 93, -1, -1, -1, -1, -1, -1, -1, -1, -1,
280, -1, 282, 283, 284, -1, -1, -1, -1, 289,
290, 291, 292, 293, -1, -1, 296, 297, -1, -1,
! -1, -1, -1, 303, -1, 41, -1, 307, 44, 309,
310, -1, -1, 257, 258, 259, 260, 261, -1, 263,
! 264, 265, 58, 59, -1, 269, -1, 63, -1, -1,
-1, -1, -1, -1, -1, -1, 280, -1, 282, 283,
284, -1, -1, -1, -1, 289, 290, 291, 292, 293,
! -1, -1, 296, 297, -1, -1, -1, 93, -1, 303,
! 41, -1, -1, 307, -1, 309, 310, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 58, 59, -1,
! -1, -1, 63, -1, -1, -1, -1, 123, -1, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
! -1, -1, -1, -1, 272, 273, 274, 275, -1, -1,
! 91, -1, 93, 281, -1, 294, 295, 285, 286, 287,
! 288, -1, -1, -1, -1, -1, 294, 295, -1, -1,
! 298, 299, 300, 301, 302, -1, 304, 305, -1, -1,
! 308, -1, 123, 311, 312, 313, -1, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, -1, -1, 281, -1,
! -1, -1, 285, 286, 287, 288, -1, -1, -1, -1,
! -1, 294, 295, -1, 41, 298, 299, 300, 301, 302,
! -1, 304, 305, -1, -1, 308, -1, -1, 311, 312,
! 313, 58, 59, -1, -1, -1, 63, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 91, -1, 93, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, -1, -1, 281, -1, -1, -1, 285,
! 286, 287, 288, -1, -1, -1, 123, -1, 294, 295,
! -1, -1, 298, 299, 300, 301, 302, -1, 304, 305,
! 41, -1, 308, 44, -1, 311, 312, 313, -1, -1,
! -1, 41, -1, -1, 44, -1, -1, 58, 59, -1,
-1, 272, 273, 274, 275, -1, -1, -1, 58, 59,
281, -1, -1, 63, 285, 286, 287, 288, -1, -1,
-1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
! 301, 302, 93, 304, 305, -1, -1, 308, -1, -1,
! 311, 312, 313, 93, 41, -1, -1, 44, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 58, 59, -1, -1, -1, 63, -1, -1, -1,
! -1, -1, -1, 123, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
! 44, -1, -1, -1, -1, -1, 93, -1, -1, -1,
! -1, -1, -1, -1, 58, 59, -1, -1, -1, 63,
! -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
! -1, -1, -1, -1, 281, -1, 123, -1, 285, 286,
! 287, 288, -1, -1, -1, 41, -1, 294, 295, 93,
! -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
! -1, 308, 58, 59, 311, 312, 313, 63, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 123,
! -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
! 44, -1, -1, -1, -1, 91, -1, 93, -1, -1,
! -1, -1, -1, -1, 58, 59, -1, -1, -1, 63,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 272, 273, 274, 275, -1, -1, 123, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, -1, -1, 93,
! -1, 281, -1, 294, 295, 285, 286, 287, 288, -1,
! -1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
300, 301, 302, -1, 304, 305, -1, -1, 308, -1,
! -1, 311, 312, 313, -1, 41, -1, -1, 44, -1,
! -1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
! -1, -1, 58, 59, 281, -1, -1, 63, 285, 286,
! 287, 288, -1, -1, -1, -1, -1, 294, 295, -1,
! -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
! -1, 308, -1, -1, 311, 312, 313, 93, 272, 273,
! 274, 275, -1, -1, -1, 41, -1, 281, 44, -1,
! -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
! 294, 295, 58, 59, 298, 299, 300, 301, 302, -1,
! 304, 305, -1, -1, 308, -1, -1, 311, 312, 313,
! -1, -1, -1, -1, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, -1, -1, 281, -1, 93, -1, 285,
! 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
! -1, 63, 298, 299, 300, 301, 302, -1, 304, 305,
! -1, -1, 308, -1, -1, 311, 312, 313, 272, 273,
! 274, 275, -1, -1, -1, -1, -1, 281, -1, 91,
! -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
! 294, 295, -1, -1, 298, 299, 300, 301, 302, 41,
! 304, 305, 44, -1, 308, -1, -1, 311, 312, 313,
! -1, 123, -1, -1, -1, -1, 58, 59, -1, -1,
! -1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 41, -1, -1, 44,
! -1, 93, -1, -1, -1, -1, 272, 273, 274, 275,
-1, -1, -1, 58, 59, 281, -1, -1, 63, 285,
! 286, 287, 288, -1, -1, -1, -1, -1, 294, 295,
-1, -1, 298, 299, 300, 301, 302, -1, 304, 305,
41, -1, 308, 44, -1, 311, 312, 313, 93, -1,
! -1, -1, -1, -1, -1, -1, -1, 58, 59, -1,
! -1, -1, 63, -1, -1, -1, 272, 273, 274, 275,
! -1, -1, -1, -1, -1, -1, -1, 41, -1, -1,
! 44, -1, -1, -1, -1, -1, -1, -1, 294, 295,
! -1, -1, 93, -1, 58, 59, -1, -1, -1, 63,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 41, -1, -1, 44, -1, 281,
! -1, -1, -1, 285, 286, 287, 288, -1, -1, 93,
! -1, 58, 59, -1, -1, -1, 63, 299, 300, 301,
! 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
! 312, 313, 41, -1, -1, 44, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 93, -1, -1, 58,
! 59, -1, -1, -1, 63, -1, -1, -1, -1, -1,
! 272, 273, 274, 275, -1, -1, -1, -1, -1, 281,
! -1, -1, -1, 285, 286, 287, 288, -1, -1, -1,
! -1, -1, 294, 295, 93, -1, 298, 299, 300, 301,
! 302, -1, 304, 305, -1, -1, 308, -1, -1, 311,
! 312, 313, -1, -1, -1, -1, -1, 272, 273, 274,
! 275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
285, 286, 287, 288, -1, -1, -1, -1, -1, 294,
295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
! 305, 41, -1, 308, 44, -1, 311, 312, 313, -1,
-1, 272, 273, 274, 275, -1, -1, -1, 58, 59,
281, -1, -1, 63, 285, 286, 287, 288, -1, -1,
-1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
! 301, 302, -1, 304, 305, -1, -1, 308, 272, 273,
! 274, 275, -1, 93, -1, -1, -1, 281, -1, -1,
! -1, 285, 286, 287, 288, -1, -1, -1, -1, -1,
! 294, 295, -1, -1, 298, 299, 300, 301, 302, -1,
! 304, 305, -1, -1, 308, 272, 273, 274, 275, -1,
! -1, -1, -1, -1, 281, -1, -1, -1, 285, 286,
! 287, 288, -1, -1, -1, -1, -1, 294, 295, -1,
! -1, 298, 299, 300, 301, 302, -1, 304, 305, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, -1, -1,
! -1, -1, 281, -1, -1, -1, 285, 286, 287, 288,
! 41, -1, -1, 44, -1, 294, 295, -1, -1, 298,
! 299, 300, 301, 302, -1, 304, 305, 58, 59, -1,
! -1, -1, 63, -1, -1, -1, -1, -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,
! 41, -1, -1, 44, -1, -1, -1, -1, 93, -1,
! -1, -1, 272, 273, 274, 275, -1, 58, 59, -1,
! -1, 281, 63, -1, -1, 285, 286, 287, 288, -1,
-1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
! 300, 301, 302, 41, 304, 305, 44, -1, -1, -1,
! -1, -1, 93, -1, -1, -1, -1, -1, -1, -1,
58, 59, -1, -1, -1, 63, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, 41,
-1, -1, 44, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, 93, 58, 59, -1, -1,
-1, 63, -1, -1, -1, -1, -1, -1, -1, -1,
- -1, -1, -1, -1, -1, -1, 41, -1, -1, 44,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 93, -1, 58, 59, -1, -1, -1, 63, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
! 281, -1, -1, -1, 285, 286, 287, 288, 93, -1,
! -1, -1, -1, 294, 295, -1, -1, 298, 299, 300,
! 301, 302, -1, 304, 305, -1, -1, 272, 273, 274,
275, -1, -1, -1, -1, -1, 281, -1, -1, -1,
285, 286, 287, 288, 41, -1, -1, 44, -1, 294,
! 295, -1, -1, 298, 299, 300, 301, 302, -1, 304,
305, 58, 59, -1, -1, -1, 63, -1, -1, -1,
! -1, 272, 273, 274, 275, -1, -1, -1, -1, -1,
! 281, -1, -1, -1, 285, 286, 287, 288, -1, -1,
! -1, -1, -1, 294, 295, -1, 93, 298, 299, 300,
! 301, 302, 41, 304, 305, 44, -1, -1, -1, -1,
! -1, -1, -1, -1, 272, 273, 274, 275, -1, 58,
! 59, -1, -1, 281, 63, -1, -1, 285, 286, 287,
! 288, -1, -1, -1, -1, -1, 294, 295, -1, -1,
! 298, 299, 300, 301, 302, -1, 304, 305, -1, -1,
! 272, 273, 274, 275, 93, -1, -1, -1, -1, 281,
! -1, -1, -1, 285, 286, 287, 288, -1, -1, -1,
-1, -1, 294, 295, -1, -1, 298, 299, 300, 301,
! 302, 41, 304, -1, 44, -1, -1, 272, 273, 274,
! 275, -1, -1, -1, -1, -1, 281, -1, 58, 59,
! 285, 286, -1, 63, -1, -1, -1, -1, -1, 294,
! 295, -1, -1, 298, 299, 300, 301, 302, 41, 304,
! -1, 44, -1, -1, -1, -1, -1, -1, 41, -1,
! -1, 44, -1, 93, -1, 58, 59, -1, -1, -1,
! 63, -1, -1, -1, -1, 58, 59, -1, -1, -1,
! 63, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 41, -1, -1, 44, -1, -1,
! 93, -1, -1, -1, -1, 272, 273, 274, 275, -1,
! 93, 58, 59, -1, 281, -1, 63, -1, 285, 286,
! -1, -1, -1, -1, -1, -1, 41, 294, 295, 44,
! -1, 298, 299, 300, 301, 302, 41, -1, -1, 44,
! -1, -1, -1, 58, 59, -1, 93, -1, 63, -1,
! -1, -1, -1, 58, 59, -1, -1, -1, 63, -1,
! -1, -1, -1, 272, 273, 274, 275, -1, -1, 58,
! -1, -1, 281, -1, 63, -1, 285, 286, 93, -1,
! -1, -1, -1, -1, -1, 294, 295, -1, 93, 298,
! 299, 300, 301, 302, -1, -1, -1, -1, -1, -1,
! -1, -1, 91, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 123, -1, -1, -1, -1, -1,
! -1, -1, 272, 273, 274, 275, -1, -1, -1, -1,
! -1, 281, -1, -1, -1, 285, 286, -1, -1, -1,
! -1, -1, -1, -1, 294, 295, -1, -1, 298, 299,
! 300, 301, 302, -1, -1, -1, -1, -1, -1, 272,
! 273, 274, 275, -1, -1, -1, -1, -1, 281, 272,
! 273, 274, 275, 286, -1, -1, -1, -1, 281, -1,
! -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
! -1, 294, 295, -1, -1, 298, 299, 300, 301, 302,
-1, -1, -1, -1, -1, 272, 273, 274, 275, -1,
! -1, -1, -1, -1, 281, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 294, 295, -1,
! -1, 298, 299, 300, 301, 302, -1, 272, 273, 274,
! 275, -1, -1, -1, -1, -1, 281, 272, 273, 274,
! 275, -1, -1, -1, -1, -1, 281, -1, -1, 294,
! 295, -1, -1, 298, 299, 300, 301, -1, -1, 294,
! 295, -1, 281, 298, 299, 300, 285, 286, 287, 288,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, 298,
! 299, 300, 301, 302, -1, 304, 305, 30, -1, 308,
! -1, -1, 311, 312, 313, 38, -1, -1, -1, -1,
! 43, 44, -1, -1, -1, -1, -1, 50, 51, 52,
! 53, 54, 55, -1, -1, 58, 59, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, 90, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! 143, -1, -1, -1, -1, -1, -1, -1, 151, 152,
! 153, 154, 155, 156, 157, 158, 159, 160, 161, 162,
! 163, 164, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
--- 93,1099 ----
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,
};
dEXT short yyrindex[] = { 0,
! 0, 0, 269, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 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, 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, 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, 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, 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,
};
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,
};
! #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,
! 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, 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, 0, 0, 0, 0, 0, 0, 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, 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, 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, 0, 0, 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, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
! 0, 0, 0, 0, 0, 215, 0, 0, 0, 0,
! 0, 0, 0, 223, 224, 225, 226, 227, 228, 229,
! 230, 231, 232, 233, 234, 235, 236, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 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,
};
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,
! 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,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, 294, 295, 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, -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, -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, -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, -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, -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, -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,
! -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,
! 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,
-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, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
***************
*** 1108,1117 ****
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, 256, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, 284,
};
#define YYFINAL 1
#ifndef YYDEBUG
--- 1102,1111 ----
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, -1, -1, 256, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
-1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
! -1, -1, -1, -1, -1, -1, 284,
};
#define YYFINAL 1
#ifndef YYDEBUG
***************
*** 1191,1197 ****
"startsub :",
"package : PACKAGE WORD ';'",
"package : PACKAGE ';'",
! "use : USE startsub WORD listexpr ';'",
"expr : expr ANDOP expr",
"expr : expr OROP expr",
"expr : argexpr",
--- 1185,1191 ----
"startsub :",
"package : PACKAGE WORD ';'",
"package : PACKAGE ';'",
! "use : USE startsub WORD WORD listexpr ';'",
"expr : expr ANDOP expr",
"expr : expr OROP expr",
"expr : argexpr",
***************
*** 1321,1327 ****
dEXT YYSTYPE yylval;
#line 571 "perly.y"
/* PROGRAM */
! #line 1394 "y_tab.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
--- 1315,1321 ----
dEXT YYSTYPE yylval;
#line 571 "perly.y"
/* PROGRAM */
! #line 1388 "y_tab.c"
#define YYABORT goto yyabort
#define YYACCEPT goto yyaccept
#define YYERROR goto yyerrlab
***************
*** 1342,1356 ****
void* ptr;
{
struct ysv* ysave = (struct ysv*)ptr;
! if (ysave->yyss) Safefree(ysave->yyss);
! if (ysave->yyvs) Safefree(ysave->yyvs);
yydebug = ysave->oldyydebug;
yynerrs = ysave->oldyynerrs;
yyerrflag = ysave->oldyyerrflag;
yychar = ysave->oldyychar;
yyval = ysave->oldyyval;
yylval = ysave->oldyylval;
! Safefree(ysave);
}
int
--- 1336,1350 ----
void* ptr;
{
struct ysv* ysave = (struct ysv*)ptr;
! if (ysave->yyss) safefree((char *)ysave->yyss);
! if (ysave->yyvs) safefree((char *)ysave->yyvs);
yydebug = ysave->oldyydebug;
yynerrs = ysave->oldyynerrs;
yyerrflag = ysave->oldyyerrflag;
yychar = ysave->oldyychar;
yyval = ysave->oldyyval;
yylval = ysave->oldyylval;
! safefree((char *)ysave);
}
int
***************
*** 1413,1419 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n", yystate,
yychar, yys);
}
#endif
--- 1407,1413 ----
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,
yychar, yys);
}
#endif
***************
*** 1423,1429 ****
{
#if YYDEBUG
if (yydebug)
! fprintf(stderr, "yydebug: state %d, shifting to state %d\n",
yystate, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
--- 1417,1423 ----
{
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log, "yydebug: state %d, shifting to state %d\n",
yystate, yytable[yyn]);
#endif
if (yyssp >= yyss + yystacksize - 1)
***************
*** 1478,1484 ****
{
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
"yydebug: state %d, error recovery shifting to state %d\n",
*yyssp, yytable[yyn]);
#endif
--- 1472,1478 ----
{
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log,
"yydebug: state %d, error recovery shifting to state %d\n",
*yyssp, yytable[yyn]);
#endif
***************
*** 1508,1514 ****
{
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
"yydebug: error recovery discarding state %d\n",
*yyssp);
#endif
--- 1502,1508 ----
{
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log,
"yydebug: error recovery discarding state %d\n",
*yyssp);
#endif
***************
*** 1527,1533 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(stderr,
"yydebug: state %d, error recovery discards token %d (%s)\n",
yystate, yychar, yys);
}
--- 1521,1527 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(Perl_debug_log,
"yydebug: state %d, error recovery discards token %d (%s)\n",
yystate, yychar, yys);
}
***************
*** 1538,1544 ****
yyreduce:
#if YYDEBUG
if (yydebug)
! fprintf(stderr, "yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
yym = yylen[yyn];
--- 1532,1538 ----
yyreduce:
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log, "yydebug: state %d, reducing by rule %d (%s)\n",
yystate, yyn, yyrule[yyn]);
#endif
yym = yylen[yyn];
***************
*** 1786,1792 ****
break;
case 54:
#line 271 "perly.y"
! { utilize(yyvsp[-4].ival, yyvsp[-3].ival, yyvsp[-2].opval, yyvsp[-1].opval); }
break;
case 55:
#line 275 "perly.y"
--- 1780,1786 ----
break;
case 54:
#line 271 "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"
***************
*** 2247,2253 ****
#line 568 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! #line 2236 "y_tab.c"
}
yyssp -= yym;
yystate = *yyssp;
--- 2241,2247 ----
#line 568 "perly.y"
{ yyval.opval = yyvsp[0].opval; }
break;
! #line 2230 "y_tab.c"
}
yyssp -= yym;
yystate = *yyssp;
***************
*** 2257,2263 ****
{
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
"yydebug: after reduction, shifting from state 0 to state %d\n",
YYFINAL);
#endif
--- 2251,2257 ----
{
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log,
"yydebug: after reduction, shifting from state 0 to state %d\n",
YYFINAL);
#endif
***************
*** 2273,2279 ****
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(stderr, "yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
#endif
--- 2267,2273 ----
yys = 0;
if (yychar <= YYMAXTOKEN) yys = yyname[yychar];
if (!yys) yys = "illegal-symbol";
! fprintf(Perl_debug_log, "yydebug: state %d, reading %d (%s)\n",
YYFINAL, yychar, yys);
}
#endif
***************
*** 2288,2294 ****
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
! fprintf(stderr,
"yydebug: after reduction, shifting from state %d to state %d\n",
*yyssp, yystate);
#endif
--- 2282,2288 ----
yystate = yydgoto[yym];
#if YYDEBUG
if (yydebug)
! fprintf(Perl_debug_log,
"yydebug: after reduction, shifting from state %d to state %d\n",
*yyssp, yystate);
#endif
#~ Add getpeername() shim to convert successful-but-no-address result
#~ to the error expected by the Perl core.
diff -Pcr perl5_003/vms/sockadapt.c perl5_003_01/vms/sockadapt.c
*** perl5_003/vms/sockadapt.c Tue Jan 30 02:05:11 1996
--- perl5_003_01/vms/sockadapt.c Mon Jul 22 18:46:13 1996
***************
*** 41,43 ****
--- 41,66 ----
void endnetent() {
croak("Function \"endnetent\" not implemented in this version of perl");
}
+
+ /* Some TCP/IP implementations seem to return success, when getpeername()
+ * is called on a UDP socket, but the port and in_addr are all zeroes.
+ */
+
+ int my_getpeername(int sock, struct sockaddr *addr, int *addrlen) {
+ static char nowhere[] = "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
+ int rslt;
+
+ rslt = si_getpeername(sock, addr, addrlen);
+
+ /* Just pass an error back up the line */
+ if (rslt) return rslt;
+
+ /* If the call succeeded, make sure we don't have a zeroed port/addr */
+ if (addr->sa_family == AF_INET &&
+ !memcmp((char *)addr + sizeof(u_short), nowhere,
+ sizeof(u_short) + sizeof(struct in_addr))) {
+ rslt = -1;
+ SETERRNO(ENOTCONN,SS$_CLEARED);
+ }
+ return rslt;
+ }
#~ Add getpeername() shim
diff -Pcr perl5_003/vms/sockadapt.h perl5_003_01/vms/sockadapt.h
*** perl5_003/vms/sockadapt.h Sat Jul 1 15:52:56 1995
--- perl5_003_01/vms/sockadapt.h Sun Mar 24 20:29:48 1996
***************
*** 140,142 ****
--- 140,150 ----
#endif
#define fileno si_fileno
int si_fileno(FILE *);
+
+
+ /* Catch erroneous results for UDP sockets -- see sockadapt.c */
+ #ifdef getpeername
+ # undef getpeername
+ #endif
+ #define getpeername my_getpeername
+ int my_getpeername _((int, struct sockaddr *, int *));
#~ Allow alternate file type for executable images
#~ Update list of Unix-dependent types
#~ Distinguish between skipping tests and passing them
diff -Pcr perl5_003/vms/test.com perl5_003_01/vms/test.com
*** perl5_003/vms/test.com Mon Mar 25 01:06:06 1996
--- perl5_003_01/vms/test.com Wed Jul 10 20:16:05 1996
***************
*** 19,27 ****
$ EndIf
$ EndIf
$
$! Pick up a copy of perl to use for the tests
$ Delete/Log/NoConfirm Perl.;*
! $ Copy/Log/NoConfirm [-]Perl.Exe []Perl.
$
$! Make the environment look a little friendlier to tests which assume Unix
$ cat = "Type"
--- 19,29 ----
$ EndIf
$ EndIf
$
+ $ exe = ".Exe"
+ $ If p1.nes."" Then exe = p1
$! Pick up a copy of perl to use for the tests
$ Delete/Log/NoConfirm Perl.;*
! $ Copy/Log/NoConfirm [-]Perl'exe' []Perl.
$
$! Make the environment look a little friendlier to tests which assume Unix
$ cat = "Type"
***************
*** 65,78 ****
movl #1,r0
ret
.end echo
! $ Link/NoTrace Echo.Obj;
$ Delete/Log/NoConfirm Echo.Obj;*
$ echo = "$" + F$Parse("Echo.Exe")
$
$! And do it
$ testdir = "Directory/NoHead/NoTrail/Column=1"
! $ Define/User Perlshr Sys$Disk:[-]PerlShr.Exe
! $ MCR Sys$Disk:[]Perl. "''p1'" "''p2'" "''p3'" "''p4'" "''p5'" "''p6'"
$ Deck/Dollar=$$END-OF-TEST$$
# $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $
# Modified for VMS 30-Sep-1994 Charles Bailey bailey@genetics.upenn.edu
--- 67,80 ----
movl #1,r0
ret
.end echo
! $ Link/NoTrace/Exe=Echo.Exe Echo.Obj;
$ Delete/Log/NoConfirm Echo.Obj;*
$ echo = "$" + F$Parse("Echo.Exe")
$
$! And do it
$ testdir = "Directory/NoHead/NoTrail/Column=1"
! $ Define/User Perlshr Sys$Disk:[-]PerlShr'exe'
! $ MCR Sys$Disk:[]Perl. "''p2'" "''p3'" "''p4'" "''p5'" "''p6'"
$ Deck/Dollar=$$END-OF-TEST$$
# $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $
# Modified for VMS 30-Sep-1994 Charles Bailey bailey@genetics.upenn.edu
***************
*** 81,92 ****
# most of the constructs we'll be testing for.
# skip those tests we know will fail entirely or cause perl to hang bacause
! # of Unixisms
@compexcl=('cpp.t','script.t');
@ioexcl=('argv.t','dup.t','fs.t','inplace.t','pipe.t');
@libexcl=('anydbm.t','db-btree.t','db-hash.t','db-recno.t',
! 'gdbm.t','ndbm.t','odbm.t','sdbm.t','posix.t','soundex.t');
! @opexcl=('exec.t','fork.t','glob.t','magic.t','misc.t','stat.t');
@exclist=(@compexcl,@ioexcl,@libexcl,@opexcl);
foreach $file (@exclist) { $skip{$file}++; }
--- 83,98 ----
# most of the constructs we'll be testing for.
# skip those tests we know will fail entirely or cause perl to hang bacause
! # of Unixisms in the tests. (The Perl operators being tested may work fine,
! # but the tests may use other operators which don't.)
@compexcl=('cpp.t','script.t');
@ioexcl=('argv.t','dup.t','fs.t','inplace.t','pipe.t');
@libexcl=('anydbm.t','db-btree.t','db-hash.t','db-recno.t',
! 'gdbm.t','io_dup.t', 'io_pipe.t', 'io_sock.t',
! 'ndbm.t','odbm.t','posix.t','sdbm.t','soundex.t');
! # Note: POSIX is not part of basic build, but can be built
! # separately if you're using DECC
! @opexcl=('exec.t','fork.t','glob.t','groups.t','magic.t','misc.t','stat.t');
@exclist=(@compexcl,@ioexcl,@libexcl,@opexcl);
foreach $file (@exclist) { $skip{$file}++; }
***************
*** 162,169 ****
}
$next = $next - 1;
if ($ok && $next == $max) {
! print "${te}ok\n";
! $good = $good + 1;
} else {
$next += 1;
print "${te}FAILED on test $next\n";
--- 168,180 ----
}
$next = $next - 1;
if ($ok && $next == $max) {
! if ($max) {
! print "${te}ok\n";
! $good = $good + 1;
! } else {
! print "${te}skipping test on this platform\n";
! $files -= 1;
! }
} else {
$next += 1;
print "${te}FAILED on test $next\n";
#~ Catch out-of-bounds args to my_trnlnm
#~ Update kill_file() to catch possible change in sys$change_acl() return sts
#~ Update VMS-Unix file syntax conversions: fix bugs, and use simple string
#~ shuffling more often
#~ Allow redirection of error messages
#~ Don't let errors during startup (e.g. expanding wildcards) sneak into $!
#~ Don't attempt wildcard expansion on command line args containing spaces
#~ Don't try to use Perl error reporting functions before we've got an
#~ interpreter initialized
#~ Use fstat() if we've already got a FILE *; name has already been resolved
#~ Add routine to insure no carriage-control translation on an I/O stream;
#~ plugs into Perl's "binmode" operator
#~ Add optional default filespec argument to rmsexpand()
diff -Pcr perl5_003/vms/vms.c perl5_003_01/vms/vms.c
*** perl5_003/vms/vms.c Mon Jun 24 15:46:32 1996
--- perl5_003_01/vms/vms.c Tue Jul 30 16:54:10 1996
***************
*** 2,9 ****
*
* VMS-specific routines for perl5
*
! * Last revised: 21-Jun-1996 by Charles Bailey bailey@genetics.upenn.edu
! * Version: 5.2.2
*/
#include <acedef.h>
--- 2,9 ----
*
* VMS-specific routines for perl5
*
! * Last revised: 18-Jul-1996 by Charles Bailey bailey@genetics.upenn.edu
! * Version: 5.3.1
*/
#include <acedef.h>
***************
*** 33,38 ****
--- 33,45 ----
#include <uaidef.h>
#include <uicdef.h>
+ #ifndef SS$_NOSUCHOBJECT /* Older versions of ssdef.h don't have this */
+ # define SS$_NOSUCHOBJECT 2696
+ #endif
+
+ /* Don't intercept calls to vfork, since my_vfork below needs to
+ * get to the underlying CRTL routine. */
+ #define __DONT_MASK_VFORK
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
***************
*** 75,80 ****
--- 82,90 ----
{LNM$C_NAMLENGTH, LNM$_STRING, 0, &eqvlen},
{0, 0, 0, 0}};
+ if (!lnm || idx > LNM$_MAX_INDEX) {
+ set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
+ }
if (!eqv) eqv = __my_trnlnm_eqv;
lnmlst[1].bufadr = (void *)eqv;
lnmdsc.dsc$a_pointer = lnm;
***************
*** 334,343 ****
}
yourroom:
! if (rmsts) {
! fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
! if (aclsts & 1) aclsts = fndsts;
! }
if (!(aclsts & 1)) {
set_errno(EVMSERR);
set_vaxc_errno(aclsts);
--- 344,356 ----
}
yourroom:
! fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
! /* We just deleted it, so of course it's not there. Some versions of
! * VMS seem to return success on the unlock operation anyhow (after all
! * the unlock is successful), but others don't.
! */
! if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts == SS$_NORMAL;
! if (aclsts & 1) aclsts = fndsts;
if (!(aclsts & 1)) {
set_errno(EVMSERR);
set_vaxc_errno(aclsts);
***************
*** 786,792 ****
static char *do_fileify_dirspec(char *dir,char *buf,int ts)
{
static char __fileify_retbuf[NAM$C_MAXRSS+1];
! unsigned long int dirlen, retlen, addmfd = 0;
char *retspec, *cp1, *cp2, *lastdir;
char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
--- 799,805 ----
static char *do_fileify_dirspec(char *dir,char *buf,int ts)
{
static char __fileify_retbuf[NAM$C_MAXRSS+1];
! unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
char *retspec, *cp1, *cp2, *lastdir;
char trndir[NAM$C_MAXRSS+1], vmsdir[NAM$C_MAXRSS+1];
***************
*** 822,828 ****
dir[dirlen-1] = ']';
}
! if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
if (dir[0] == '.') {
if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
return do_fileify_dirspec("[]",buf,ts);
--- 835,858 ----
dir[dirlen-1] = ']';
}
! if ((cp1 = strrchr(dir,']')) != NULL || (cp1 = strrchr(dir,'>')) != NULL) {
! /* If we've got an explicit filename, we can just shuffle the string. */
! if (*(cp1+1)) hasfilename = 1;
! /* Similarly, we can just back up a level if we've got multiple levels
! of explicit directories in a VMS spec which ends with directories. */
! else {
! for (cp2 = cp1; cp2 > dir; cp2--) {
! if (*cp2 == '.') {
! *cp2 = *cp1; *cp1 = '\0';
! hasfilename = 1;
! break;
! }
! if (*cp2 == '[' || *cp2 == '<') break;
! }
! }
! }
!
! if (hasfilename || !strpbrk(dir,"]:>")) { /* Unix-style path or filename */
if (dir[0] == '.') {
if (dir[1] == '\0' || (dir[1] == '/' && dir[2] == '\0'))
return do_fileify_dirspec("[]",buf,ts);
***************
*** 849,873 ****
} while ((cp1 = strstr(cp1,"/.")) != NULL);
}
else {
! if (!(lastdir = cp1 = strrchr(dir,'/'))) cp1 = dir;
if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
! if (toupper(*(cp2+1)) == 'D' && /* Yep. Is it .dir? */
! toupper(*(cp2+2)) == 'I' &&
! toupper(*(cp2+3)) == 'R') {
! if ((cp1 = strchr(cp2,';')) || (cp1 = strchr(cp2+1,'.'))) {
! if (*(cp1+1) != '1' || *(cp1+2) != '\0') { /* Version is not ;1 */
! set_errno(ENOTDIR); /* Bzzt. */
! set_vaxc_errno(RMS$_DIR);
! return NULL;
! }
! }
! dirlen = cp2 - dir;
! }
! else { /* There's a type, and it's not .dir. Bzzt. */
! set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
}
}
}
/* If we lead off with a device or rooted logical, add the MFD
--- 879,900 ----
} while ((cp1 = strstr(cp1,"/.")) != NULL);
}
else {
! if ( !(lastdir = cp1 = strrchr(dir,'/')) &&
! !(lastdir = cp1 = strrchr(dir,']')) &&
! !(lastdir = cp1 = strrchr(dir,'>'))) cp1 = dir;
if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
! int ver; char *cp3;
! if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
! !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
! !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
! (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
! (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
! (ver || *cp3)))))) {
! set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
}
+ dirlen = cp2 - dir;
}
}
/* If we lead off with a device or rooted logical, add the MFD
***************
*** 1082,1104 ****
}
dir = trndir;
! if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain dir name */
if (*dir == '.' && (*(dir+1) == '\0' ||
(*(dir+1) == '.' && *(dir+2) == '\0')))
retlen = 2 + (*(dir+1) != '\0');
else {
! if (!(cp1 = strrchr(dir,'/'))) cp1 = dir;
! if ((cp2 = strchr(cp1,'.')) && (*(cp2+1) != '.' && *(cp2+1) != '\0')) {
! if (toupper(*(cp2+1)) == 'D' && /* They specified .dir. */
! toupper(*(cp2+2)) == 'I' && /* Trim it off. */
! toupper(*(cp2+3)) == 'R') {
! retlen = cp2 - dir + 1;
! }
! else { /* Some other file type. Bzzt. */
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
}
}
else { /* No file type present. Treat the filename as a directory. */
retlen = strlen(dir) + 1;
--- 1109,1135 ----
}
dir = trndir;
! if (!strpbrk(dir,"]:>")) { /* Unix-style path or plain name */
if (*dir == '.' && (*(dir+1) == '\0' ||
(*(dir+1) == '.' && *(dir+2) == '\0')))
retlen = 2 + (*(dir+1) != '\0');
else {
! if ( !(cp1 = strrchr(dir,'/')) &&
! !(cp1 = strrchr(dir,']')) &&
! !(cp1 = strrchr(dir,'>')) ) cp1 = dir;
! if ((cp2 = strchr(cp1,'.')) != NULL) {
! int ver; char *cp3;
! if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
! !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
! !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
! (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
! (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
! (ver || *cp3)))))) {
set_errno(ENOTDIR);
set_vaxc_errno(RMS$_DIR);
return NULL;
}
+ retlen = cp2 - dir + 1;
}
else { /* No file type present. Treat the filename as a directory. */
retlen = strlen(dir) + 1;
***************
*** 1120,1125 ****
--- 1151,1180 ----
struct FAB dirfab = cc$rms_fab;
struct NAM savnam, dirnam = cc$rms_nam;
+ /* If we've got an explicit filename, we can just shuffle the string. */
+ if ( ( (cp1 = strrchr(dir,']')) != NULL ||
+ (cp1 = strrchr(dir,'>')) != NULL ) && *(cp1+1)) {
+ if ((cp2 = strchr(cp1,'.')) != NULL) {
+ int ver; char *cp3;
+ if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
+ !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
+ !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
+ (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
+ (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
+ (ver || *cp3)))))) {
+ set_errno(ENOTDIR);
+ set_vaxc_errno(RMS$_DIR);
+ return NULL;
+ }
+ }
+ else { /* No file type, so just draw name into directory part */
+ for (cp2 = cp1; *cp2; cp2++) ;
+ }
+ *cp2 = *cp1;
+ *(cp2+1) = '\0'; /* OK; trndir is guaranteed to be long enough */
+ *cp1 = '.';
+ /* We've now got a VMS 'path'; fall through */
+ }
dirfab.fab$b_fns = strlen(dir);
dirfab.fab$l_fna = dir;
if (dir[dirfab.fab$b_fns-1] == ']' ||
***************
*** 1343,1349 ****
int islnm, rooted;
STRLEN trnend;
! while (*(++cp2) == '/') ; /* Skip multiple /s */
while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
*cp1 = '\0';
islnm = my_trnlnm(rslt,trndev,0);
--- 1398,1404 ----
int islnm, rooted;
STRLEN trnend;
! while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
*cp1 = '\0';
islnm = my_trnlnm(rslt,trndev,0);
***************
*** 1604,1610 ****
{
if (j+1 >= argc)
{
! fprintf(stderr,"No input file after < on command line");
exit(LIB$_WRONUMARG);
}
in = argv[++j];
--- 1659,1665 ----
{
if (j+1 >= argc)
{
! fprintf(Perl_debug_log,"No input file after < on command line");
exit(LIB$_WRONUMARG);
}
in = argv[++j];
***************
*** 1619,1625 ****
{
if (j+1 >= argc)
{
! fprintf(stderr,"No output file after > on command line");
exit(LIB$_WRONUMARG);
}
out = argv[++j];
--- 1674,1680 ----
{
if (j+1 >= argc)
{
! fprintf(Perl_debug_log,"No output file after > on command line");
exit(LIB$_WRONUMARG);
}
out = argv[++j];
***************
*** 1639,1645 ****
out = 1 + ap;
if (j >= argc)
{
! fprintf(stderr,"No output file after > or >> on command line");
exit(LIB$_WRONUMARG);
}
continue;
--- 1694,1700 ----
out = 1 + ap;
if (j >= argc)
{
! fprintf(Perl_debug_log,"No output file after > or >> on command line");
exit(LIB$_WRONUMARG);
}
continue;
***************
*** 1661,1667 ****
err = 2 + ap;
if (j >= argc)
{
! fprintf(stderr,"No output file after 2> or 2>> on command line");
exit(LIB$_WRONUMARG);
}
continue;
--- 1716,1722 ----
err = 2 + ap;
if (j >= argc)
{
! fprintf(Perl_debug_log,"No output file after 2> or 2>> on command line");
exit(LIB$_WRONUMARG);
}
continue;
***************
*** 1670,1676 ****
{
if (j+1 >= argc)
{
! fprintf(stderr,"No command into which to pipe on command line");
exit(LIB$_WRONUMARG);
}
cmargc = argc-(j+1);
--- 1725,1731 ----
{
if (j+1 >= argc)
{
! fprintf(Perl_debug_log,"No command into which to pipe on command line");
exit(LIB$_WRONUMARG);
}
cmargc = argc-(j+1);
***************
*** 1701,1707 ****
{
if (out != NULL)
{
! fprintf(stderr,"'|' and '>' may not both be specified on command line");
exit(LIB$_INVARGORD);
}
pipe_and_fork(cmargv);
--- 1756,1762 ----
{
if (out != NULL)
{
! fprintf(Perl_debug_log,"'|' and '>' may not both be specified on command line");
exit(LIB$_INVARGORD);
}
pipe_and_fork(cmargv);
***************
*** 1734,1771 ****
freopen(mbxname, "rb", stdin);
if (errno != 0)
{
! fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
exit(vaxc$errno);
}
}
if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
{
! fprintf(stderr,"Can't open input file %s as stdin",in);
exit(vaxc$errno);
}
if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
{
! fprintf(stderr,"Can't open output file %s as stdout",out);
exit(vaxc$errno);
}
if (err != NULL) {
FILE *tmperr;
if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
{
! fprintf(stderr,"Can't open error file %s as stderr",err);
exit(vaxc$errno);
}
fclose(tmperr);
! if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
{
exit(vaxc$errno);
}
}
#ifdef ARGPROC_DEBUG
! fprintf(stderr, "Arglist:\n");
for (j = 0; j < *ac; ++j)
! fprintf(stderr, "argv[%d] = '%s'\n", j, argv[j]);
#endif
} /* end of getredirection() */
/*}}}*/
--- 1789,1829 ----
freopen(mbxname, "rb", stdin);
if (errno != 0)
{
! fprintf(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);
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);
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);
exit(vaxc$errno);
}
fclose(tmperr);
! if (NULL == freopen(err, "a", Perl_debug_log, "mbc=32", "mbf=2"))
{
exit(vaxc$errno);
}
}
#ifdef ARGPROC_DEBUG
! fprintf(Perl_debug_log, "Arglist:\n");
for (j = 0; j < *ac; ++j)
! fprintf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
#endif
+ /* Clear errors we may have hit expanding wildcards, so they don't
+ show up in Perl's $! later */
+ set_errno(0); set_vaxc_errno(1);
} /* end of getredirection() */
/*}}}*/
***************
*** 1805,1811 ****
$DESCRIPTOR(resultspec, "");
unsigned long int zero = 0, sts;
! if (strcspn(item, "*%") == strlen(item))
{
add_item(head, tail, item, count);
return;
--- 1863,1869 ----
$DESCRIPTOR(resultspec, "");
unsigned long int zero = 0, sts;
! if (strcspn(item, "*%") == strlen(item) || strchr(item,' ') != NULL)
{
add_item(head, tail, item, count);
return;
***************
*** 1862,1867 ****
--- 1920,1926 ----
switch (sts)
{
case RMS$_FNF:
+ case RMS$_DNF:
case RMS$_DIR:
set_errno(ENOENT); break;
case RMS$_DEV:
***************
*** 1871,1883 ****
case RMS$_PRV:
set_errno(EACCES); break;
default:
! _ckvmssts(sts);
}
}
if (expcount == 0)
add_item(head, tail, item, count);
! _ckvmssts(lib$sfree1_dd(&resultspec));
! _ckvmssts(lib$find_file_end(&context));
}
static int child_st[2];/* Event Flag set when child process completes */
--- 1930,1942 ----
case RMS$_PRV:
set_errno(EACCES); break;
default:
! _ckvmssts_noperl(sts);
}
}
if (expcount == 0)
add_item(head, tail, item, count);
! _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
! _ckvmssts_noperl(lib$find_file_end(&context));
}
static int child_st[2];/* Event Flag set when child process completes */
***************
*** 1891,1897 ****
if (0 == child_st[0])
{
#ifdef ARGPROC_DEBUG
! fprintf(stderr, "Waiting for Child Process to Finish . . .\n");
#endif
fflush(stdout); /* Have to flush pipe for binary data to */
/* terminate properly -- <tp@mccall.com> */
--- 1950,1956 ----
if (0 == child_st[0])
{
#ifdef ARGPROC_DEBUG
! fprintf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
#endif
fflush(stdout); /* Have to flush pipe for binary data to */
/* terminate properly -- <tp@mccall.com> */
***************
*** 1906,1912 ****
static void sig_child(int chan)
{
#ifdef ARGPROC_DEBUG
! fprintf(stderr, "Child Completion AST\n");
#endif
if (child_st[0] == 0)
child_st[0] = 1;
--- 1965,1971 ----
static void sig_child(int chan)
{
#ifdef ARGPROC_DEBUG
! fprintf(Perl_debug_log, "Child Completion AST\n");
#endif
if (child_st[0] == 0)
child_st[0] = 1;
***************
*** 1942,1960 ****
create_mbx(&child_chan,&mbxdsc);
#ifdef ARGPROC_DEBUG
! fprintf(stderr, "Pipe Mailbox Name = '%s'\n", mbxdsc.dsc$a_pointer);
! fprintf(stderr, "Sub Process Command = '%s'\n", cmddsc.dsc$a_pointer);
#endif
! _ckvmssts(lib$spawn(&cmddsc, &mbxdsc, 0, &one,
! 0, &pid, child_st, &zero, sig_child,
! &child_chan));
#ifdef ARGPROC_DEBUG
! fprintf(stderr, "Subprocess's Pid = %08X\n", pid);
#endif
sys$dclexh(&exit_block);
if (NULL == freopen(mbxname, "wb", stdout))
{
! fprintf(stderr,"Can't open output pipe (name %s)",mbxname);
}
}
--- 2001,2019 ----
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);
#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);
#endif
sys$dclexh(&exit_block);
if (NULL == freopen(mbxname, "wb", stdout))
{
! fprintf(Perl_debug_log,"Can't open output pipe (name %s)",mbxname);
}
}
***************
*** 1979,1997 ****
}
value.dsc$a_pointer = command;
value.dsc$w_length = strlen(value.dsc$a_pointer);
! _ckvmssts(lib$set_symbol(&cmd, &value));
retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
! _ckvmssts(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
}
else {
! _ckvmssts(retsts);
}
#ifdef ARGPROC_DEBUG
! fprintf(stderr, "%s\n", command);
#endif
sprintf(pidstring, "%08X", pid);
! fprintf(stderr, "%s\n", pidstring);
pidstr.dsc$a_pointer = pidstring;
pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
lib$set_symbol(&pidsymbol, &pidstr);
--- 2038,2056 ----
}
value.dsc$a_pointer = command;
value.dsc$w_length = strlen(value.dsc$a_pointer);
! _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
! _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
}
else {
! _ckvmssts_noperl(retsts);
}
#ifdef ARGPROC_DEBUG
! fprintf(Perl_debug_log, "%s\n", command);
#endif
sprintf(pidstring, "%08X", pid);
! fprintf(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);
***************
*** 3114,3122 ****
}
retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
- #ifndef SS$_NOSUCHOBJECT /* Older versions of ssdef.h don't have this */
- # define SS$_NOSUCHOBJECT 2696
- #endif
if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
retsts == RMS$_FNF || retsts == RMS$_DIR ||
retsts == RMS$_DEV) {
--- 3173,3178 ----
***************
*** 3145,3157 ****
/*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
int
! flex_fstat(int fd, struct stat *statbuf)
{
! char fspec[NAM$C_MAXRSS+1];
!
! if (!getname(fd,fspec,1)) return -1;
! return flex_stat(fspec,statbuf);
} /* end of flex_fstat() */
/*}}}*/
--- 3201,3215 ----
/*{{{ int flex_fstat(int fd, struct stat *statbuf)*/
+ #undef stat
int
! flex_fstat(int fd, struct mystat *statbufp)
{
! if (!fstat(fd,(stat_t *) statbufp)) {
! statbufp->st_dev = encode_dev(statbufp->st_devnam);
! return 0;
! }
! return -1;
} /* end of flex_fstat() */
/*}}}*/
***************
*** 3162,3168 ****
* to the system version here, since we're actually calling their
* stat().
*/
- #undef stat
int
flex_stat(char *fspec, struct mystat *statbufp)
{
--- 3220,3225 ----
***************
*** 3207,3212 ****
--- 3264,3292 ----
#define stat mystat
/*}}}*/
+ /* Insures that no carriage-control translation will be done on a file. */
+ /*{{{FILE *my_binmode(FILE *fp, char iotype)*/
+ FILE *
+ my_binmode(FILE *fp, char iotype)
+ {
+ char filespec[NAM$C_MAXRSS], *acmode;
+ fpos_t pos;
+
+ if (!fgetname(fp,filespec)) return NULL;
+ if (fgetpos(fp,&pos) == -1) return NULL;
+ switch (iotype) {
+ case '<': case 'r': acmode = "rb"; break;
+ case '>': case 'w': acmode = "wb"; break;
+ case '+': case '|': case 's': acmode = "rb+"; break;
+ case 'a': acmode = "ab"; break;
+ case '-': acmode = fileno(fp) ? "wb" : "rb"; break;
+ }
+ if (freopen(filespec,acmode,fp) == NULL) return NULL;
+ if (fsetpos(fp,&pos) == -1) return NULL;
+ } /* end of my_binmode() */
+ /*}}}*/
+
+
/*{{{char *my_getlogin()*/
/* VMS cuserid == Unix getlogin, except calling sequence */
char *
***************
*** 3351,3357 ****
--- 3431,3443 ----
if (preserve_dates & 2) {
/* sys$close() will process xabrdt, not xabdat */
xabrdt = cc$rms_xabrdt;
+ #ifndef __GNUC__
xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
+ #else
+ /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
+ * is unsigned long[2], while DECC & VAXC use a struct */
+ memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
+ #endif
fab_out.fab$l_xab = (void *) &xabrdt;
}
***************
*** 3418,3427 ****
--- 3504,3520 ----
STRLEN speclen;
unsigned long int retsts, haslower = 0;
+ if (items > 2) croak("Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
+
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;
+ }
+
mynam.nam$l_esa = esa;
mynam.nam$b_ess = sizeof esa;
mynam.nam$l_rsa = rsa;
***************
*** 3429,3434 ****
--- 3522,3532 ----
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);
***************
*** 3443,3450 ****
--- 3541,3550 ----
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; }
#~ Remove duplicate pragma
#~ Allow redirection of error messages
#~ Make my_vfork() visible as shim for vfork() and fork()
#~ Add default values for OS-specific cpp macros used in Plan9 and VMS ports
#~ Add cpp macro to report error status without using Perl core
#~ Don't declare struct tms if system headers have already done it for us
#~ Add prototypes for my_vfork() and my_binmode()
diff -Pcr perl5_003/vms/vmsish.h perl5_003_01/vms/vmsish.h
*** perl5_003/vms/vmsish.h Mon Mar 25 01:06:10 1996
--- perl5_003_01/vms/vmsish.h Tue Jul 30 16:56:37 1996
***************
*** 16,30 ****
/* Suppress compiler warnings from DECC for VMS-specific extensions:
* GLOBALEXT, NOSHAREEXT: global[dr]ef declarations
- * ADDRCONSTEXT: initialization of data with non-constant values
- * (e.g. pointer fields of descriptors)
- */
- #ifdef __DECC
- # pragma message disable (GLOBALEXT,NOSHAREEXT,ADDRCONSTEXT)
- #endif
-
- /* Suppress compiler warnings from DECC for VMS-specific extensions:
- * GLOBALEXT, NOSHAREEXT: global[dr]ef declarations
* ADDRCONSTEXT,NEEDCONSTEXT: initialization of data with non-constant values
* (e.g. pointer fields of descriptors)
*/
--- 16,21 ----
***************
*** 96,106 ****
--- 87,99 ----
# define flex_fstat Perl_flex_fstat
# define flex_stat Perl_flex_stat
# define trim_unixpath Perl_trim_unixpath
+ # define my_vfork Perl_my_vfork
# define vms_do_aexec Perl_vms_do_aexec
# define vms_do_exec Perl_vms_do_exec
# define do_aspawn Perl_do_aspawn
# define do_spawn Perl_do_spawn
# define my_fwrite Perl_my_fwrite
+ # define my_binmode Perl_my_binmode
# define my_getpwnam Perl_my_getpwnam
# define my_getpwuid Perl_my_getpwuid
# define my_getpwent Perl_my_getpwent
***************
*** 113,124 ****
/* Delete if at all possible, changing protections if necessary. */
#define unlink kill_file
! /* The VMS C RTL has vfork() but not fork(). Both actually work in a way
! * that's somewhere between Unix vfork() and VMS lib$spawn(), so it's
! * probably not a good idea to use them much. That said, we'll try to
! * use vfork() in either case.
*/
! #define fork vfork
/* Macros to set errno using the VAX thread-safe calls, if present */
#if (defined(__DECC) || defined(__DECCXX)) && !defined(__ALPHA)
--- 106,140 ----
/* Delete if at all possible, changing protections if necessary. */
#define unlink kill_file
! /*
! * Intercept calls to fork, so we know whether subsequent calls to
! * exec should be handled in VMSish or Unixish style.
! */
! #define fork my_vfork
! #ifndef __DONT_MASK_VFORK /* #defined in vms.c so we see real vfork */
! # ifdef vfork
! # undef vfork
! # endif
! # define vfork my_vfork
! #endif
!
! /* BIG_TIME:
! * This symbol is defined if Time_t is an unsigned type on this system.
*/
! #define BIG_TIME
!
! /* USE_STAT_RDEV:
! * This symbol is defined if this system has a stat structure declaring
! * st_rdev
! */
! #define USE_STAT_RDEV /**/
!
! /* ACME_MESS:
! * This symbol, if defined, indicates that error messages should be
! * should be generated in a format that allows the use of the Acme
! * GUI/editor's autofind feature.
! */
! #undef ACME_MESS /**/
/* Macros to set errno using the VAX thread-safe calls, if present */
#if (defined(__DECC) || defined(__DECCXX)) && !defined(__ALPHA)
***************
*** 136,141 ****
--- 152,165 ----
croak("Fatal VMS error (status=%d) at %s, line %d", \
__ckvms_sts,__FILE__,__LINE__); } } STMT_END
+ /* Same thing, but don't call back to Perl's croak(); useful for errors
+ * occurring during startup, before Perl's state is initialized */
+ #define _ckvmssts_noperl(call) STMT_START { register unsigned long int __ckvms_sts; \
+ if (!((__ckvms_sts=(call))&1)) { \
+ set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \
+ fprintf(Perl_debug_log,"Fatal VMS error (status=%d) at %s, line %d", \
+ __ckvms_sts,__FILE__,__LINE__); lib$signal(__ckvms_sts); } } STMT_END
+
#ifdef VMS_DO_SOCKETS
#include "sockadapt.h"
#endif
***************
*** 184,189 ****
--- 208,221 ----
#define HAS_KILL
#define HAS_WAIT
+ /* USEMYBINMODE
+ * This symbol, if defined, indicates that the program should
+ * use the routine my_binmode(FILE *fp, char iotype) to insure
+ * that a file is in "binary" mode -- that is, that no translation
+ * of bytes occurs on read or write operations.
+ */
+ #define USEMYBINMODE
+
/*
* fwrite1() should be a routine with the same calling sequence as fwrite(),
* but which outputs all of the bytes requested as a single stream (unlike
***************
*** 206,219 ****
};
#define utime my_utime
! /* This is what times() returns, but <times.h> calls it tbuffer_t on VMS */
! struct tms {
! clock_t tms_utime; /* user time */
! clock_t tms_stime; /* system time - always 0 on VMS */
! clock_t tms_cutime; /* user time, children */
! clock_t tms_cstime; /* system time, children - always 0 on VMS */
! };
/* Prior to VMS 7.0, the CRTL gmtime() routine was a stub which always
* returned NULL. Substitute our own routine, which uses the logical
--- 238,257 ----
};
#define utime my_utime
! /* This is what times() returns, but <times.h> calls it tbuffer_t on VMS
! * prior to v7.0. We check the DECC manifest to see whether it's already
! * done this for us, relying on the fact that perl.h #includes <time.h>
! * before it #includes "vmsish.h".
! */
! #ifndef __TMS
! struct tms {
! clock_t tms_utime; /* user time */
! clock_t tms_stime; /* system time - always 0 on VMS */
! clock_t tms_cutime; /* user time, children */
! clock_t tms_cstime; /* system time, children - always 0 on VMS */
! };
! #endif
/* Prior to VMS 7.0, the CRTL gmtime() routine was a stub which always
* returned NULL. Substitute our own routine, which uses the logical
***************
*** 394,404 ****
--- 432,444 ----
int flex_fstat _((int, struct stat *));
int flex_stat _((char *, struct stat *));
int trim_unixpath _((char *, char*));
+ int my_vfork _(());
bool vms_do_aexec _((SV *, SV **, SV **));
bool vms_do_exec _((char *));
unsigned long int do_aspawn _((SV *, SV **, SV **));
unsigned long int do_spawn _((char *));
int my_fwrite _((void *, size_t, size_t, FILE *));
+ FILE * my_binmode _((FILE *, char));
struct passwd * my_getpwnam _((char *name));
struct passwd * my_getpwuid _((Uid_t uid));
struct passwd * my_getpwent _(());
#~ Remove "" from command line args
diff -Pcr perl5_003/vms/writemain.pl perl5_003_01/vms/writemain.pl
*** perl5_003/vms/writemain.pl Mon Mar 25 01:06:10 1996
--- perl5_003_01/vms/writemain.pl Mon Apr 29 12:25:51 1996
***************
*** 40,47 ****
EOH
if (@ARGV) {
# Allow for multiple names in one quoted group
! @exts = split(/\s+/, join(' ',@ARGV));
}
if (@exts) {
--- 40,49 ----
EOH
if (@ARGV) {
+ $names = join(' ',@ARGV);
+ $names =~ tr/"//d; # Plan9 doesn't remove "" on command line
# Allow for multiple names in one quoted group
! @exts = split(/\s+/,$names);
}
if (@exts) {
#~ Delete old version of target before generating new one
diff -Pcr perl5_003/writemain.SH perl5_003_01/writemain.SH
*** perl5_003/writemain.SH Mon Mar 25 01:06:10 1996
--- perl5_003_01/writemain.SH Thu Jul 11 12:25:57 1996
***************
*** 21,26 ****
--- 21,27 ----
: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
: Protect any dollar signs and backticks that you do not want interpreted
: by putting a backslash in front. You may delete these comments.
+ rm -f writemain
$spitshell >writemain <<!GROK!THIS!
$startsh
!GROK!THIS!
#~ Add MAB support for NeXT
#~ Set up variable pointing to shell for OS/2 compatibility
diff -Pcr perl5_003/x2p/Makefile.SH perl5_003_01/x2p/Makefile.SH
*** perl5_003/x2p/Makefile.SH Mon Mar 25 01:06:13 1996
--- perl5_003_01/x2p/Makefile.SH Thu Jul 11 12:35:36 1996
***************
*** 17,34 ****
*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
esac
echo "Extracting x2p/Makefile (with variable substitutions)"
rm -f Makefile
cat >Makefile <<!GROK!THIS!
! # $RCSfile: Makefile.SH,v $$Revision: 4.1 $$Date: 92/08/07 18:29:07 $
#
# $Log: Makefile.SH,v $
CC = $cc
BYACC = $byacc
LDFLAGS = $ldflags
SMALL = $small
LARGE = $large $split
mallocsrc = $mallocsrc
mallocobj = $mallocobj
shellflags = $shellflags
--- 17,40 ----
*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
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 $
#
# $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
***************
*** 47,52 ****
--- 53,61 ----
.SUFFIXES: .c \$(OBJ_EXT)
+ # grrr
+ SHELL = $bin_sh
+
!GROK!THIS!
cat >>Makefile <<'!NO!SUBS!'
***************
*** 77,93 ****
lintflags = -phbvxac
- # grrr
- SHELL = /bin/sh
-
.c$(OBJ_EXT):
! $(CCCMD) $*.c
all: $(public) $(private) $(util)
touch all
a2p: $(obj) a2p$(OBJ_EXT)
! $(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
--- 86,99 ----
lintflags = -phbvxac
.c$(OBJ_EXT):
! $(CCCMD) $(MAB) $*.c
all: $(public) $(private) $(util)
touch all
a2p: $(obj) a2p$(OBJ_EXT)
! $(CC) $(MAB) $(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
***************
*** 104,110 ****
-@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) a2p.c
clean:
rm -f a2p *$(OBJ_EXT)
--- 110,116 ----
-@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
clean:
rm -f a2p *$(OBJ_EXT)
#~ Update NeXT support
diff -Pcr perl5_003/x2p/a2p.h perl5_003_01/x2p/a2p.h
*** perl5_003/x2p/a2p.h Sat Jan 20 01:00:41 1996
--- perl5_003_01/x2p/a2p.h Thu Jul 11 12:34:06 1996
***************
*** 1,4 ****
! /* $RCSfile: a2p.h,v $$Revision: 4.1 $$Date: 92/08/07 18:29:09 $
*
* Copyright (c) 1991, Larry Wall
*
--- 1,4 ----
! /* $RCSfile: a2p.h,v $$Revision: 4.1 $$Date: 1996/07/05 23:49:58 $
*
* Copyright (c) 1991, Larry Wall
*
***************
*** 6,11 ****
--- 6,14 ----
* 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"
***************
*** 32,42 ****
#endif
! #ifdef USE_NEXT_CTYPE
#include <appkit/NXCType.h>
! #else
#include <ctype.h>
! #endif
#define MEM_SIZE Size_t
--- 35,51 ----
#endif
! #ifdef USE_NEXT_CTYPE
!
! #if NX_CURRENT_COMPILER_RELEASE >= 400
! #include <objc/NXCType.h>
! #else /* NX_CURRENT_COMPILER_RELEASE < 400 */
#include <appkit/NXCType.h>
! #endif /* NX_CURRENT_COMPILER_RELEASE >= 400 */
!
! #else /* !USE_NEXT_CTYPE */
#include <ctype.h>
! #endif /* USE_NEXT_CTYPE */
#define MEM_SIZE Size_t
#~ Delete old version of target before generating new one
diff -Pcr perl5_003/x2p/cflags.SH perl5_003_01/x2p/cflags.SH
*** perl5_003/x2p/cflags.SH Sat Jan 20 01:00:46 1996
--- perl5_003_01/x2p/cflags.SH Thu Jul 11 12:27:18 1996
***************
*** 21,26 ****
--- 21,27 ----
: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
: Protect any dollar signs and backticks that you do not want interpreted
: by putting a backslash in front. You may delete these comments.
+ rm -f cflags
$spitshell >cflags <<!GROK!THIS!
!GROK!THIS!
## End of patch ##